'((:around "\300\301\302\003#\207" 5)
(:before "\300\301\002\"\210\300\302\002\"\207" 4)
(:after "\300\302\002\"\300\301\003\"\210\207" 5)
+ (:override "\300\301\ 2\"\207" 4)
(:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
(:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
(:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
- (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4))
+ (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
+ (:filter-args "\300\302\301\ 3!\"\207" 5)
+ (:filter-return "\301\300\302\ 3\"!\207" 5))
"List of descriptions of how to add a function.
Each element has the form (WHERE BYTECODE STACK) where:
WHERE is a keyword indicating where the function is added.
(advice--make-1 (nth 1 desc) (nth 2 desc)
function main props)))
-(defun advice--member-p (function definition)
+(defun advice--member-p (function name definition)
(let ((found nil))
(while (and (not found) (advice--p definition))
(if (or (equal function (advice--car definition))
- (equal function (cdr (assq 'name (advice--props definition)))))
- (setq found t)
+ (when name
+ (equal name (cdr (assq 'name (advice--props definition))))))
+ (setq found definition)
(setq definition (advice--cdr definition))))
found))
(equal function (cdr (assq 'name props))))
(list rest))))))
-(defvar advice--buffer-local-function-sample nil)
+(defvar advice--buffer-local-function-sample nil
+ "keeps an example of the special \"run the default value\" functions.
+These functions play the same role as t in buffer-local hooks, and to recognize
+them, we keep a sample here against which to compare. Each instance is
+different, but `function-equal' will hopefully ignore those differences.")
(defun advice--set-buffer-local (var val)
(if (function-equal val advice--buffer-local-function-sample)
(declare (gv-setter advice--set-buffer-local))
(if (local-variable-p var) (symbol-value var)
(setq advice--buffer-local-function-sample
+ ;; This function acts like the t special value in buffer-local hooks.
(lambda (&rest args) (apply (default-value var) args)))))
;;;###autoload
(defmacro add-function (where place function &optional props)
;; TODO:
- ;; - obsolete with-wrapper-hook (mostly requires buffer-local support).
;; - 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
`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r))
`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r)))
`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r))
+`:override' (lambda (&rest r) (apply FUNCTION r))
`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r)))
`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r)))
`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r)))
`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r)))
+`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r)))
+`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r)))
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.
-PLACE cannot be a simple variable. Instead it should either be
-\(default-value 'VAR) or (local 'VAR) depending on whether FUNCTION
-should be applied to VAR buffer-locally or globally.
+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 one of FUNCTION or OLDFUN is interactive, then the resulting function
is also interactive. There are 3 cases:
(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)))
+ (setq place `(default-value ',place))))
`(advice--add-function ,where (gv-ref ,place) ,function ,props))
;;;###autoload
(defun advice--add-function (where ref function props)
- (unless (advice--member-p function (gv-deref ref))
+ (let ((a (advice--member-p function (cdr (assq 'name props))
+ (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))))
(setf (gv-deref ref)
(advice--make where function (gv-deref ref) props))))
+;;;###autoload
(defmacro remove-function (place function)
"Remove the FUNCTION piece of advice from PLACE.
If FUNCTION was not added to PLACE, do nothing.
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new)))))
+(defun advice-function-mapc (f function-def)
+ "Apply F to every advice function in FUNCTION-DEF.
+F is called with two arguments: the function that was added, and the
+properties alist that was specified when it was added."
+ (while (advice--p function-def)
+ (funcall f (advice--car function-def) (advice--props function-def))
+ (setq function-def (advice--cdr function-def))))
+
+(defun advice-function-member-p (advice function-def)
+ "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))
+
;;;; Specific application of add-function to `symbol-function' for advice.
(defun advice--subst-main (old new)
(cond
((special-form-p def)
;; Not worth the trouble trying to handle this, I think.
- (error "advice-add failure: %S is a special form" symbol))
- ((and (symbolp def)
- (eq 'macro (car-safe (ignore-errors (indirect-function def)))))
- (let ((newval (cons 'macro (cdr (indirect-function def)))))
- (put symbol 'advice--saved-rewrite (cons def newval))
+ (error "Advice impossible: %S is a special form" symbol))
+ ((and (symbolp def) (macrop def))
+ (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r))))))
+ (put symbol 'advice--saved-rewrite (cons def (cdr newval)))
newval))
;; `f' might be a pure (hence read-only) cons!
((and (eq 'macro (car-safe def))
(defsubst advice--strip-macro (x)
(if (eq 'macro (car-safe x)) (cdr x) x))
+(defun advice--symbol-function (symbol)
+ ;; The value conceptually stored in `symbol-function' is split into two
+ ;; parts:
+ ;; - the normal function definition.
+ ;; - the list of advice applied to it.
+ ;; `advice--symbol-function' is intended to return the second part (i.e. the
+ ;; list of advice, which includes a hole at the end which typically holds the
+ ;; first part, but this function doesn't care much which value is found
+ ;; there).
+ ;; In the "normal" state both parts are combined into a single value stored
+ ;; in the "function slot" of the symbol. But the way they are combined is
+ ;; different depending on whether the definition is a function or a macro.
+ ;; Also if the function definition is nil (i.e. unbound) or is an autoload,
+ ;; the second part is stashed away temporarily in the `advice--pending'
+ ;; symbol property.
+ (or (get symbol 'advice--pending)
+ (advice--strip-macro (symbol-function symbol))))
+
(defun advice--defalias-fset (fsetfun symbol newdef)
+ (unless fsetfun (setq fsetfun #'fset))
(when (get symbol 'advice--saved-rewrite)
(put symbol 'advice--saved-rewrite nil))
(setq newdef (advice--normalize symbol newdef))
- (let* ((olddef (advice--strip-macro
- (if (fboundp symbol) (symbol-function symbol))))
- (oldadv
- (cond
- ((null (get symbol 'advice--pending))
- (or olddef
- (progn
- (message "Delayed advice activation failed for %s: no data"
- symbol)
- nil)))
- ((or (not olddef) (autoloadp olddef))
- (prog1 (get symbol 'advice--pending)
- (put symbol 'advice--pending nil)))
- (t (message "Dropping left-over advice--pending for %s" symbol)
- (put symbol 'advice--pending nil)
- olddef))))
- (let* ((snewdef (advice--strip-macro newdef))
- (snewadv (advice--subst-main oldadv snewdef)))
- (funcall (or fsetfun #'fset) symbol
- (if (eq snewdef newdef) snewadv (cons 'macro snewadv))))))
+ (let ((oldadv (advice--symbol-function symbol)))
+ (if (and newdef (not (autoloadp newdef)))
+ (let* ((snewdef (advice--strip-macro newdef))
+ (snewadv (advice--subst-main oldadv snewdef)))
+ (put symbol 'advice--pending nil)
+ (funcall fsetfun symbol
+ (if (eq snewdef newdef) snewadv (cons 'macro snewadv))))
+ (unless (eq oldadv (get symbol 'advice--pending))
+ (put symbol 'advice--pending (advice--subst-main oldadv nil)))
+ (funcall fsetfun symbol newdef))))
;;;###autoload
;; TODO:
;; - record the advice location, to display in describe-function.
;; - change all defadvice in lisp/**/*.el.
- ;; - rewrite advice.el on top of this.
;; - obsolete advice.el.
- (let* ((f (and (fboundp symbol) (symbol-function symbol)))
+ (let* ((f (symbol-function symbol))
(nf (advice--normalize symbol f)))
- (unless (eq f nf) ;; Most importantly, if nf == nil!
- (fset symbol nf))
+ (unless (eq f nf) (fset symbol nf))
(add-function where (cond
((eq (car-safe nf) 'macro) (cdr nf))
;; Reasons to delay installation of the advice:
;;;###autoload
(defun advice-remove (symbol function)
"Like `remove-function' but for the function named SYMBOL.
-Contrary to `remove-function', this will work also when SYMBOL is a macro
-and it will not signal an error if SYMBOL is not `fboundp'.
+Contrary to `remove-function', this also works when SYMBOL is a macro
+or an autoload and it preserves `fboundp'.
Instead of the actual function to remove, FUNCTION can also be the `name'
of the piece of advice."
- (when (fboundp symbol)
- (let ((f (symbol-function symbol)))
- ;; Can't use the `if' place here, because the body is too large,
- ;; resulting in use of code that only works with lexical-scoping.
- (remove-function (if (eq (car-safe f) 'macro)
- (cdr f)
- (symbol-function symbol))
- function)
- (unless (advice--p
- (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
- ;; Not advised any more.
- (remove-function (get symbol 'defalias-fset-function)
- #'advice--defalias-fset)
- (if (eq (symbol-function symbol)
- (cdr (get symbol 'advice--saved-rewrite)))
- (fset symbol (car (get symbol 'advice--saved-rewrite))))))
- nil))
-
-;; (defun advice-mapc (fun symbol)
-;; "Apply FUN to every function added as advice to SYMBOL.
-;; FUN is called with a two arguments: the function that was added, and the
-;; properties alist that was specified when it was added."
-;; (let ((def (or (get symbol 'advice--pending)
-;; (if (fboundp symbol) (symbol-function symbol)))))
-;; (while (advice--p def)
-;; (funcall fun (advice--car def) (advice--props def))
-;; (setq def (advice--cdr def)))))
+ (let ((f (symbol-function symbol)))
+ (remove-function (cond ;This is `advice--symbol-function' but as a "place".
+ ((get symbol 'advice--pending)
+ (get symbol 'advice--pending))
+ ((eq (car-safe f) 'macro) (cdr f))
+ (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)))
+ (and asr (eq (cdr-safe (symbol-function symbol))
+ (cdr asr))
+ (fset symbol (car (get symbol 'advice--saved-rewrite)))))))
+ nil)
+
+(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
+properties alist that was specified when it was added."
+ (advice-function-mapc fun (advice--symbol-function symbol)))
;;;###autoload
-(defun advice-member-p (advice function-name)
- "Return non-nil if ADVICE has been added to FUNCTION-NAME.
+(defun advice-member-p (advice symbol)
+ "Return non-nil if ADVICE has been added to SYMBOL.
Instead of ADVICE being the actual function, it can also be the `name'
of the piece of advice."
- (advice--member-p advice
- (or (get function-name 'advice--pending)
- (advice--strip-macro
- (if (fboundp function-name)
- (symbol-function function-name))))))
+ (advice-function-member-p advice (advice--symbol-function symbol)))
;; When code is advised, called-interactively-p needs to be taught to skip
;; the advising frames.
(get-next-frame
(lambda ()
(setq frame1 frame2)
- (setq frame2 (internal--called-interactively-p--get-frame i))
+ (setq frame2 (backtrace-frame i #'called-interactively-p))
;; (message "Advice Frame %d = %S" i frame2)
(setq i (1+ i)))))
(when (and (eq (nth 1 frame2) 'apply)