;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*-
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions, lisp, tools
;; 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-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))))
+ (interactive-form main))))))
(defsubst advice--make-1 (byte-code stack-depth function main props)
"Build a function value that adds FUNCTION to MAIN."
(setq definition (advice--cdr definition))))
found))
-;;;###autoload
-(defun advice--remove-function (flist function)
+(defun advice--tweak (flist tweaker)
(if (not (advice--p flist))
- flist
+ (funcall tweaker nil flist nil)
(let ((first (advice--car flist))
+ (rest (advice--cdr flist))
(props (advice--props flist)))
- (if (or (equal function first)
- (equal function (cdr (assq 'name props))))
- (advice--cdr flist)
- (let* ((rest (advice--cdr flist))
- (nrest (advice--remove-function rest function)))
- (if (eq rest nrest) flist
- (advice--make-1 (aref flist 1) (aref flist 3)
- first nrest props)))))))
+ (let ((val (funcall tweaker first rest props)))
+ (if val (car val)
+ (let ((nrest (advice--tweak rest tweaker)))
+ (if (eq rest nrest) flist
+ (advice--make-1 (aref flist 1) (aref flist 3)
+ first nrest props))))))))
+
+;;;###autoload
+(defun advice--remove-function (flist function)
+ (advice--tweak flist
+ (lambda (first rest props)
+ (cond ((not first) rest)
+ ((or (equal function first)
+ (equal function (cdr (assq 'name props))))
+ (list rest))))))
+
+(defvar advice--buffer-local-function-sample nil)
+
+(defun advice--set-buffer-local (var val)
+ (if (function-equal val advice--buffer-local-function-sample)
+ (kill-local-variable var)
+ (set (make-local-variable var) val)))
+
+;;;###autoload
+(defun advice--buffer-local (var)
+ "Buffer-local value of VAR, presumed to contain a function."
+ (declare (gv-setter advice--set-buffer-local))
+ (if (local-variable-p var) (symbol-value var)
+ (setq advice--buffer-local-function-sample
+ (lambda (&rest args) (apply (default-value var) args)))))
;;;###autoload
(defmacro add-function (where place function &optional props)
;; TODO:
- ;; - provide something like `around' for interactive forms.
- ;; - provide some kind of buffer-local functionality at least when `place'
- ;; is a variable.
;; - 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 also let `where' specify some kind of predicate and use it
+ ;; - 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
+ ;; be combined and made more efficient.
;; :before is like a normal add-hook on a normal hook.
;; :before-while is like add-hook on run-hook-with-args-until-failure.
;; :before-until is like add-hook on run-hook-with-args-until-success.
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.
+
+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 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)
+ (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)))
`(advice--add-function ,where (gv-ref ,place) ,function ,props))
;;;###autoload
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
(macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new)))))
;;;; Specific application of add-function to `symbol-function' for advice.
(defun advice--subst-main (old new)
- (if (not (advice--p old))
- new
- (let* ((first (advice--car old))
- (rest (advice--cdr old))
- (props (advice--props old))
- (nrest (advice--subst-main rest new)))
- (if (equal rest nrest) old
- (advice--make-1 (aref old 1) (aref old 3)
- first nrest props)))))
+ (advice--tweak old
+ (lambda (first _rest _props) (if (not first) new))))
(defun advice--normalize (symbol def)
(cond
((special-form-p def)
;; Not worth the trouble trying to handle this, I think.
- (error "add-advice failure: %S is a special form" symbol))
+ (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)))))
;; - 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)))
(nf (advice--normalize symbol f)))
(unless (eq f nf) ;; Most importantly, if nf == nil!
(fset symbol nf))
(add-function where (cond
((eq (car-safe nf) 'macro) (cdr nf))
- ;; 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 nf) (and (autoloadp nf))) ;; (commandp 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)
(if (fboundp function-name)
(symbol-function function-name))))))
+;; When code is advised, called-interactively-p needs to be taught to skip
+;; the advising frames.
+;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p
+;; done from the advised function if the deepest advice is an around advice!
+;; In other cases (calls from an advice or calls from the advised function when
+;; the deepest advice is not an around advice), it should hopefully get
+;; it right.
+(add-hook 'called-interactively-p-functions
+ #'advice--called-interactively-skip)
+(defun advice--called-interactively-skip (origi frame1 frame2)
+ (let* ((i origi)
+ (get-next-frame
+ (lambda ()
+ (setq frame1 frame2)
+ (setq frame2 (internal--called-interactively-p--get-frame i))
+ ;; (message "Advice Frame %d = %S" i frame2)
+ (setq i (1+ i)))))
+ (when (and (eq (nth 1 frame2) 'apply)
+ (progn
+ (funcall get-next-frame)
+ (advice--p (indirect-function (nth 1 frame2)))))
+ (funcall get-next-frame)
+ ;; If we now have the symbol, this was the head advice and
+ ;; we're done.
+ (while (advice--p (nth 1 frame1))
+ ;; This was an inner advice called from some earlier advice.
+ ;; The stack frames look different depending on the particular
+ ;; kind of the earlier advice.
+ (let ((inneradvice (nth 1 frame1)))
+ (if (and (eq (nth 1 frame2) 'apply)
+ (progn
+ (funcall get-next-frame)
+ (advice--p (indirect-function
+ (nth 1 frame2)))))
+ ;; The earlier advice was something like a before/after
+ ;; advice where the "next" code is called directly by the
+ ;; advice--p object.
+ (funcall get-next-frame)
+ ;; It's apparently an around advice, where the "next" is
+ ;; called by the body of the advice in any way it sees fit,
+ ;; so we need to skip the frames of that body.
+ (while
+ (progn
+ (funcall get-next-frame)
+ (not (and (eq (nth 1 frame2) 'apply)
+ (eq (nth 3 frame2) inneradvice)))))
+ (funcall get-next-frame)
+ (funcall get-next-frame))))
+ (- i origi 1))))
+
(provide 'nadvice)
;;; nadvice.el ends here
HCoop / bpt / emacs.git / blobdiff