diff options
Diffstat (limited to 'lisp/emacs-lisp/nadvice.el')
| -rw-r--r-- | lisp/emacs-lisp/nadvice.el | 180 |
1 files changed, 115 insertions, 65 deletions
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 576e72088e9..2cd34e12810 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -1,6 +1,6 @@ ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- -;; Copyright (C) 2012-2013 Free Software Foundation, Inc. +;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools @@ -67,14 +67,26 @@ Each element has the form (WHERE BYTECODE STACK) where: (defsubst advice--cdr (f) (aref (aref f 2) 2)) (defsubst advice--props (f) (aref (aref f 2) 3)) -(defun advice--make-docstring (_string function) - "Build the raw doc-string of SYMBOL, presumably advised." - (let ((flist (indirect-function function)) - (docstring nil)) +(defun advice--cd*r (f) + (while (advice--p f) + (setq f (advice--cdr f))) + f) + +(defun advice--make-docstring (function) + "Build the raw docstring for FUNCTION, presumably advised." + (let* ((flist (indirect-function function)) + (docfun nil) + (docstring nil)) (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) (while (advice--p flist) (let ((bytecode (aref flist 1)) + (doc (aref flist 4)) (where nil)) + ;; Hack attack! For advices installed before calling + ;; Snarf-documentation, the integer offset into the DOC file will not + ;; be installed in the "core unadvised function" but in the advice + ;; object instead! So here we try to undo the damage. + (if (integerp doc) (setq docfun flist)) (dolist (elem advice--where-alist) (if (eq bytecode (cadr elem)) (setq where (car elem)))) (setq docstring @@ -83,7 +95,7 @@ Each element has the form (WHERE BYTECODE STACK) where: (propertize (format "%s advice: " where) 'face 'warning) (let ((fun (advice--car flist))) - (if (symbolp fun) (format "`%S'" fun) + (if (symbolp fun) (format-message "`%S'" fun) (let* ((name (cdr (assq 'name (advice--props flist)))) (doc (documentation fun t)) (usage (help-split-fundoc doc function))) @@ -96,22 +108,16 @@ Each element has the form (WHERE BYTECODE STACK) where: "\n"))) (setq flist (advice--cdr flist))) (if docstring (setq docstring (concat docstring "\n"))) - (let* ((origdoc (unless (eq function flist) ;Avoid inf-loops. - (documentation flist t))) + (unless docfun (setq docfun flist)) + (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops. + (documentation docfun t))) (usage (help-split-fundoc origdoc function))) (setq usage (if (null usage) (let ((arglist (help-function-arglist flist))) - (format "%S" (help-make-usage function arglist))) + (help--make-usage-docstring function arglist)) (setq origdoc (cdr usage)) (car usage))) (help-add-fundoc-usage (concat docstring origdoc) usage)))) -(defvar advice--docstring - ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, - ;; which drops the text-properties. - ;;(eval-when-compile - (propertize "Advised function" - 'dynamic-docstring-function #'advice--make-docstring)) ;; ) - (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." (cond @@ -125,48 +131,65 @@ Each element has the form (WHERE BYTECODE STACK) where: ;; ((functionp spec) (funcall spec)) (t (eval spec)))) +(defun advice--interactive-form (function) + ;; Like `interactive-form' but tries to avoid autoloading functions. + (when (commandp function) + (if (not (and (symbolp function) (autoloadp (indirect-function function)))) + (interactive-form function) + `(interactive (advice-eval-interactive-spec + (cadr (interactive-form ',function))))))) + (defun advice--make-interactive-form (function main) ;; TODO: make it so that interactive spec can be a constant which ;; dynamically checks the advice--car/cdr to do its job. ;; For that, advice-eval-interactive-spec needs to be more faithful. - ;; FIXME: The calls to interactive-form below load autoloaded functions - ;; too eagerly. - (let ((fspec (cadr (interactive-form function)))) + (let* ((iff (advice--interactive-form function)) + (ifm (advice--interactive-form main)) + (fspec (cadr iff))) (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? (setq fspec (nth 1 fspec))) (if (functionp fspec) - `(funcall ',fspec - ',(cadr (interactive-form main))) - (cadr (or (interactive-form function) - (interactive-form main)))))) + `(funcall ',fspec ',(cadr ifm)) + (cadr (or iff ifm))))) -(defsubst advice--make-1 (byte-code stack-depth function main props) +(defun advice--make-1 (byte-code stack-depth function main props) "Build a function value that adds FUNCTION to MAIN." (let ((adv-sig (gethash main advertised-signature-table)) (advice (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth - advice--docstring - (when (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) + (vector #'apply function main props) stack-depth nil + (and (or (commandp function) (commandp main)) + (list (advice--make-interactive-form + function main)))))) (when adv-sig (puthash advice adv-sig advertised-signature-table)) advice)) (defun advice--make (where function main props) "Build a function value that adds FUNCTION to MAIN at WHERE. WHERE is a symbol to select an entry in `advice--where-alist'." - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))) - -(defun advice--member-p (function name definition) + (let ((fd (or (cdr (assq 'depth props)) 0)) + (md (if (advice--p main) + (or (cdr (assq 'depth (advice--props main))) 0)))) + (if (and md (> fd md)) + ;; `function' should go deeper. + (let ((rest (advice--make where function (advice--cdr main) props))) + (advice--make-1 (aref main 1) (aref main 3) + (advice--car main) rest (advice--props main))) + (let ((desc (assq where advice--where-alist))) + (unless desc (error "Unknown add-function location `%S'" where)) + (advice--make-1 (nth 1 desc) (nth 2 desc) + function main props))))) + +(defun advice--member-p (function use-name definition) (let ((found nil)) (while (and (not found) (advice--p definition)) - (if (or (equal function (advice--car definition)) - (when name - (equal name (cdr (assq 'name (advice--props definition)))))) + (if (if (eq use-name :use-both) + (or (equal function + (cdr (assq 'name (advice--props definition)))) + (equal function (advice--car definition))) + (equal function (if use-name + (cdr (assq 'name (advice--props definition))) + (advice--car definition)))) (setq found definition) (setq definition (advice--cdr definition)))) found)) @@ -190,8 +213,8 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (lambda (first rest props) (cond ((not first) rest) ((or (equal function first) - (equal function (cdr (assq 'name props)))) - (list rest)))))) + (equal function (cdr (assq 'name props)))) + (list (advice--remove-function rest function))))))) (defvar advice--buffer-local-function-sample nil "keeps an example of the special \"run the default value\" functions. @@ -213,11 +236,16 @@ different, but `function-equal' will hopefully ignore those differences.") ;; This function acts like the t special value in buffer-local hooks. (lambda (&rest args) (apply (default-value var) args))))) +(eval-and-compile + (defun advice--normalize-place (place) + (cond ((eq 'local (car-safe place)) `(advice--buffer-local ,@(cdr place))) + ((eq 'var (car-safe place)) (nth 1 place)) + ((symbolp place) `(default-value ',place)) + (t place)))) + ;;;###autoload (defmacro add-function (where place function &optional props) ;; TODO: - ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP - ;; and tracing want to stay first. ;; - maybe let `where' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can @@ -245,9 +273,14 @@ If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: - `name': a string or symbol. It can be used to refer to this piece of advice. +- `depth': a number indicating a preference w.r.t ordering. + The default depth is 0. By convention, a depth of 100 means that + the advice should be innermost (i.e. at the end of the list), + whereas a depth of -100 means that the advice should be outermost. -If PLACE is a simple variable, only its global value will be affected. -Use (local 'VAR) if you want to apply FUNCTION to VAR buffer-locally. +If PLACE is a symbol, its `default-value' will be affected. +Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. +Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR. If one of FUNCTION or OLDFUN is interactive, then the resulting function is also interactive. There are 3 cases: @@ -257,20 +290,18 @@ is also interactive. There are 3 cases: `advice-eval-interactive-spec') and return the list of arguments to use. - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." (declare (debug t)) ;;(indent 2) - (cond ((eq 'local (car-safe place)) - (setq place `(advice--buffer-local ,@(cdr place)))) - ((symbolp place) - (setq place `(default-value ',place)))) - `(advice--add-function ,where (gv-ref ,place) ,function ,props)) + `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + ,function ,props)) ;;;###autoload (defun advice--add-function (where ref function props) - (let ((a (advice--member-p function (cdr (assq 'name props)) - (gv-deref ref)))) + (let* ((name (cdr (assq 'name props))) + (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a ;; The advice is already present. Remove the old one, first. (setf (gv-deref ref) - (advice--remove-function (gv-deref ref) (advice--car a)))) + (advice--remove-function (gv-deref ref) + (or name (advice--car a))))) (setf (gv-deref ref) (advice--make where function (gv-deref ref) props)))) @@ -281,11 +312,7 @@ If FUNCTION was not added to PLACE, do nothing. Instead of FUNCTION being the actual function, it can also be the `name' of the piece of advice." (declare (debug t)) - (cond ((eq 'local (car-safe place)) - (setq place `(advice--buffer-local ,@(cdr place)))) - ((symbolp place) - (error "Use (default-value '%S) or (local '%S)" place place))) - (gv-letplace (getter setter) place + (gv-letplace (getter setter) (advice--normalize-place place) (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) @@ -301,7 +328,7 @@ properties alist that was specified when it was added." "Return non-nil if ADVICE is already in FUNCTION-DEF. Instead of ADVICE being the actual function, it can also be the `name' of the piece of advice." - (advice--member-p advice advice function-def)) + (advice--member-p advice :use-both function-def)) ;;;; Specific application of add-function to `symbol-function' for advice. @@ -360,7 +387,6 @@ of the piece of advice." (unless (eq oldadv (get symbol 'advice--pending)) (put symbol 'advice--pending (advice--subst-main oldadv nil))) (funcall fsetfun symbol newdef)))) - ;;;###autoload (defun advice-add (symbol where function &optional props) @@ -379,15 +405,15 @@ is defined as a macro, alias, command, ..." ;; Reasons to delay installation of the advice: ;; - If the function is not yet defined, installing ;; the advice would affect `fboundp'ness. - ;; - If it's an autoloaded command, - ;; advice--make-interactive-form would end up - ;; loading the command eagerly. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. ;; - `autoload' does nothing if the function is ;; not an autoload or undefined. ((or (not nf) (autoloadp nf)) (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) nil) @@ -407,7 +433,6 @@ of the piece of advice." (t (symbol-function symbol))) function) (unless (advice--p (advice--symbol-function symbol)) - ;; Not advised any more. (remove-function (get symbol 'defalias-fset-function) #'advice--defalias-fset) (let ((asr (get symbol 'advice--saved-rewrite))) @@ -416,6 +441,30 @@ of the piece of advice." (fset symbol (car (get symbol 'advice--saved-rewrite))))))) nil) +;;;###autoload +(defmacro define-advice (symbol args &rest body) + "Define an advice and add it to function named SYMBOL. +See `advice-add' and `add-function' for explanation on the +arguments. Note if NAME is nil the advice is anonymous; +otherwise it is named `SYMBOL@NAME'. + +\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" + (declare (indent 2) (doc-string 3) (debug (sexp sexp body))) + (or (listp args) (signal 'wrong-type-argument (list 'listp args))) + (or (<= 2 (length args) 4) + (signal 'wrong-number-of-arguments (list 2 4 (length args)))) + (let* ((where (nth 0 args)) + (lambda-list (nth 1 args)) + (name (nth 2 args)) + (depth (nth 3 args)) + (props (and depth `((depth . ,depth)))) + (advice (cond ((null name) `(lambda ,lambda-list ,@body)) + ((or (stringp name) (symbolp name)) + (intern (format "%s@%s" symbol name))) + (t (error "Unrecognized name spec `%S'" name))))) + `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) + (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (defun advice-mapc (fun symbol) "Apply FUN to every advice function in SYMBOL. FUN is called with a two arguments: the function that was added, and the @@ -473,8 +522,9 @@ of the piece of advice." (while (progn (funcall get-next-frame) - (not (and (eq (nth 1 frame2) 'apply) - (eq (nth 3 frame2) inneradvice))))) + (and frame2 + (not (and (eq (nth 1 frame2) 'apply) + (eq (nth 3 frame2) inneradvice)))))) (funcall get-next-frame) (funcall get-next-frame)))) (- i origi 1)))) |