Commit | Line | Data |
---|---|---|
231d8498 SM |
1 | ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- |
2 | ||
3 | ;; Copyright (C) 2012 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ;; Keywords: extensions, lisp, tools | |
7 | ;; Package: emacs | |
8 | ||
9 | ;; This program is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; This program is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;; This package lets you add behavior (which we call "piece of advice") to | |
25 | ;; existing functions, like the old `advice.el' package, but with much fewer | |
26 | ;; bells ans whistles. It comes in 2 parts: | |
27 | ;; | |
28 | ;; - The first part lets you add/remove functions, similarly to | |
29 | ;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that | |
30 | ;; holds a function. | |
31 | ;; This part provides mainly 2 macros: `add-function' and `remove-function'. | |
32 | ;; | |
a77b8d5e | 33 | ;; - The second part provides `advice-add' and `advice-remove' which are |
231d8498 SM |
34 | ;; refined version of the previous macros specially tailored for the case |
35 | ;; where the place that we want to modify is a `symbol-function'. | |
36 | ||
37 | ;;; Code: | |
38 | ||
39 | ;;;; Lightweight advice/hook | |
40 | (defvar advice--where-alist | |
41 | '((:around "\300\301\302\003#\207" 5) | |
42 | (:before "\300\301\002\"\210\300\302\002\"\207" 4) | |
43 | (:after "\300\302\002\"\300\301\003\"\210\207" 5) | |
44 | (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) | |
45 | (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) | |
46 | (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) | |
47 | (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)) | |
48 | "List of descriptions of how to add a function. | |
49 | Each element has the form (WHERE BYTECODE STACK) where: | |
50 | WHERE is a keyword indicating where the function is added. | |
51 | BYTECODE is the corresponding byte-code that will be used. | |
52 | STACK is the amount of stack space needed by the byte-code.") | |
53 | ||
54 | (defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) | |
55 | ||
56 | (defun advice--p (object) | |
57 | (and (byte-code-function-p object) | |
58 | (eq 128 (aref object 0)) | |
59 | (memq (length object) '(5 6)) | |
60 | (memq (aref object 1) advice--bytecodes) | |
61 | (eq #'apply (aref (aref object 2) 0)))) | |
62 | ||
63 | (defsubst advice--car (f) (aref (aref f 2) 1)) | |
64 | (defsubst advice--cdr (f) (aref (aref f 2) 2)) | |
65 | (defsubst advice--props (f) (aref (aref f 2) 3)) | |
66 | ||
67 | (defun advice--make-docstring (_string function) | |
68 | "Build the raw doc-string of SYMBOL, presumably advised." | |
69 | (let ((flist (indirect-function function)) | |
70 | (docstring nil)) | |
71 | (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) | |
72 | (while (advice--p flist) | |
73 | (let ((bytecode (aref flist 1)) | |
74 | (where nil)) | |
75 | (dolist (elem advice--where-alist) | |
76 | (if (eq bytecode (cadr elem)) (setq where (car elem)))) | |
77 | (setq docstring | |
78 | (concat | |
79 | docstring | |
80 | (propertize (format "%s advice: " where) | |
81 | 'face 'warning) | |
82 | (let ((fun (advice--car flist))) | |
83 | (if (symbolp fun) (format "`%S'" fun) | |
84 | (let* ((name (cdr (assq 'name (advice--props flist)))) | |
85 | (doc (documentation fun t)) | |
86 | (usage (help-split-fundoc doc function))) | |
87 | (if usage (setq doc (cdr usage))) | |
88 | (if name | |
89 | (if doc | |
90 | (format "%s\n%s" name doc) | |
91 | (format "%s" name)) | |
92 | (or doc "No documentation"))))) | |
93 | "\n"))) | |
94 | (setq flist (advice--cdr flist))) | |
95 | (if docstring (setq docstring (concat docstring "\n"))) | |
96 | (let* ((origdoc (unless (eq function flist) ;Avoid inf-loops. | |
97 | (documentation flist t))) | |
98 | (usage (help-split-fundoc origdoc function))) | |
99 | (setq usage (if (null usage) | |
100 | (let ((arglist (help-function-arglist flist))) | |
101 | (format "%S" (help-make-usage function arglist))) | |
102 | (setq origdoc (cdr usage)) (car usage))) | |
103 | (help-add-fundoc-usage (concat docstring origdoc) usage)))) | |
104 | ||
105 | (defvar advice--docstring | |
106 | ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, | |
107 | ;; which drops the text-properties. | |
108 | ;;(eval-when-compile | |
109 | (propertize "Advised function" | |
110 | 'dynamic-docstring-function #'advice--make-docstring)) ;; ) | |
111 | ||
1668ea90 SM |
112 | (defun advice-eval-interactive-spec (spec) |
113 | "Evaluate the interactive spec SPEC." | |
114 | (cond | |
115 | ((stringp spec) | |
116 | ;; There's no direct access to the C code (in call-interactively) that | |
117 | ;; processes those specs, but that shouldn't stop us, should it? | |
118 | ;; FIXME: Despite appearances, this is not faithful: SPEC and | |
119 | ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t | |
120 | ;; command-history (and maybe a few other details). | |
121 | (call-interactively `(lambda (&rest args) (interactive ,spec) args))) | |
122 | ;; ((functionp spec) (funcall spec)) | |
123 | (t (eval spec)))) | |
124 | ||
231d8498 | 125 | (defun advice--make-interactive-form (function main) |
231d8498 SM |
126 | ;; TODO: make it so that interactive spec can be a constant which |
127 | ;; dynamically checks the advice--car/cdr to do its job. | |
1668ea90 SM |
128 | ;; For that, advice-eval-interactive-spec needs to be more faithful. |
129 | ;; FIXME: The calls to interactive-form below load autoloaded functions | |
130 | ;; too eagerly. | |
131 | (let ((fspec (cadr (interactive-form function)))) | |
132 | (when (eq 'function (car fspec)) ;; Macroexpanded lambda? | |
133 | (setq fspec (nth 1 fspec))) | |
134 | (if (functionp fspec) | |
135 | `(funcall ',fspec | |
136 | ',(cadr (interactive-form main))) | |
231d8498 | 137 | (cadr (or (interactive-form function) |
1668ea90 | 138 | (interactive-form main)))))) |
231d8498 SM |
139 | |
140 | (defsubst advice--make-1 (byte-code stack-depth function main props) | |
141 | "Build a function value that adds FUNCTION to MAIN." | |
142 | (let ((adv-sig (gethash main advertised-signature-table)) | |
143 | (advice | |
144 | (apply #'make-byte-code 128 byte-code | |
145 | (vector #'apply function main props) stack-depth | |
146 | advice--docstring | |
147 | (when (or (commandp function) (commandp main)) | |
148 | (list (advice--make-interactive-form | |
149 | function main)))))) | |
150 | (when adv-sig (puthash advice adv-sig advertised-signature-table)) | |
151 | advice)) | |
152 | ||
153 | (defun advice--make (where function main props) | |
154 | "Build a function value that adds FUNCTION to MAIN at WHERE. | |
155 | WHERE is a symbol to select an entry in `advice--where-alist'." | |
156 | (let ((desc (assq where advice--where-alist))) | |
157 | (unless desc (error "Unknown add-function location `%S'" where)) | |
158 | (advice--make-1 (nth 1 desc) (nth 2 desc) | |
159 | function main props))) | |
160 | ||
161 | (defun advice--member-p (function definition) | |
162 | (let ((found nil)) | |
163 | (while (and (not found) (advice--p definition)) | |
164 | (if (or (equal function (advice--car definition)) | |
165 | (equal function (cdr (assq 'name (advice--props definition))))) | |
166 | (setq found t) | |
167 | (setq definition (advice--cdr definition)))) | |
168 | found)) | |
169 | ||
170 | ;;;###autoload | |
171 | (defun advice--remove-function (flist function) | |
172 | (if (not (advice--p flist)) | |
173 | flist | |
174 | (let ((first (advice--car flist)) | |
175 | (props (advice--props flist))) | |
176 | (if (or (equal function first) | |
177 | (equal function (cdr (assq 'name props)))) | |
178 | (advice--cdr flist) | |
179 | (let* ((rest (advice--cdr flist)) | |
180 | (nrest (advice--remove-function rest function))) | |
181 | (if (eq rest nrest) flist | |
182 | (advice--make-1 (aref flist 1) (aref flist 3) | |
183 | first nrest props))))))) | |
184 | ||
185 | ;;;###autoload | |
186 | (defmacro add-function (where place function &optional props) | |
187 | ;; TODO: | |
188 | ;; - provide something like `around' for interactive forms. | |
189 | ;; - provide some kind of buffer-local functionality at least when `place' | |
190 | ;; is a variable. | |
191 | ;; - obsolete with-wrapper-hook (mostly requires buffer-local support). | |
192 | ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP | |
193 | ;; and tracing want to stay first. | |
194 | ;; - maybe also let `where' specify some kind of predicate and use it | |
195 | ;; to implement things like mode-local or eieio-defmethod. | |
196 | ;; :before is like a normal add-hook on a normal hook. | |
197 | ;; :before-while is like add-hook on run-hook-with-args-until-failure. | |
198 | ;; :before-until is like add-hook on run-hook-with-args-until-success. | |
199 | ;; Same with :after-* but for (add-hook ... 'append). | |
200 | "Add a piece of advice on the function stored at PLACE. | |
201 | FUNCTION describes the code to add. WHERE describes where to add it. | |
202 | WHERE can be explained by showing the resulting new function, as the | |
203 | result of combining FUNCTION and the previous value of PLACE, which we | |
204 | call OLDFUN here: | |
205 | `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) | |
206 | `:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) | |
207 | `:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) | |
208 | `:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) | |
209 | `:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) | |
210 | `:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) | |
211 | `:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) | |
212 | If FUNCTION was already added, do nothing. | |
213 | PROPS is an alist of additional properties, among which the following have | |
214 | a special meaning: | |
1668ea90 SM |
215 | - `name': a string or symbol. It can be used to refer to this piece of advice. |
216 | ||
217 | If one of FUNCTION or OLDFUN is interactive, then the resulting function | |
218 | is also interactive. There are 3 cases: | |
219 | - FUNCTION is not interactive: the interactive spec of OLDFUN is used. | |
220 | - The interactive spec of FUNCTION is itself a function: it should take one | |
221 | argument (the interactive spec of OLDFUN, which it can pass to | |
222 | `advice-eval-interactive-spec') and return the list of arguments to use. | |
223 | - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." | |
231d8498 SM |
224 | (declare (debug t)) ;;(indent 2) |
225 | `(advice--add-function ,where (gv-ref ,place) ,function ,props)) | |
226 | ||
227 | ;;;###autoload | |
228 | (defun advice--add-function (where ref function props) | |
229 | (unless (advice--member-p function (gv-deref ref)) | |
230 | (setf (gv-deref ref) | |
231 | (advice--make where function (gv-deref ref) props)))) | |
232 | ||
233 | (defmacro remove-function (place function) | |
234 | "Remove the FUNCTION piece of advice from PLACE. | |
235 | If FUNCTION was not added to PLACE, do nothing. | |
236 | Instead of FUNCTION being the actual function, it can also be the `name' | |
237 | of the piece of advice." | |
238 | (declare (debug t)) | |
239 | (gv-letplace (getter setter) place | |
240 | (macroexp-let2 nil new `(advice--remove-function ,getter ,function) | |
241 | `(unless (eq ,new ,getter) ,(funcall setter new))))) | |
242 | ||
243 | ;;;; Specific application of add-function to `symbol-function' for advice. | |
244 | ||
245 | (defun advice--subst-main (old new) | |
246 | (if (not (advice--p old)) | |
247 | new | |
248 | (let* ((first (advice--car old)) | |
249 | (rest (advice--cdr old)) | |
250 | (props (advice--props old)) | |
251 | (nrest (advice--subst-main rest new))) | |
252 | (if (equal rest nrest) old | |
253 | (advice--make-1 (aref old 1) (aref old 3) | |
254 | first nrest props))))) | |
255 | ||
413d4689 SM |
256 | (defun advice--normalize (symbol def) |
257 | (cond | |
258 | ((special-form-p def) | |
259 | ;; Not worth the trouble trying to handle this, I think. | |
a77b8d5e | 260 | (error "advice-add failure: %S is a special form" symbol)) |
413d4689 SM |
261 | ((and (symbolp def) |
262 | (eq 'macro (car-safe (ignore-errors (indirect-function def))))) | |
263 | (let ((newval (cons 'macro (cdr (indirect-function def))))) | |
264 | (put symbol 'advice--saved-rewrite (cons def newval)) | |
265 | newval)) | |
266 | ;; `f' might be a pure (hence read-only) cons! | |
267 | ((and (eq 'macro (car-safe def)) | |
268 | (not (ignore-errors (setcdr def (cdr def)) t))) | |
269 | (cons 'macro (cdr def))) | |
270 | (t def))) | |
271 | ||
272 | (defsubst advice--strip-macro (x) | |
273 | (if (eq 'macro (car-safe x)) (cdr x) x)) | |
274 | ||
231d8498 | 275 | (defun advice--defalias-fset (fsetfun symbol newdef) |
413d4689 SM |
276 | (when (get symbol 'advice--saved-rewrite) |
277 | (put symbol 'advice--saved-rewrite nil)) | |
278 | (setq newdef (advice--normalize symbol newdef)) | |
279 | (let* ((olddef (advice--strip-macro | |
280 | (if (fboundp symbol) (symbol-function symbol)))) | |
231d8498 SM |
281 | (oldadv |
282 | (cond | |
413d4689 SM |
283 | ((null (get symbol 'advice--pending)) |
284 | (or olddef | |
285 | (progn | |
286 | (message "Delayed advice activation failed for %s: no data" | |
287 | symbol) | |
288 | nil))) | |
289 | ((or (not olddef) (autoloadp olddef)) | |
290 | (prog1 (get symbol 'advice--pending) | |
291 | (put symbol 'advice--pending nil))) | |
231d8498 SM |
292 | (t (message "Dropping left-over advice--pending for %s" symbol) |
293 | (put symbol 'advice--pending nil) | |
294 | olddef)))) | |
413d4689 SM |
295 | (let* ((snewdef (advice--strip-macro newdef)) |
296 | (snewadv (advice--subst-main oldadv snewdef))) | |
297 | (funcall (or fsetfun #'fset) symbol | |
298 | (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))))) | |
231d8498 SM |
299 | |
300 | ||
301 | ;;;###autoload | |
302 | (defun advice-add (symbol where function &optional props) | |
303 | "Like `add-function' but for the function named SYMBOL. | |
304 | Contrary to `add-function', this will properly handle the cases where SYMBOL | |
305 | is defined as a macro, alias, command, ..." | |
306 | ;; TODO: | |
307 | ;; - record the advice location, to display in describe-function. | |
308 | ;; - change all defadvice in lisp/**/*.el. | |
309 | ;; - rewrite advice.el on top of this. | |
310 | ;; - obsolete advice.el. | |
413d4689 SM |
311 | (let* ((f (and (fboundp symbol) (symbol-function symbol))) |
312 | (nf (advice--normalize symbol f))) | |
313 | (unless (eq f nf) ;; Most importantly, if nf == nil! | |
314 | (fset symbol nf)) | |
231d8498 | 315 | (add-function where (cond |
413d4689 | 316 | ((eq (car-safe nf) 'macro) (cdr nf)) |
1668ea90 SM |
317 | ;; Reasons to delay installation of the advice: |
318 | ;; - If the function is not yet defined, installing | |
319 | ;; the advice would affect `fboundp'ness. | |
320 | ;; - If it's an autoloaded command, | |
321 | ;; advice--make-interactive-form would end up | |
322 | ;; loading the command eagerly. | |
323 | ;; - `autoload' does nothing if the function is | |
324 | ;; not an autoload or undefined. | |
325 | ((or (not nf) (autoloadp nf)) | |
231d8498 SM |
326 | (get symbol 'advice--pending)) |
327 | (t (symbol-function symbol))) | |
328 | function props) | |
329 | (add-function :around (get symbol 'defalias-fset-function) | |
330 | #'advice--defalias-fset)) | |
331 | nil) | |
332 | ||
333 | ;;;###autoload | |
334 | (defun advice-remove (symbol function) | |
335 | "Like `remove-function' but for the function named SYMBOL. | |
336 | Contrary to `remove-function', this will work also when SYMBOL is a macro | |
337 | and it will not signal an error if SYMBOL is not `fboundp'. | |
338 | Instead of the actual function to remove, FUNCTION can also be the `name' | |
339 | of the piece of advice." | |
340 | (when (fboundp symbol) | |
341 | (let ((f (symbol-function symbol))) | |
342 | ;; Can't use the `if' place here, because the body is too large, | |
343 | ;; resulting in use of code that only works with lexical-scoping. | |
344 | (remove-function (if (eq (car-safe f) 'macro) | |
345 | (cdr f) | |
346 | (symbol-function symbol)) | |
347 | function) | |
348 | (unless (advice--p | |
349 | (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) | |
413d4689 | 350 | ;; Not advised any more. |
231d8498 SM |
351 | (remove-function (get symbol 'defalias-fset-function) |
352 | #'advice--defalias-fset) | |
353 | (if (eq (symbol-function symbol) | |
354 | (cdr (get symbol 'advice--saved-rewrite))) | |
355 | (fset symbol (car (get symbol 'advice--saved-rewrite)))))) | |
356 | nil)) | |
357 | ||
358 | ;; (defun advice-mapc (fun symbol) | |
359 | ;; "Apply FUN to every function added as advice to SYMBOL. | |
360 | ;; FUN is called with a two arguments: the function that was added, and the | |
361 | ;; properties alist that was specified when it was added." | |
362 | ;; (let ((def (or (get symbol 'advice--pending) | |
363 | ;; (if (fboundp symbol) (symbol-function symbol))))) | |
364 | ;; (while (advice--p def) | |
365 | ;; (funcall fun (advice--car def) (advice--props def)) | |
366 | ;; (setq def (advice--cdr def))))) | |
367 | ||
368 | ;;;###autoload | |
413d4689 SM |
369 | (defun advice-member-p (advice function-name) |
370 | "Return non-nil if ADVICE has been added to FUNCTION-NAME. | |
371 | Instead of ADVICE being the actual function, it can also be the `name' | |
231d8498 | 372 | of the piece of advice." |
413d4689 SM |
373 | (advice--member-p advice |
374 | (or (get function-name 'advice--pending) | |
375 | (advice--strip-macro | |
376 | (if (fboundp function-name) | |
377 | (symbol-function function-name)))))) | |
231d8498 SM |
378 | |
379 | ||
380 | (provide 'nadvice) | |
381 | ;;; nadvice.el ends here |