[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] xwidget d6ada5a: Merge branch 'master' into xwidget
|
From: |
Joakim Verona |
|
Subject: |
[Emacs-diffs] xwidget d6ada5a: Merge branch 'master' into xwidget |
|
Date: |
Wed, 21 Jan 2015 23:40:42 +0000 |
branch: xwidget
commit d6ada5ae0fad7a5c85eb28b102bc460e9fe0aceb
Merge: 487d6cd 20f6648
Author: Joakim Verona <address@hidden>
Commit: Joakim Verona <address@hidden>
Merge branch 'master' into xwidget
---
ChangeLog | 7 ++
configure.ac | 24 +++++-
etc/NEWS | 7 ++
lib-src/ChangeLog | 12 +++
lib-src/Makefile.in | 16 +++-
lib-src/update-game-score.c | 33 ++++---
lisp/ChangeLog | 70 +++++++++++++++
lisp/emacs-lisp/cl-generic.el | 122 +++++++++++++++++----------
lisp/emacs-lisp/eieio-base.el | 36 ++++----
lisp/emacs-lisp/eieio-compat.el | 33 ++++++--
lisp/emacs-lisp/eieio-core.el | 23 +++++-
lisp/emacs-lisp/eieio-custom.el | 12 ++--
lisp/emacs-lisp/eieio-datadebug.el | 4 +-
lisp/emacs-lisp/eieio-opt.el | 113 ++++++++++---------------
lisp/emacs-lisp/eieio-speedbar.el | 20 ++--
lisp/emacs-lisp/eieio.el | 89 ++++++++++----------
lisp/emacs-lisp/package.el | 11 ++-
lisp/play/gamegrid.el | 6 +-
lisp/progmodes/xref.el | 130 +++++++++++++++++++----------
test/ChangeLog | 11 ++-
test/automated/cl-generic-tests.el | 5 +
test/automated/eieio-test-methodinvoke.el | 2 +
22 files changed, 508 insertions(+), 278 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 309b04f..b02203d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2015-01-21 Ulrich Müller <address@hidden>
+
+ * 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 <address@hidden>
Give up on -Wsuggest-attribute=const
diff --git a/configure.ac b/configure.ac
index 1d206db..0c25557 100644
--- a/configure.ac
+++ b/configure.ac
@@ -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 @address@hidden
## src/Makefile.in did add LD_SWITCH_X_SITE (as a cpp define) to the
## end of LIBX_BASE, but nothing ever set it.
diff --git a/etc/NEWS b/etc/NEWS
index 548b54d..120d8b9 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -46,6 +46,13 @@ and silent rules are now quieter. To get the old behavior
where
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,
so if you want to use it, you can always take a copy from an older Emacs.
diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog
index 37f037e..b67038f 100644
--- a/lib-src/ChangeLog
+++ b/lib-src/ChangeLog
@@ -1,3 +1,15 @@
+2015-01-21 Ulrich Müller <address@hidden>
+
+ * 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 <address@hidden>
* Makefile.in (AM_V_RC, am__v_RC_, am__v_RC_0, am__v_RC_1): New
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index 01592bd..2997f1b 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -122,6 +122,7 @@ address@hidden@
address@hidden@
address@hidden@
address@hidden@
# ==================== 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 \
diff --git a/lib-src/update-game-score.c b/lib-src/update-game-score.c
index d3354af..4f15483 100644
--- a/lib-src/update-game-score.c
+++ b/lib-src/update-game-score.c
@@ -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");
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b5824ab..7aa66bf 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,73 @@
+2015-01-21 Ulrich Müller <address@hidden>
+
+ * 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 <address@hidden>
+
+ * 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 <address@hidden>
+
+ * 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 <address@hidden>
+
+ * emacs-lisp/package.el (package-dir-info): Fix `while' logic.
+
2015-01-20 Stefan Monnier <address@hidden>
* emacs-lisp/eieio-generic.el: Remove.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 3bbddfc..8dee9a3 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -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.
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 9931fbd..feb0671 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -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
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 34c06c0..c2dabf7 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -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)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index b89ccfd..0297acc 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -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")
+
;;;***
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 8ab74ae..0e0b31e 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -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)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el
b/lisp/emacs-lisp/eieio-datadebug.el
index ab8d41e..6534bd0 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -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 "]"))
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 13ad120..a131b02 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -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
;;
diff --git a/lisp/emacs-lisp/eieio-speedbar.el
b/lisp/emacs-lisp/eieio-speedbar.el
index b236f0f..a1eabcf 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -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,
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index b64eba1..7672d7f 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -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.
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 0f094b5..88fc950 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -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.
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index 1e265a6..b4c3c59 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -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
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 92144cf..ee81250 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -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)
-
- ;; 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 (&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.
-(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))
diff --git a/test/ChangeLog b/test/ChangeLog
index dcce0bf..d63a561 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,7 +1,12 @@
+2015-01-21 Stefan Monnier <address@hidden>
+
+ * 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 <address@hidden>
* 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 <address@hidden>
@@ -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.
diff --git a/test/automated/cl-generic-tests.el
b/test/automated/cl-generic-tests.el
index 1c01d9b..bc9a1ec 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -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))
diff --git a/test/automated/eieio-test-methodinvoke.el
b/test/automated/eieio-test-methodinvoke.el
index 3918fb9..da5f59a 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -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")