;;; 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
;; This package lets you add behavior (which we call "piece of advice") to
;; existing functions, like the old `advice.el' package, but with much fewer
-;; bells ans whistles. It comes in 2 parts:
+;; bells and whistles. It comes in 2 parts:
;;
;; - The first part lets you add/remove functions, similarly to
;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that
'((: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))
-;;;###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)
;;;###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.
;;;; 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
"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 advice
+ (advice--member-p advice advice
(or (get function-name 'advice--pending)
(advice--strip-macro
(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