mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-03-03 04:21:28 -08:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into xwidget

Browse source
This commit is contained in:
Joakim Verona 2015-01-22 00:05:27 +01:00
commit d6ada5ae0f
22 changed files with 508 additions and 278 deletions
Download patch file Download diff file Expand all files Collapse all files

7
ChangeLog
View file

@ -1,3 +1,10 @@
2015-01-21 Ulrich Müller <ulm@gentoo.org>
* configure.ac (gamegroup): New AC_SUBST.
(--with-gameuser): Allow to specify a group instead of a user.
In the default case, check at configure time if a 'games' user
exists.
2015-01-16 Paul Eggert <eggert@cs.ucla.edu>
Give up on -Wsuggest-attribute=const

24
configure.ac
View file

@ -394,10 +394,25 @@ OPTION_DEFAULT_ON([compress-install],
make GZIP_PROG= install])
AC_ARG_WITH(gameuser,dnl
[AS_HELP_STRING([--with-gameuser=USER],[user for shared game score files])])
test "X${with_gameuser}" != X && test "${with_gameuser}" != yes \
&& gameuser="${with_gameuser}"
test "X$gameuser" = X && gameuser=games
[AS_HELP_STRING([--with-gameuser=USER_OR_GROUP],
[user for shared game score files.
An argument prefixed by ':' specifies a group instead.])])
gameuser=
gamegroup=
case ${with_gameuser} in
no) ;;
"" | yes)
AC_MSG_CHECKING([whether a 'games' user exists])
if id -u games >/dev/null 2>&1; then
AC_MSG_RESULT([yes])
gameuser=games
else
AC_MSG_RESULT([no])
fi
;;
:*) gamegroup=`echo "${with_gameuser}" | sed -e "s/://"` ;;
*) gameuser=${with_gameuser} ;;
esac
AC_ARG_WITH([gnustep-conf],dnl
[AS_HELP_STRING([--with-gnustep-conf=FILENAME],
@ -4721,6 +4736,7 @@ AC_SUBST(etcdocdir)
AC_SUBST(bitmapdir)
AC_SUBST(gamedir)
AC_SUBST(gameuser)
AC_SUBST(gamegroup)
## FIXME? Nothing uses @LD_SWITCH_X_SITE@.
## src/Makefile.in did add LD_SWITCH_X_SITE (as a cpp define) to the
## end of LIBX_BASE, but nothing ever set it.

7
etc/NEWS
View file

@ -45,6 +45,13 @@ and silent rules are now quieter. To get the old behavior where
'make' chatters a lot, configure with '--disable-silent-rules' or
build with 'make V=1'.
---
** The configure option '--with-gameuser' now allows to specify a
group instead of a user if its argument is prefixed by ':' (a colon).
This will cause the game score files in ${localstatedir}/games/emacs
to be owned by that group, and the helper program for updating them to
be installed setgid.
---
** The `grep-changelog' script (and its manual page) are no longer included.
It has no particular connection to Emacs and has not changed in years,

12
lib-src/ChangeLog
View file

@ -1,3 +1,15 @@
2015-01-21 Ulrich Müller <ulm@gentoo.org>
* update-game-score.c: Allow the program to run sgid instead
of suid, in order to match common practice for most games.
(main): Check if we are running sgid. Pass appropriate file
permission bits to 'write_scores'.
(write_scores): New 'mode' argument, instead of hardcoding 0644.
(get_prefix): Update error message.
* Makefile.in (gamegroup): New variable, set by configure.
($(DESTDIR)${archlibdir}): Handle both suid or sgid when
installing the 'update-game-score' program.
2015-01-16 Eli Zaretskii <eliz@gnu.org>
* Makefile.in (AM_V_RC, am__v_RC_, am__v_RC_0, am__v_RC_1): New

16
lib-src/Makefile.in
View file

@ -122,6 +122,7 @@ archlibdir=@archlibdir@
gamedir=@gamedir@
gameuser=@gameuser@
gamegroup=@gamegroup@
# ==================== Utility Programs for the Build =================
@ -263,10 +264,17 @@ $(DESTDIR)${archlibdir}: all
umask 022; ${MKDIR_P} "$(DESTDIR)${gamedir}"; \
touch "$(DESTDIR)${gamedir}/snake-scores"; \
touch "$(DESTDIR)${gamedir}/tetris-scores"
-if chown ${gameuser} "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}" && chmod u+s "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}"; then \
chown ${gameuser} "$(DESTDIR)${gamedir}"; \
chmod u=rwx,g=rwx,o=rx "$(DESTDIR)${gamedir}"; \
fi
ifneq ($(gameuser),)
chown ${gameuser} "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}"
chmod u+s,go-r "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}"
chown ${gameuser} "$(DESTDIR)${gamedir}"
chmod u=rwx,g=rx,o=rx "$(DESTDIR)${gamedir}"
else ifneq ($(gamegroup),)
chgrp ${gamegroup} "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}"
chmod g+s,o-r "$(DESTDIR)${archlibdir}/update-game-score${EXEEXT}"
chgrp ${gamegroup} "$(DESTDIR)${gamedir}"
chmod u=rwx,g=rwx,o=rx "$(DESTDIR)${gamedir}"
endif
exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && /bin/pwd`; \
if [ "$$exp_archlibdir" != "`cd ${srcdir} && /bin/pwd`" ]; then \
for file in ${SCRIPTS}; do \

33
lib-src/update-game-score.c
View file

@ -21,8 +21,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
/* This program allows a game to securely and atomically update a
score file. It should be installed setuid, owned by an appropriate
user like `games'.
score file. It should be installed either setuid or setgid, owned
by an appropriate user or group like `games'.
Alternatively, it can be compiled without HAVE_SHARED_GAME_DIR
defined, and in that case it will store scores in the user's home
@ -88,7 +88,7 @@ static int push_score (struct score_entry **scores, ptrdiff_t *count,
ptrdiff_t *size, struct score_entry const *newscore);
static void sort_scores (struct score_entry *scores, ptrdiff_t count,
bool reverse);
static int write_scores (const char *filename,
static int write_scores (const char *filename, mode_t mode,
const struct score_entry *scores, ptrdiff_t count);
static _Noreturn void
@ -122,18 +122,19 @@ get_user_id (void)
}
static const char *
get_prefix (bool running_suid, const char *user_prefix)
get_prefix (bool privileged, const char *user_prefix)
{
if (!running_suid && user_prefix == NULL)
lose ("Not using a shared game directory, and no prefix given.");
if (running_suid)
if (privileged)
{
#ifdef HAVE_SHARED_GAME_DIR
return HAVE_SHARED_GAME_DIR;
#else
lose ("This program was compiled without HAVE_SHARED_GAME_DIR,\n and should not be suid.");
lose ("This program was compiled without HAVE_SHARED_GAME_DIR,\n"
"and should not run with elevated privileges.");
#endif
}
if (user_prefix == NULL)
lose ("Not using a shared game directory, and no prefix given.");
return user_prefix;
}
@ -173,7 +174,7 @@ int
main (int argc, char **argv)
{
int c;
bool running_suid;
bool running_suid, running_sgid;
void *lockstate;
char *scorefile;
char *end, *nl, *user, *data;
@ -214,8 +215,11 @@ main (int argc, char **argv)
usage (EXIT_FAILURE);
running_suid = (getuid () != geteuid ());
running_sgid = (getgid () != getegid ());
if (running_suid && running_sgid)
lose ("This program can run either suid or sgid, but not both.");
prefix = get_prefix (running_suid, user_prefix);
prefix = get_prefix (running_suid || running_sgid, user_prefix);
scorefile = malloc (strlen (prefix) + strlen (argv[optind]) + 2);
if (!scorefile)
@ -270,7 +274,8 @@ main (int argc, char **argv)
scores += scorecount - max_scores;
scorecount = max_scores;
}
if (write_scores (scorefile, scores, scorecount) < 0)
if (write_scores (scorefile, running_sgid ? 0664 : 0644,
scores, scorecount) < 0)
{
unlock_file (scorefile, lockstate);
lose_syserr ("Failed to write scores file");
@ -421,8 +426,8 @@ sort_scores (struct score_entry *scores, ptrdiff_t count, bool reverse)
}
static int
write_scores (const char *filename, const struct score_entry *scores,
ptrdiff_t count)
write_scores (const char *filename, mode_t mode,
const struct score_entry *scores, ptrdiff_t count)
{
int fd;
FILE *f;
@ -435,7 +440,7 @@ write_scores (const char *filename, const struct score_entry *scores,
if (fd < 0)
return -1;
#ifndef DOS_NT
if (fchmod (fd, 0644) != 0)
if (fchmod (fd, mode) != 0)
return -1;
#endif
f = fdopen (fd, "w");

70
lisp/ChangeLog
View file

@ -1,3 +1,73 @@
2015-01-21 Ulrich Müller <ulm@gentoo.org>
* play/gamegrid.el (gamegrid-add-score-with-update-game-score):
Allow the 'update-game-score' helper program to run suid or sgid.
2015-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el: Use cl-defmethod.
(defclass): Generate cl-defmethod calls; use setf methods for :accessor.
(eieio-object-name-string): Declare as obsolete.
* emacs-lisp/eieio-opt.el: Adapt to cl-generic.
(eieio--specializers-apply-to-class-p): New function.
(eieio-all-generic-functions): Use it.
(eieio-method-documentation): Use it as well as cl--generic-method-info.
Change format of return value.
(eieio-help-class): Adapt accordingly.
* emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method
errors when there's a `before' but no `primary' (bug#19645).
(next-method-p): Return nil rather than signal an error.
(eieio-defgeneric): Remove bogus (fboundp 'method).
* emacs-lisp/eieio-speedbar.el:
* emacs-lisp/eieio-datadebug.el:
* emacs-lisp/eieio-custom.el:
* emacs-lisp/eieio-base.el: Use cl-defmethod.
* emacs-lisp/cl-generic.el (cl-defgeneric): Add support for `declare'.
(cl--generic-setf-rewrite): Setup the setf expander right away.
(cl-defmethod): Make sure the setf expander is setup before we expand
the body.
(cl-defmethod): Silence byte-compiler warnings.
(cl-generic-define-method): Shuffle code to change return value.
(cl--generic-method-info): New function, extracted from
cl--generic-describe.
(cl--generic-describe): Use it.
2015-01-21 Dmitry Gutov <dgutov@yandex.ru>
* progmodes/xref.el (xref--xref-buffer-mode-map): Define before
the major mode. Remap `quit-window' to `xref-quit'.
(xref--xref-buffer-mode): Inherit from special-mode.
xref: Keep track of temporary buffers (bug#19466).
* progmodes/xref.el (xref--temporary-buffers, xref--selected)
(xref--inhibit-mark-selected): New variables.
(xref--mark-selected): New function.
(xref--show-location): Maybe add the buffer to
`xref--temporary-buffers', add `xref--mark-selected' to
`buffer-list-update-hook' there.
(xref--window): Add docstring.
(xref-quit): Rename from `xref--quit'. Update both references.
Add KILL argument. When it's non-nil, kill the temporary buffers
that haven't been selected by the user.
(xref--show-xref-buffer): Change the second argument to alist,
extract the values for `xref--window' and
`xref--temporary-buffers' from it. Add `xref--mark-selected' to
`buffer-list-update-hook' to each buffer in the list.
(xref--show-xrefs): Move the logic of calling `xref-find-function'
here. Save the difference between buffer lists before and after
it's called as "temporary buffers", and `pass it to
`xref-show-xrefs-function'.
(xref--find-definitions, xref-find-references)
(xref-find-apropos): Update accordingly.
2015-01-20 Artur Malabarba <bruce.connor.am@gmail.com>
* emacs-lisp/package.el (package-dir-info): Fix `while' logic.
2015-01-20 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio-generic.el: Remove.

122
lisp/emacs-lisp/cl-generic.el
View file

@ -98,19 +98,20 @@ They should be sorted from most specific to least specific.")
(:constructor cl--generic-make
(name &optional dispatches method-table))
(:predicate nil))
(name nil :read-only t) ;Pointer back to the symbol.
(name nil :type symbol :read-only t) ;Pointer back to the symbol.
;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
;; where the EXPs are expressions (to be `or'd together) to compute the tag
;; on which to dispatch and PRIORITY is the priority of each expression to
;; decide in which order to sort them.
;; The most important dispatch is last in the list (and the least is first).
dispatches
(dispatches nil :type (list-of (cons natnum (list-of tagcode))))
;; `method-table' is a list of
;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
;; (and hence expects an extra argument holding the next-method).
method-table)
(method-table nil :type (list-of (cons (cons (list-of type) keyword)
(cons boolean function)))))
(defmacro cl--generic (name)
`(get ,name 'cl--generic))
@ -134,15 +135,16 @@ They should be sorted from most specific to least specific.")
generic))
(defun cl--generic-setf-rewrite (name)
(let ((setter (intern (format "cl-generic-setter--%s" name))))
(cons setter
`(eval-and-compile
(unless (eq ',setter (get ',name 'cl-generic-setter))
;; (when (get ',name 'gv-expander)
;; (error "gv-expander conflicts with (setf %S)" ',name))
(setf (get ',name 'cl-generic-setter) ',setter)
(gv-define-setter ,name (val &rest args)
(cons ',setter (cons val args))))))))
(let* ((setter (intern (format "cl-generic-setter--%s" name)))
(exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
;; (when (get ',name 'gv-expander)
;; (error "gv-expander conflicts with (setf %S)" ',name))
(setf (get ',name 'cl-generic-setter) ',setter)
(gv-define-setter ,name (val &rest args)
(cons ',setter (cons val args))))))
;; Make sure `setf' can be used right away, e.g. in the body of the method.
(eval exp t)
(cons setter exp)))
;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
@ -151,8 +153,9 @@ DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
is appropriate to use. Specific methods are defined with `cl-defmethod'.
With this implementation the ARGS are currently ignored.
OPTIONS-AND-METHODS is currently only used to specify the docstring,
via (:documentation DOCSTRING)."
OPTIONS-AND-METHODS currently understands:
- (:documentation DOCSTRING)
- (declare DECLARATIONS)"
(declare (indent 2) (doc-string 3))
(let* ((docprop (assq :documentation options-and-methods))
(doc (cond ((stringp (car-safe options-and-methods))
@ -161,13 +164,26 @@ via (:documentation DOCSTRING)."
(prog1
(cadr docprop)
(setq options-and-methods
(delq docprop options-and-methods)))))))
(delq docprop options-and-methods))))))
(declarations (assq 'declare options-and-methods)))
(when declarations
(setq options-and-methods
(delq declarations options-and-methods)))
`(progn
,(when (eq 'setf (car-safe name))
(pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
(cadr name))))
(setq name setter)
code))
,@(mapcar (lambda (declaration)
(let ((f (cdr (assq (car declaration)
defun-declarations-alist))))
(cond
(f (apply (car f) name args (cdr declaration)))
(t (message "Warning: Unknown defun property `%S' in %S"
(car declaration) name)
nil))))
(cdr declarations))
(defalias ',name
(cl-generic-define ',name ',args ',options-and-methods)
,(help-add-fundoc-usage doc args)))))
@ -292,18 +308,19 @@ which case this method will be invoked when the argument is `eql' to VAL.
list ; arguments
[ &optional stringp ] ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
(let ((qualifiers nil)
(setfizer (if (eq 'setf (car-safe name))
;; Call it before we call cl--generic-lambda.
(cl--generic-setf-rewrite (cadr name)))))
(while (keywordp args)
(push args qualifiers)
(setq args (pop body)))
(pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
(`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
`(progn
,(when (eq 'setf (car-safe name))
(pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
(cadr name))))
(setq name setter)
code))
,(when setfizer
(setq name (car setfizer))
(cdr setfizer))
,(and (get name 'byte-obsolete-info)
(or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete))
@ -311,6 +328,11 @@ which case this method will be invoked when the argument is `eql' to VAL.
(macroexp--warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
;; function, so warnings like "not known to be defined" are fair game.
;; But in practice, it's common to use `cl-defmethod'
;; without a previous `cl-defgeneric'.
(declare-function ,name "")
(cl-generic-define-method ',name ',qualifiers ',args
,uses-cnm ,fun)))))
@ -344,14 +366,14 @@ which case this method will be invoked when the argument is `eql' to VAL.
(if me (setcdr me (cons uses-cnm function))
(setf (cl--generic-method-table generic)
(cons `(,key ,uses-cnm . ,function) mt)))
;; For aliases, cl--generic-name gives us the actual name.
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)
(let ((gfun (cl--generic-make-function generic))
;; Prevent `defalias' from recording this as the definition site of
;; the generic function.
current-load-list)
(defalias (cl--generic-name generic) gfun))
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)))
;; For aliases, cl--generic-name gives us the actual name.
(defalias (cl--generic-name generic) gfun))))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
@ -448,8 +470,12 @@ for all those different tags in the method-cache.")
;; We don't currently have "method objects" like CLOS
;; does so we can't really do it the CLOS way.
;; The closest would be to pass the lambda corresponding
;; to the method, but the caller wouldn't be able to do
;; much with it anyway. So we pass nil for now.
;; to the method, or maybe the ((SPECIALIZERS
;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method
;; table, but the caller wouldn't be able to do much with
;; it anyway. So we pass nil for now.
;; FIXME: signal `no-primary-method' if there's
;; no primary.
(apply #'cl-no-next-method generic-name nil args)))
;; We use `cdr' to drop the `uses-cnm' annotations.
(before
@ -566,6 +592,24 @@ Can only be used from within the lexical body of a primary or around method."
(add-to-list 'find-function-regexp-alist
`(cl-defmethod . ,#'cl--generic-search-method)))
(defun cl--generic-method-info (method)
(pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method))
(let* ((args (help-function-arglist function 'names))
(docstring (documentation function))
(doconly (if docstring
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
(if uses-cnm (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
(pop args))))
(push (if (eq specializer t) arg (list arg specializer))
combined-args)))
(setq combined-args (append (nreverse combined-args) args))
(list qualifier combined-args doconly))))
(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
(let ((generic (if (symbolp function) (cl--generic function))))
@ -575,25 +619,11 @@ Can only be used from within the lexical body of a primary or around method."
(insert "\n\nThis is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
(pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method)
(cl--generic-method-table generic))
(let* ((args (help-function-arglist method 'names))
(docstring (documentation method))
(doconly (if docstring
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
(if uses-cnm (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
(pop args))))
(push (if (eq specializer t) arg (list arg specializer))
combined-args)))
(setq combined-args (append (nreverse combined-args) args))
(dolist (method (cl--generic-method-table generic))
(let* ((info (cl--generic-method-info method)))
;; FIXME: Add hyperlinks for the types as well.
(insert (format "%S %S" qualifier combined-args))
(let* ((met-name (cons function specializers))
(insert (format "%S %S" (nth 0 info) (nth 1 info)))
(let* ((met-name (cons function (caar method)))
(file (find-lisp-object-file-name met-name 'cl-defmethod)))
(when file
(insert " in `")
@ -601,7 +631,7 @@ Can only be used from within the lexical body of a primary or around method."
'help-function-def met-name file
'cl-defmethod)
(insert "'.\n")))
(insert "\n" (or doconly "Undocumented") "\n\n")))))))
(insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
;;; Support for (eql <val>) specializers.

36
lisp/emacs-lisp/eieio-base.el
View file

@ -52,7 +52,7 @@ a parent instance. When a slot in the child is referenced, and has
not been set, use values from the parent."
:abstract t)
(defmethod slot-unbound ((object eieio-instance-inheritor)
(cl-defmethod slot-unbound ((object eieio-instance-inheritor)
_class slot-name _fn)
"If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
SLOT-NAME is the offending slot. FN is the function signaling the error."
@ -61,16 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
;; method if the parent instance's slot is unbound.
(eieio-oref (oref object parent-instance) slot-name)
;; Throw the regular signal.
(call-next-method)))
(cl-call-next-method)))
(defmethod clone ((obj eieio-instance-inheritor) &rest _params)
(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params)
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let ((nobj (call-next-method)))
(let ((nobj (cl-call-next-method)))
(oset nobj parent-instance obj)
nobj))
(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
slot)
"Return non-nil if the instance inheritor OBJECT's SLOT is bound.
See `slot-boundp' for details on binding slots.
@ -103,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is
a variable symbol used to store a list of all instances."
:abstract t)
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
(cl-defmethod initialize-instance :after ((this eieio-instance-tracker)
&rest _slots)
"Make sure THIS is in our master list of this class.
Optional argument SLOTS are the initialization arguments."
@ -112,7 +112,7 @@ Optional argument SLOTS are the initialization arguments."
(if (not (memq this (symbol-value sym)))
(set sym (append (symbol-value sym) (list this))))))
(defmethod delete-instance ((this eieio-instance-tracker))
(cl-defmethod delete-instance ((this eieio-instance-tracker))
"Remove THIS from the master list of this class."
(set (oref this tracking-symbol)
(delq this (symbol-value (oref this tracking-symbol)))))
@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
A singleton is a class which will only ever have one instance."
:abstract t)
(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots)
"Constructor for singleton CLASS.
NAME and SLOTS initialize the new object.
This constructor guarantees that no matter how many you request,
@ -149,7 +149,7 @@ only one object ever exists."
;; with class allocated slots or default values.
(let ((old (oref-default class singleton)))
(if (eq old eieio-unbound)
(oset-default class singleton (call-next-method))
(oset-default class singleton (cl-call-next-method))
old)))
@ -198,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg'
specified will not be saved."
:abstract t)
(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
&optional name)
"Prepare to save THIS. Use in an `interactive' statement.
Query user for file name with PROMPT if THIS does not yet specify
@ -417,17 +417,17 @@ If no class is referenced there, then return nil."
;; No match, not a class.
nil)))
(defmethod object-write ((this eieio-persistent) &optional comment)
(cl-defmethod object-write ((this eieio-persistent) &optional comment)
"Write persistent object THIS out to the current stream.
Optional argument COMMENT is a header line comment."
(call-next-method this (or comment (oref this file-header-line))))
(cl-call-next-method this (or comment (oref this file-header-line))))
(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
"For object THIS, make absolute file name FILE relative."
(file-relative-name (expand-file-name file)
(file-name-directory (oref this file))))
(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
"Save persistent object THIS to disk.
Optional argument FILE overrides the file name specified in the object
instance."
@ -474,21 +474,21 @@ instance."
"Object with a name."
:abstract t)
(defmethod eieio-object-name-string ((obj eieio-named))
(cl-defmethod eieio-object-name-string ((obj eieio-named))
"Return a string which is OBJ's name."
(or (slot-value obj 'object-name)
(symbol-name (eieio-object-class obj))))
(defmethod eieio-object-set-name-string ((obj eieio-named) name)
(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
"Set the string which is OBJ's NAME."
(eieio--check-type stringp name)
(eieio-oset obj 'object-name name))
(defmethod clone ((obj eieio-named) &rest params)
(cl-defmethod clone ((obj eieio-named) &rest params)
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let* ((newname (and (stringp (car params)) (pop params)))
(nobj (apply #'call-next-method obj params))
(nobj (apply #'cl-call-next-method obj params))
(nm (slot-value obj 'object-name)))
(eieio-oset obj 'object-name
(or newname

33
lisp/emacs-lisp/eieio-compat.el
View file

@ -190,13 +190,27 @@ Summary:
(if split (cdr split) docstring))))
(new-docstring (help-add-fundoc-usage doc-only
(cons 'cl-cnm args))))
;; FIXME: ¡Add the new-docstring to those closures!
;; FIXME: ¡Add new-docstring to those closures!
(lambda (cnm &rest args)
(cl-letf (((symbol-function 'call-next-method) cnm)
((symbol-function 'next-method-p)
(lambda () (cl--generic-isnot-nnm-p cnm))))
(apply code args))))
code))))
code))
;; The old EIEIO code did not signal an error when there are methods
;; applicable but only of the before/after kind. So if we add a :before
;; or :after, make sure there's a matching dummy primary.
(when (and (memq kind '(:before :after))
(not (assoc (cons (mapcar (lambda (arg)
(if (consp arg) (nth 1 arg) t))
specializers)
:primary)
(cl--generic-method-table (cl--generic method)))))
(cl-generic-define-method method () specializers t
(lambda (cnm &rest args)
(if (cl--generic-isnot-nnm-p cnm)
(apply cnm args)))))
method))
;; Compatibility with code which tries to catch `no-method-definition' errors.
(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
@ -212,7 +226,12 @@ Summary:
(apply #'cl-no-applicable-method method object args))
(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
(define-obsolete-function-alias 'next-method-p 'cl-next-method-p "25.1")
(defun next-method-p ()
(declare (obsolete cl-next-method-p "25.1"))
;; EIEIO's `next-method-p' just returned nil when called in an
;; invalid context.
(message "next-method-p called outside of a primary or around method")
nil)
;;;###autoload
(defun eieio-defmethod (method args)
@ -225,11 +244,9 @@ Summary:
(defun eieio-defgeneric (method doc-string)
"Obsolete work part of an old version of the `defgeneric' macro."
(declare (obsolete cl-defgeneric "24.1"))
;; Don't do this over and over.
(unless (fboundp 'method)
(eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
;; Return the method
'method))
(eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
;; Return the method
'method)
;;;###autoload
(defun eieio-defclass (cname superclasses slots options)

23
lisp/emacs-lisp/eieio-core.el
View file

@ -1258,7 +1258,7 @@ method invocation orders of the involved classes."
(eieio--class-precedence-list tag))))
;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "b177169dfbad7fb2e9d500b9c40002fa")
;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "51667b1cd372f45acdae14f838cedcc6")
;;; Generated autoloads from eieio-compat.el
(autoload 'eieio--defalias "eieio-compat" "\
@ -1325,6 +1325,27 @@ Summary:
\(fn METHOD KIND ARGCLASS CODE)" nil nil)
(autoload 'eieio-defmethod "eieio-compat" "\
Obsolete work part of an old version of the `defmethod' macro.
\(fn METHOD ARGS)" nil nil)
(make-obsolete 'eieio-defmethod 'cl-defmethod '"24.1")
(autoload 'eieio-defgeneric "eieio-compat" "\
Obsolete work part of an old version of the `defgeneric' macro.
\(fn METHOD DOC-STRING)" nil nil)
(make-obsolete 'eieio-defgeneric 'cl-defgeneric '"24.1")
(autoload 'eieio-defclass "eieio-compat" "\
\(fn CNAME SUPERCLASSES SLOTS OPTIONS)" nil nil)
(make-obsolete 'eieio-defclass 'eieio-defclass-internal '"25.1")
;;;***

12
lisp/emacs-lisp/eieio-custom.el
View file

@ -322,7 +322,7 @@ Optional argument IGNORE is an extraneous parameter."
;; This is the same object we had before.
obj))
(defmethod eieio-done-customizing ((_obj eieio-default-superclass))
(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass))
"When applying change to a widget, call this method.
This method is called by the default widget-edit commands.
User made commands should also call this method when applying changes.
@ -345,7 +345,7 @@ Optional argument GROUP is the sub-group of slots to display."
"Major mode for customizing EIEIO objects.
\\{eieio-custom-mode-map}")
(defmethod eieio-customize-object ((obj eieio-default-superclass)
(cl-defmethod eieio-customize-object ((obj eieio-default-superclass)
&optional group)
"Customize OBJ in a specialized custom buffer.
To override call the `eieio-custom-widget-insert' to just insert the
@ -386,7 +386,7 @@ These groups are specified with the `:group' slot flag."
(make-local-variable 'eieio-cog)
(setq eieio-cog g)))
(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
"Insert an Apply and Reset button into the object editor.
Argument OBJ is the object being customized."
(widget-create 'push-button
@ -417,7 +417,7 @@ Argument OBJ is the object being customized."
(bury-buffer))
"Cancel"))
(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
&rest flags)
"Insert the widget used for editing object OBJ in the current buffer.
Arguments FLAGS are widget compatible flags.
@ -446,7 +446,7 @@ Must return the created widget."
;; These functions provide the ability to create dynamic menus to
;; customize specific sections of an object. They do not hook directly
;; into a filter, but can be used to create easymenu vectors.
(defmethod eieio-customize-object-group ((obj eieio-default-superclass))
(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass))
"Create a list of vectors for customizing sections of OBJ."
(mapcar (lambda (group)
(vector (concat "Group " (symbol-name group))
@ -457,7 +457,7 @@ Must return the created widget."
(defvar eieio-read-custom-group-history nil
"History for the custom group reader.")
(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
"Do a completing read on the name of a customization group in OBJ.
Return the symbol for the group, or nil"
(let ((g (eieio--class-option (eieio--object-class-object obj)

4
lisp/emacs-lisp/eieio-datadebug.el
View file

@ -79,7 +79,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;;
;; Each object should have an opportunity to show stuff about itself.
(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
prefix)
"Insert the slots of OBJ into the current DDEBUG buffer."
(let ((inhibit-read-only t))
@ -124,7 +124,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;;
;; A generic function to run DDEBUG on an object and popup a new buffer.
;;
(defmethod data-debug-show ((obj eieio-default-superclass))
(cl-defmethod data-debug-show ((obj eieio-default-superclass))
"Run ddebug against any EIEIO object OBJ."
(data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
(data-debug-insert-object-slots obj "]"))

113
lisp/emacs-lisp/eieio-opt.el
View file

@ -122,29 +122,18 @@ If CLASS is actually an object, then also display current values of that object.
;; Describe all the slots in this class.
(eieio-help-class-slots class)
;; Describe all the methods specific to this class.
(let ((methods (eieio-all-generic-functions class))
(type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"])
counter doc)
(when methods
(let ((generics (eieio-all-generic-functions class)))
(when generics
(insert (propertize "Specialized Methods:\n\n" 'face 'bold))
(while methods
(setq doc (eieio-method-documentation (car methods) class))
(insert "`")
(help-insert-xref-button (symbol-name (car methods))
'help-function (car methods))
(insert "'")
(if (not doc)
(insert " Undocumented")
(setq counter 0)
(dolist (cur doc)
(when cur
(insert " " (aref type counter) " "
(prin1-to-string (car cur) (current-buffer))
"\n"
(or (cdr cur) "")))
(setq counter (1+ counter))))
(insert "\n\n")
(setq methods (cdr methods))))))
(dolist (generic generics)
(insert "`")
(help-insert-xref-button (symbol-name generic) 'help-function generic)
(insert "'")
(pcase-dolist (`(,qualifier ,args ,doc)
(eieio-method-documentation generic class))
(insert (format " %S %S\n" qualifier args)
(or doc "")))
(insert "\n\n")))))
(defun eieio-help-class-slots (class)
"Print help description for the slots in CLASS.
@ -311,6 +300,20 @@ are not abstract."
(eieio-help-class ctr))
))))
(defun eieio--specializers-apply-to-class-p (specializers class)
"Return non-nil if a method with SPECIALIZERS applies to CLASS."
(let ((applies nil))
(dolist (specializer specializers)
(if (eq 'subclass (car-safe specializer))
(setq specializer (nth 1 specializer)))
;; Don't include the methods that are "too generic", such as those
;; applying to `eieio-default-superclass'.
(and (not (memq specializer '(t eieio-default-superclass)))
(class-p specializer)
(child-of-class-p class specializer)
(setq applies t)))
applies))
(defun eieio-all-generic-functions (&optional class)
"Return a list of all generic functions.
Optional CLASS argument returns only those functions that contain
@ -318,53 +321,31 @@ methods for CLASS."
(let ((l nil))
(mapatoms
(lambda (symbol)
(let ((tree (get symbol 'eieio-method-hashtable)))
(when tree
;; A symbol might be interned for that class in one of
;; these three slots in the method-obarray.
(if (or (not class)
(car (gethash class (aref tree 0)))
(car (gethash class (aref tree 1)))
(car (gethash class (aref tree 2))))
(setq l (cons symbol l)))))))
(let ((generic (and (fboundp symbol) (cl--generic symbol))))
(and generic
(catch 'found
(if (null class) (throw 'found t))
(pcase-dolist (`((,specializers . ,_qualifier) . ,_)
(cl--generic-method-table generic))
(if (eieio--specializers-apply-to-class-p
specializers class)
(throw 'found t))))
(push symbol l)))))
l))
(defun eieio-method-documentation (generic class)
"Return a list of the specific documentation of GENERIC for CLASS.
If there is not an explicit method for CLASS in GENERIC, or if that
function has no documentation, then return nil."
(let ((tree (get generic 'eieio-method-hashtable)))
(when tree
;; A symbol might be interned for that class in one of
;; these three slots in the method-hashtable.
;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
;; 1 for before, and 2 for primary (and 3 for after)?
(let ((before (car (gethash class (aref tree 0))))
(primary (car (gethash class (aref tree 1))))
(after (car (gethash class (aref tree 2)))))
(if (not (or before primary after))
nil
(list (if before
(cons (help-function-arglist before)
(documentation before))
nil)
(if primary
(cons (help-function-arglist primary)
(documentation primary))
nil)
(if after
(cons (help-function-arglist after)
(documentation after))
nil)))))))
(defvar eieio-read-generic nil
"History of the `eieio-read-generic' prompt.")
(defun eieio-read-generic (prompt &optional historyvar)
"Read a generic function from the minibuffer with PROMPT.
Optional argument HISTORYVAR is the variable to use as history."
(intern (completing-read prompt obarray #'generic-p
t nil (or historyvar 'eieio-read-generic))))
"Return info for all methods of GENERIC applicable to CLASS.
The value returned is a list of elements of the form
\(QUALIFIER ARGS DOC)."
(let ((generic (cl--generic generic))
(docs ()))
(when generic
(dolist (method (cl--generic-method-table generic))
(pcase-let ((`((,specializers . ,_qualifier) . ,_) method))
(when (eieio--specializers-apply-to-class-p
specializers class)
(push (cl--generic-method-info method) docs)))))
docs))
;;; METHOD STATS
;;

20
lisp/emacs-lisp/eieio-speedbar.el
View file

@ -196,19 +196,19 @@ that path."
;; when no other methods are found, allowing multiple inheritance to work
;; reliably with eieio-speedbar.
(defmethod eieio-speedbar-description (object)
(cl-defmethod eieio-speedbar-description (object)
"Return a string describing OBJECT."
(eieio-object-name-string object))
(defmethod eieio-speedbar-derive-line-path (_object)
(cl-defmethod eieio-speedbar-derive-line-path (_object)
"Return the path which OBJECT has something to do with."
nil)
(defmethod eieio-speedbar-object-buttonname (object)
(cl-defmethod eieio-speedbar-object-buttonname (object)
"Return a string to use as a speedbar button for OBJECT."
(eieio-object-name-string object))
(defmethod eieio-speedbar-make-tag-line (object depth)
(cl-defmethod eieio-speedbar-make-tag-line (object depth)
"Insert a tag line into speedbar at point for OBJECT.
By default, all objects appear as simple TAGS with no need to inherit from
the special `eieio-speedbar' classes. Child classes should redefine this
@ -221,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
'speedbar-tag-face
depth))
(defmethod eieio-speedbar-handle-click (object)
(cl-defmethod eieio-speedbar-handle-click (object)
"Handle a click action on OBJECT in speedbar.
Any object can be represented as a tag in SPEEDBAR without special
attributes. These default objects will be pulled up in a custom
@ -285,7 +285,7 @@ Add one of the child classes to this class to the parent list of a class."
;;; Methods to eieio-speedbar-* which do not need to be overridden
;;
(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
(cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
depth)
"Insert a tag line into speedbar at point for OBJECT.
All objects a child of symbol `eieio-speedbar' can be created from
@ -321,12 +321,12 @@ Argument DEPTH is the depth at which the tag line is inserted."
(if exp
(eieio-speedbar-expand object (1+ depth))))))
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth)
(cl-defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth)
"Base method for creating tag lines for non-object children."
(error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
(eieio-object-name object)))
(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
(cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
"Expand OBJECT at indentation DEPTH.
Inserts a list of new tag lines representing expanded elements within
OBJECT."
@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
(cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
"Return a description for a child of OBJ which is not an object."
(error "You must implement `eieio-speedbar-child-description' for %s"
(eieio-object-name obj)))
@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at."
;;; Methods to the eieio-speedbar-* classes which need to be overridden.
;;
(defmethod eieio-speedbar-object-children ((_object eieio-speedbar))
(cl-defmethod eieio-speedbar-object-children ((_object eieio-speedbar))
"Return a list of children to be displayed in speedbar.
If the return value is a list of OBJECTs, then those objects are
queried for details. If the return list is made of strings,

89
lisp/emacs-lisp/eieio.el
View file

@ -179,36 +179,31 @@ and reference them using the function `class-option'."
;; of the specified name, and also performs a `defsetf' if applicable
;; so that users can `setf' the space returned by this function.
(when acces
;; FIXME: The defmethod below only defines a part of the generic
;; function (good), but the define-setter below affects the whole
;; generic function (bad)!
(push `(gv-define-setter ,acces (store object)
;; Apparently, eieio-oset-default doesn't work like
;; oref-default and only accept class arguments!
(list ',(if nil ;; (eq alloc :class)
'eieio-oset-default
'eieio-oset)
object '',sname store))
(push `(cl-defmethod (setf ,acces) (value (this ,name))
(eieio-oset this ',sname value))
accessors)
(push `(defmethod ,acces ,(if (eq alloc :class) :static :primary)
((this ,name))
(push `(cl-defmethod ,acces ((this ,name))
,(format
"Retrieve the slot `%S' from an object of class `%S'."
sname name)
(if (slot-boundp this ',sname)
;; Use oref-default for :class allocated slots, since
;; these also accept the use of a class argument instead
;; of an object argument.
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
this ',sname)
;; Else - Some error? nil?
nil))
accessors))
;; FIXME: Why is this different from the :reader case?
(if (slot-boundp this ',sname) (eieio-oref this ',sname)))
accessors)
(when (and eieio-backward-compatibility (eq alloc :class))
;; FIXME: How could I declare this *method* as obsolete.
(push `(cl-defmethod ,acces ((this (subclass ,name)))
,(format
"Retrieve the class slot `%S' from a class `%S'.
This method is obsolete."
sname name)
(if (slot-boundp this ',sname)
(eieio-oref-default this ',sname)))
accessors)))
;; If a writer is defined, then create a generic method of that
;; name whose purpose is to set the value of the slot.
(if writer
(push `(defmethod ,writer ((this ,name) value)
(push `(cl-defmethod ,writer ((this ,name) value)
,(format "Set the slot `%S' of an object of class `%S'."
sname name)
(setf (slot-value this ',sname) value))
@ -216,7 +211,7 @@ and reference them using the function `class-option'."
;; If a reader is defined, then create a generic method
;; of that name whose purpose is to access this slot value.
(if reader
(push `(defmethod ,reader ((this ,name))
(push `(cl-defmethod ,reader ((this ,name))
,(format "Access the slot `%S' from object of class `%S'."
sname name)
(slot-value this ',sname))
@ -372,6 +367,10 @@ variable name of the same name as the slot."
(define-obsolete-function-alias
'object-class-fast #'eieio--object-class-name "24.4")
(cl-defgeneric eieio-object-name-string (obj)
"Return a string which is OBJ's name."
(declare (obsolete eieio-named "25.1")))
(defun eieio-object-name (obj &optional extra)
"Return a Lisp like symbol string for object OBJ.
If EXTRA, include that in the string returned to represent the symbol."
@ -386,15 +385,13 @@ If EXTRA, include that in the string returned to represent the symbol."
;; below "for free". Since this field is very rarely used, we got rid of it
;; and instead we keep it in a weak hash-tables, for those very rare objects
;; that use it.
(defmethod eieio-object-name-string (obj)
"Return a string which is OBJ's name."
(declare (obsolete eieio-named "25.1"))
(cl-defmethod eieio-object-name-string (obj)
(or (gethash obj eieio--object-names)
(symbol-name (eieio-object-class obj))))
(define-obsolete-function-alias
'object-name-string #'eieio-object-name-string "24.4")
(defmethod eieio-object-set-name-string (obj name)
(cl-defmethod eieio-object-set-name-string (obj name)
"Set the string which is OBJ's NAME."
(declare (obsolete eieio-named "25.1"))
(eieio--check-type stringp name)
@ -648,13 +645,13 @@ This class is not stored in the `parent' slot of a class vector."
(defalias 'standard-class 'eieio-default-superclass)
(defgeneric eieio-constructor (class &rest slots)
(cl-defgeneric eieio-constructor (class &rest slots)
"Default constructor for CLASS `eieio-default-superclass'.")
(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
(defmethod eieio-constructor :static
((class eieio-default-superclass) &rest slots)
(cl-defmethod eieio-constructor
((class (subclass eieio-default-superclass)) &rest slots)
"Default constructor for CLASS `eieio-default-superclass'.
SLOTS are the initialization slots used by `shared-initialize'.
This static method is called when an object is constructed.
@ -674,11 +671,11 @@ calls `shared-initialize' on that object."
;; Return the created object.
new-object))
(defgeneric shared-initialize (obj slots)
(cl-defgeneric shared-initialize (obj slots)
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine.")
(defmethod shared-initialize ((obj eieio-default-superclass) slots)
(cl-defmethod shared-initialize ((obj eieio-default-superclass) slots)
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine."
(while slots
@ -689,10 +686,10 @@ Called from the constructor routine."
(eieio-oset obj rn (car (cdr slots)))))
(setq slots (cdr (cdr slots)))))
(defgeneric initialize-instance (this &optional slots)
(cl-defgeneric initialize-instance (this &optional slots)
"Construct the new object THIS based on SLOTS.")
(defmethod initialize-instance ((this eieio-default-superclass)
(cl-defmethod initialize-instance ((this eieio-default-superclass)
&optional slots)
"Construct the new object THIS based on SLOTS.
SLOTS is a tagged list where odd numbered elements are tags, and
@ -724,10 +721,10 @@ dynamically set from SLOTS."
;; Shared initialize will parse our slots for us.
(shared-initialize this slots))
(defgeneric slot-missing (object slot-name operation &optional new-value)
(cl-defgeneric slot-missing (object slot-name operation &optional new-value)
"Method invoked when an attempt to access a slot in OBJECT fails.")
(defmethod slot-missing ((object eieio-default-superclass) slot-name
(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name
_operation &optional _new-value)
"Method invoked when an attempt to access a slot in OBJECT fails.
SLOT-NAME is the name of the failed slot, OPERATION is the type of access
@ -739,10 +736,10 @@ directly reference slots in EIEIO objects."
(signal 'invalid-slot-name (list (eieio-object-name object)
slot-name)))
(defgeneric slot-unbound (object class slot-name fn)
(cl-defgeneric slot-unbound (object class slot-name fn)
"Slot unbound is invoked during an attempt to reference an unbound slot.")
(defmethod slot-unbound ((object eieio-default-superclass)
(cl-defmethod slot-unbound ((object eieio-default-superclass)
class slot-name fn)
"Slot unbound is invoked during an attempt to reference an unbound slot.
OBJECT is the instance of the object being reference. CLASS is the
@ -757,14 +754,14 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
(signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
slot-name fn)))
(defgeneric clone (obj &rest params)
(cl-defgeneric clone (obj &rest params)
"Make a copy of OBJ, and then supply PARAMS.
PARAMS is a parameter list of the same form used by `initialize-instance'.
When overloading `clone', be sure to call `call-next-method'
first and modify the returned object.")
(defmethod clone ((obj eieio-default-superclass) &rest params)
(cl-defmethod clone ((obj eieio-default-superclass) &rest params)
"Make a copy of OBJ, and then apply PARAMS."
(let ((nobj (copy-sequence obj)))
(if (stringp (car params))
@ -773,24 +770,24 @@ first and modify the returned object.")
(if params (shared-initialize nobj params))
nobj))
(defgeneric destructor (this &rest params)
(cl-defgeneric destructor (this &rest params)
"Destructor for cleaning up any dynamic links to our object.")
(defmethod destructor ((_this eieio-default-superclass) &rest _params)
(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params)
"Destructor for cleaning up any dynamic links to our object.
Argument THIS is the object being destroyed. PARAMS are additional
ignored parameters."
;; No cleanup... yet.
)
(defgeneric object-print (this &rest strings)
(cl-defgeneric object-print (this &rest strings)
"Pretty printer for object THIS. Call function `object-name' with STRINGS.
It is sometimes useful to put a summary of the object into the
default #<notation> string when using EIEIO browsing tools.
Implement this method to customize the summary.")
(defmethod object-print ((this eieio-default-superclass) &rest strings)
(cl-defmethod object-print ((this eieio-default-superclass) &rest strings)
"Pretty printer for object THIS. Call function `object-name' with STRINGS.
The default method for printing object THIS is to use the
function `object-name'.
@ -807,11 +804,11 @@ to prepend a space."
(defvar eieio-print-depth 0
"When printing, keep track of the current indentation depth.")
(defgeneric object-write (this &optional comment)
(cl-defgeneric object-write (this &optional comment)
"Write out object THIS to the current stream.
Optional COMMENT will add comments to the beginning of the output.")
(defmethod object-write ((this eieio-default-superclass) &optional comment)
(cl-defmethod object-write ((this eieio-default-superclass) &optional comment)
"Write object THIS out to the current stream.
This writes out the vector version of this object. Complex and recursive
object are discouraged from being written.

11
lisp/emacs-lisp/package.el
View file

@ -1316,9 +1316,14 @@ The return result is a `package-desc'."
(while files
(with-temp-buffer
(insert-file-contents (pop files))
(if (setq info (ignore-errors (package-buffer-info)))
(setq files nil)
(setf (package-desc-kind info) 'dir))))))))
;; When we find the file with the data,
(when (setq info (ignore-errors (package-buffer-info)))
;; stop looping,
(setq files nil)
;; set the 'dir kind,
(setf (package-desc-kind info) 'dir))))
;; and return the info.
info))))
(defun package--read-pkg-desc (kind)
"Read a `define-package' form in current buffer.

6
lisp/play/gamegrid.el
View file

@ -486,13 +486,13 @@ FILE is created there."
(not (zerop (logand (file-modes
(expand-file-name "update-game-score"
exec-directory))
#o4000)))))
#o6000)))))
(cond ((file-name-absolute-p file)
(gamegrid-add-score-insecure file score))
((and gamegrid-shared-game-dir
(file-exists-p (expand-file-name file shared-game-score-directory)))
;; Use the setuid "update-game-score" program to update a
;; system-wide score file.
;; Use the setuid (or setgid) "update-game-score" program
;; to update a system-wide score file.
(gamegrid-add-score-with-update-game-score-1 file
(expand-file-name file shared-game-score-directory) score))
;; Else: Add the score to a score file in the user's home

130
lisp/progmodes/xref.el
View file

@ -339,6 +339,20 @@ WINDOW controls how the buffer is displayed:
(defvar-local xref--display-history nil
"List of pairs (BUFFER . WINDOW), for temporarily displayed buffers.")
(defvar-local xref--temporary-buffers nil
"List of buffers created by xref code.")
(defvar-local xref--selected nil
"t if the current buffer has ever been selected.
Used for temporary buffers.")
(defvar xref--inhibit-mark-selected nil)
(defun xref--mark-selected ()
(unless xref--inhibit-mark-selected
(setq xref--selected t))
(remove-hook 'buffer-list-update-hook #'xref--mark-selected t))
(defun xref--save-to-history (buf win)
(let ((restore (window-parameter win 'quit-restore)))
;; Save the new entry if the window displayed another buffer
@ -359,8 +373,16 @@ WINDOW controls how the buffer is displayed:
(defun xref--show-location (location)
(condition-case err
(let ((xref-buf (current-buffer)))
(let ((xref-buf (current-buffer))
(bl (buffer-list))
(xref--inhibit-mark-selected t))
(xref--goto-location location)
(let ((buf (current-buffer)))
(unless (memq buf bl)
;; Newly created.
(add-hook 'buffer-list-update-hook #'xref--mark-selected nil t)
(with-current-buffer xref-buf
(push buf xref--temporary-buffers))))
(xref--display-position (point) t 1 xref-buf))
(user-error (message (error-message-string err)))))
@ -386,7 +408,8 @@ WINDOW controls how the buffer is displayed:
(defun xref--location-at-point ()
(get-text-property (point) 'xref-location))
(defvar-local xref--window nil)
(defvar-local xref--window nil
"ACTION argument to call `display-buffer' with.")
(defun xref-goto-xref ()
"Jump to the xref on the current line and bury the xref buffer."
@ -395,35 +418,50 @@ WINDOW controls how the buffer is displayed:
(let ((loc (or (xref--location-at-point)
(user-error "No reference at point")))
(window xref--window))
(xref--quit)
(xref-quit)
(xref--pop-to-location loc window)))
(define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF"
(defvar xref--xref-buffer-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [remap quit-window] #'xref-quit)
(define-key map (kbd "n") #'xref-next-line)
(define-key map (kbd "p") #'xref-prev-line)
(define-key map (kbd "RET") #'xref-goto-xref)
(define-key map (kbd "C-o") #'xref-show-location-at-point)
;; suggested by Johan Claesson "to further reduce finger movement":
(define-key map (kbd ".") #'xref-next-line)
(define-key map (kbd ",") #'xref-prev-line)
map))
(define-derived-mode xref--xref-buffer-mode special-mode "XREF"
"Mode for displaying cross-references."
(setq buffer-read-only t))
(let ((map xref--xref-buffer-mode-map))
(define-key map (kbd "q") #'xref--quit)
(define-key map (kbd "n") #'xref-next-line)
(define-key map (kbd "p") #'xref-prev-line)
(define-key map (kbd "RET") #'xref-goto-xref)
(define-key map (kbd "C-o") #'xref-show-location-at-point)
(defun xref-quit (&optional kill)
"Perform cleanup, then quit the current window.
The cleanup consists of burying all temporarily displayed
buffers, and if KILL is non-nil, of killing all buffers that were
created in the process of showing xrefs.
;; suggested by Johan Claesson "to further reduce finger movement":
(define-key map (kbd ".") #'xref-next-line)
(define-key map (kbd ",") #'xref-prev-line))
(defun xref--quit ()
"Quit all windows in `xref--display-history', then quit current window."
(interactive)
Exceptions are made for buffers switched to by the user in the
meantime, and other window configuration changes. These are
preserved."
(interactive "P")
(let ((window (selected-window))
(history xref--display-history))
(setq xref--display-history nil)
(when kill
(let ((xref--inhibit-mark-selected t)
kill-buffer-query-functions)
(dolist (buf xref--temporary-buffers)
(unless (buffer-local-value 'xref--selected buf)
(kill-buffer buf)))
(setq xref--temporary-buffers nil)))
(pcase-dolist (`(,buf . ,win) history)
(when (and (window-live-p win)
(eq buf (window-buffer win)))
(quit-window nil win)))
(quit-window nil window)))
(quit-window kill window)))
(defconst xref-buffer-name "*xref*"
"The name of the buffer to show xrefs.")
@ -471,7 +509,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(xref-location-group (xref--xref-location x)))
#'equal))
(defun xref--show-xref-buffer (xrefs window)
(defun xref--show-xref-buffer (xrefs alist)
(let ((xref-alist (xref--analyze xrefs)))
(with-current-buffer (get-buffer-create xref-buffer-name)
(let ((inhibit-read-only t))
@ -480,7 +518,11 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(xref--xref-buffer-mode)
(pop-to-buffer (current-buffer))
(goto-char (point-min))
(setq xref--window window)
(setq xref--window (assoc-default 'window alist))
(setq xref--temporary-buffers (assoc-default 'temporary-buffers alist))
(dolist (buf xref--temporary-buffers)
(with-current-buffer buf
(add-hook 'buffer-list-update-hook #'xref--mark-selected nil t)))
(current-buffer)))))
@ -493,16 +535,21 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(defvar xref-show-xrefs-function 'xref--show-xref-buffer
"Function to display a list of xrefs.")
(defun xref--show-xrefs (id kind xrefs window)
(cond
((null xrefs)
(user-error "No known %s for: %s" kind id))
((not (cdr xrefs))
(xref-push-marker-stack)
(xref--pop-to-location (xref--xref-location (car xrefs)) window))
(t
(xref-push-marker-stack)
(funcall xref-show-xrefs-function xrefs window))))
(defun xref--show-xrefs (input kind arg window)
(let* ((bl (buffer-list))
(xrefs (funcall xref-find-function kind arg))
(tb (cl-set-difference (buffer-list) bl)))
(cond
((null xrefs)
(user-error "No known %s for: %s" (symbol-name kind) input))
((not (cdr xrefs))
(xref-push-marker-stack)
(xref--pop-to-location (xref--xref-location (car xrefs)) window))
(t
(xref-push-marker-stack)
(funcall xref-show-xrefs-function xrefs
`((window . ,window)
(temporary-buffers . ,tb)))))))
(defun xref--read-identifier (prompt)
"Return the identifier at point or read it from the minibuffer."
@ -517,9 +564,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
;;; Commands
(defun xref--find-definitions (id window)
(xref--show-xrefs id "definitions"
(funcall xref-find-function 'definitions id)
window))
(xref--show-xrefs id 'definitions id window))
;;;###autoload
(defun xref-find-definitions (identifier)
@ -546,9 +591,7 @@ prompt for it."
"Find references to the identifier at point.
With prefix argument, prompt for the identifier."
(interactive (list (xref--read-identifier "Find references of: ")))
(xref--show-xrefs identifier "references"
(funcall xref-find-function 'references identifier)
nil))
(xref--show-xrefs identifier 'references identifier nil))
;;;###autoload
(defun xref-find-apropos (pattern)
@ -557,14 +600,13 @@ The argument has the same meaning as in `apropos'."
(interactive (list (read-from-minibuffer
"Search for pattern (word list or regexp): ")))
(require 'apropos)
(xref--show-xrefs pattern "apropos"
(funcall xref-find-function 'apropos
(apropos-parse-pattern
(if (string-equal (regexp-quote pattern) pattern)
;; Split into words
(or (split-string pattern "[ \t]+" t)
(user-error "No word list given"))
pattern)))
(xref--show-xrefs pattern 'apropos
(apropos-parse-pattern
(if (string-equal (regexp-quote pattern) pattern)
;; Split into words
(or (split-string pattern "[ \t]+" t)
(user-error "No word list given"))
pattern))
nil))

11
test/ChangeLog
View file

@ -1,7 +1,12 @@
2015-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/cl-generic-tests.el (setf cl--generic-2): Make sure
the setf can be used already in the body of the method.
2015-01-20 Jorgen Schaefer <contact@jorgenschaefer.de>
* automated/package-test.el (package-test-install-prioritized):
Removed test due to unreproducable failures.
Remove test due to unreproducable failures.
2015-01-20 Michal Nazarewicz <mina86@mina86.com>
@ -15,8 +20,8 @@
A new helper function for testing `tildify-double-space-undos'
behaviour in the `tildify-space' function.
(tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp)
(tildify-space-undo-test-xml, tildify-space-undo-test-tex): New
tests for `tildify-doule-space-undos' behaviour.
(tildify-space-undo-test-xml, tildify-space-undo-test-tex):
New tests for `tildify-doule-space-undos' behaviour.
* automated/tildify-tests.el (tildify-space-test--test):
A new helper function for testing `tildify-space' function.

5
test/automated/cl-generic-tests.el
View file

@ -73,6 +73,11 @@
(should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
'("child11" "around""child1" "parent" a))))
;; I don't know how to put this inside an `ert-test'. This tests that `setf'
;; can be used directly inside the body of the setf method.
(cl-defmethod (setf cl--generic-2) (v (y integer) z)
(setf (cl--generic-2 (nth y z) z) v))
(ert-deftest cl-generic-test-03-setf ()
(cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
(cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))

2
test/automated/eieio-test-methodinvoke.el
View file

@ -292,6 +292,7 @@
(defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
;(message "+Ja")
;; FIXME: Using next-method-p in an after-method is invalid!
(when (next-method-p)
(call-next-method))
;(message "-Ja")
@ -302,6 +303,7 @@
(defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
;(message "+Jb")
;; FIXME: Using next-method-p in an after-method is invalid!
(when (next-method-p)
(call-next-method))
;(message "-Jb")