;; holds a function.
;; This part provides mainly 2 macros: `add-function' and `remove-function'.
;;
-;; - The second part provides `add-advice' and `remove-advice' which are
+;; - The second part provides `advice-add' and `advice-remove' which are
;; refined version of the previous macros specially tailored for the case
;; where the place that we want to modify is a `symbol-function'.
(propertize "Advised function"
'dynamic-docstring-function #'advice--make-docstring)) ;; )
+(defun advice-eval-interactive-spec (spec)
+ "Evaluate the interactive spec SPEC."
+ (cond
+ ((stringp spec)
+ ;; There's no direct access to the C code (in call-interactively) that
+ ;; processes those specs, but that shouldn't stop us, should it?
+ ;; FIXME: Despite appearances, this is not faithful: SPEC and
+ ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t
+ ;; command-history (and maybe a few other details).
+ (call-interactively `(lambda (&rest args) (interactive ,spec) args)))
+ ;; ((functionp spec) (funcall spec))
+ (t (eval spec))))
+
(defun advice--make-interactive-form (function main)
- ;; TODO: Make it possible to do around-like advising on the
- ;; interactive forms (bug#12844).
;; TODO: make it so that interactive spec can be a constant which
;; dynamically checks the advice--car/cdr to do its job.
- ;; TODO: Implement interactive-read-args:
- ;;(when (or (commandp function) (commandp main))
- ;; `(interactive-read-args
- ;; (cadr (or (interactive-form function) (interactive-form main)))))
- ;; FIXME: This loads autoloaded functions too eagerly.
+ ;; 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))))
+ (when (eq 'function (car 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))))
+ (interactive-form main))))))
(defsubst advice--make-1 (byte-code stack-depth function main props)
"Build a function value that adds FUNCTION to MAIN."
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."
+- `name': a string or symbol. It can be used to refer to this piece of advice.
+
+If one of FUNCTION or OLDFUN is interactive, then the resulting function
+is also interactive. There are 3 cases:
+- FUNCTION is not interactive: the interactive spec of OLDFUN is used.
+- The interactive spec of FUNCTION is itself a function: it should take one
+ argument (the interactive spec of OLDFUN, which it can pass to
+ `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)
`(advice--add-function ,where (gv-ref ,place) ,function ,props))
(advice--make-1 (aref old 1) (aref old 3)
first nrest props)))))
+(defun advice--normalize (symbol def)
+ (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))
+ newval))
+ ;; `f' might be a pure (hence read-only) cons!
+ ((and (eq 'macro (car-safe def))
+ (not (ignore-errors (setcdr def (cdr def)) t)))
+ (cons 'macro (cdr def)))
+ (t def)))
+
+(defsubst advice--strip-macro (x)
+ (if (eq 'macro (car-safe x)) (cdr x) x))
+
(defun advice--defalias-fset (fsetfun symbol newdef)
- (let* ((olddef (if (fboundp symbol) (symbol-function symbol)))
+ (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)))
+ ((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))))
- (funcall (or fsetfun #'fset) symbol (advice--subst-main oldadv newdef))))
+ (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))))))
;;;###autoload
;; - change all defadvice in lisp/**/*.el.
;; - rewrite advice.el on top of this.
;; - obsolete advice.el.
- ;; To make advice.el and nadvice.el interoperate properly I see 2 different
- ;; ways:
- ;; - keep them separate: complete the defalias-fset-function setter with
- ;; a matching accessor which both nadvice.el and advice.el will have to use
- ;; in place of symbol-function. This can probably be made to work, but
- ;; they have to agree on a "protocol".
- ;; - layer advice.el on top of nadvice.el. I prefer this approach. the
- ;; simplest way is to make advice.el build one ad-Advice-foo function for
- ;; each advised function which is advice-added/removed whenever ad-activate
- ;; ad-deactivate is called.
- (let ((f (and (fboundp symbol) (symbol-function symbol))))
- (cond
- ((special-form-p f)
- ;; Not worth the trouble trying to handle this, I think.
- (error "add-advice failure: %S is a special form" symbol))
- ((and (symbolp f)
- (eq 'macro (car-safe (ignore-errors (indirect-function f)))))
- (let ((newval (cons 'macro (cdr (indirect-function f)))))
- (put symbol 'advice--saved-rewrite (cons f newval))
- (fset symbol newval)))
- ;; `f' might be a pure (hence read-only) cons!
- ((and (eq 'macro (car-safe f)) (not (ignore-errors (setcdr f (cdr f)) t)))
- (fset symbol (cons 'macro (cdr f))))
- ))
- (let ((f (and (fboundp symbol) (symbol-function symbol))))
+ (let* ((f (and (fboundp symbol) (symbol-function symbol)))
+ (nf (advice--normalize symbol f)))
+ (unless (eq f nf) ;; Most importantly, if nf == nil!
+ (fset symbol nf))
(add-function where (cond
- ((eq (car-safe f) 'macro) (cdr f))
- ;; If the function is not yet defined, we can't yet
- ;; install the advice.
- ;; FIXME: If it's an autoloaded command, we also
- ;; have a problem because we need to load the
- ;; command to build the interactive-form.
- ((or (not f) (and (autoloadp f))) ;; (commandp f)
+ ((eq (car-safe nf) 'macro) (cdr nf))
+ ;; 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.
+ ;; - `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)
function)
(unless (advice--p
(if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
- ;; Not adviced any more.
+ ;; Not advised any more.
(remove-function (get symbol 'defalias-fset-function)
#'advice--defalias-fset)
(if (eq (symbol-function symbol)
;; (setq def (advice--cdr def)))))
;;;###autoload
-(defun advice-member-p (function symbol)
- "Return non-nil if advice FUNCTION has been added to function SYMBOL.
-Instead of FUNCTION being the actual function, it can also be the `name'
+(defun advice-member-p (advice function-name)
+ "Return non-nil if ADVICE has been added to FUNCTION-NAME.
+Instead of ADVICE being the actual function, it can also be the `name'
of the piece of advice."
- (advice--member-p function
- (or (get symbol 'advice--pending)
- (if (fboundp symbol) (symbol-function symbol)))))
+ (advice--member-p advice
+ (or (get function-name 'advice--pending)
+ (advice--strip-macro
+ (if (fboundp function-name)
+ (symbol-function function-name))))))
(provide 'nadvice)
HCoop / bpt / emacs.git / blobdiff