;;; 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
(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
"\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)))
(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
;; ((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))
(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.
;; 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
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:
`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))))
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)))))
"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.
(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)
;; 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)
(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)))
(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