Commit | Line | Data |
---|---|---|
231d8498 SM |
1 | ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2012-2014 Free Software Foundation, Inc. |
231d8498 SM |
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 | |
8725b746 | 26 | ;; bells and whistles. It comes in 2 parts: |
231d8498 SM |
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) | |
bcd7a0a4 | 44 | (:override "\300\301\ 2\"\207" 4) |
231d8498 SM |
45 | (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) |
46 | (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) | |
47 | (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) | |
d36ed1c8 SM |
48 | (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) |
49 | (:filter-args "\300\302\301\ 3!\"\207" 5) | |
50 | (:filter-return "\301\300\302\ 3\"!\207" 5)) | |
231d8498 SM |
51 | "List of descriptions of how to add a function. |
52 | Each element has the form (WHERE BYTECODE STACK) where: | |
53 | WHERE is a keyword indicating where the function is added. | |
54 | BYTECODE is the corresponding byte-code that will be used. | |
55 | STACK is the amount of stack space needed by the byte-code.") | |
56 | ||
57 | (defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) | |
58 | ||
59 | (defun advice--p (object) | |
60 | (and (byte-code-function-p object) | |
61 | (eq 128 (aref object 0)) | |
62 | (memq (length object) '(5 6)) | |
63 | (memq (aref object 1) advice--bytecodes) | |
64 | (eq #'apply (aref (aref object 2) 0)))) | |
65 | ||
66 | (defsubst advice--car (f) (aref (aref f 2) 1)) | |
67 | (defsubst advice--cdr (f) (aref (aref f 2) 2)) | |
68 | (defsubst advice--props (f) (aref (aref f 2) 3)) | |
69 | ||
70e5a261 SM |
70 | (defun advice--cd*r (f) |
71 | (while (advice--p f) | |
72 | (setq f (advice--cdr f))) | |
73 | f) | |
74 | ||
0d53f628 CY |
75 | (defun advice--make-docstring (function) |
76 | "Build the raw docstring for FUNCTION, presumably advised." | |
049fac7c SM |
77 | (let* ((flist (indirect-function function)) |
78 | (docfun nil) | |
79 | (docstring nil)) | |
231d8498 SM |
80 | (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) |
81 | (while (advice--p flist) | |
82 | (let ((bytecode (aref flist 1)) | |
049fac7c | 83 | (doc (aref flist 4)) |
231d8498 | 84 | (where nil)) |
049fac7c SM |
85 | ;; Hack attack! For advices installed before calling |
86 | ;; Snarf-documentation, the integer offset into the DOC file will not | |
87 | ;; be installed in the "core unadvised function" but in the advice | |
88 | ;; object instead! So here we try to undo the damage. | |
89 | (if (integerp doc) (setq docfun flist)) | |
231d8498 SM |
90 | (dolist (elem advice--where-alist) |
91 | (if (eq bytecode (cadr elem)) (setq where (car elem)))) | |
92 | (setq docstring | |
93 | (concat | |
94 | docstring | |
95 | (propertize (format "%s advice: " where) | |
96 | 'face 'warning) | |
97 | (let ((fun (advice--car flist))) | |
98 | (if (symbolp fun) (format "`%S'" fun) | |
99 | (let* ((name (cdr (assq 'name (advice--props flist)))) | |
100 | (doc (documentation fun t)) | |
101 | (usage (help-split-fundoc doc function))) | |
102 | (if usage (setq doc (cdr usage))) | |
103 | (if name | |
104 | (if doc | |
105 | (format "%s\n%s" name doc) | |
106 | (format "%s" name)) | |
107 | (or doc "No documentation"))))) | |
108 | "\n"))) | |
109 | (setq flist (advice--cdr flist))) | |
110 | (if docstring (setq docstring (concat docstring "\n"))) | |
049fac7c SM |
111 | (unless docfun (setq docfun flist)) |
112 | (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops. | |
113 | (documentation docfun t))) | |
231d8498 SM |
114 | (usage (help-split-fundoc origdoc function))) |
115 | (setq usage (if (null usage) | |
116 | (let ((arglist (help-function-arglist flist))) | |
117 | (format "%S" (help-make-usage function arglist))) | |
118 | (setq origdoc (cdr usage)) (car usage))) | |
119 | (help-add-fundoc-usage (concat docstring origdoc) usage)))) | |
120 | ||
1668ea90 SM |
121 | (defun advice-eval-interactive-spec (spec) |
122 | "Evaluate the interactive spec SPEC." | |
123 | (cond | |
124 | ((stringp spec) | |
125 | ;; There's no direct access to the C code (in call-interactively) that | |
126 | ;; processes those specs, but that shouldn't stop us, should it? | |
127 | ;; FIXME: Despite appearances, this is not faithful: SPEC and | |
128 | ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t | |
129 | ;; command-history (and maybe a few other details). | |
130 | (call-interactively `(lambda (&rest args) (interactive ,spec) args))) | |
131 | ;; ((functionp spec) (funcall spec)) | |
132 | (t (eval spec)))) | |
133 | ||
adbfe42c SM |
134 | (defun advice--interactive-form (function) |
135 | ;; Like `interactive-form' but tries to avoid autoloading functions. | |
136 | (when (commandp function) | |
137 | (if (not (and (symbolp function) (autoloadp (symbol-function function)))) | |
138 | (interactive-form function) | |
139 | `(interactive (advice-eval-interactive-spec | |
140 | (cadr (interactive-form ',function))))))) | |
141 | ||
231d8498 | 142 | (defun advice--make-interactive-form (function main) |
231d8498 SM |
143 | ;; TODO: make it so that interactive spec can be a constant which |
144 | ;; dynamically checks the advice--car/cdr to do its job. | |
1668ea90 | 145 | ;; For that, advice-eval-interactive-spec needs to be more faithful. |
adbfe42c SM |
146 | (let* ((iff (advice--interactive-form function)) |
147 | (ifm (advice--interactive-form main)) | |
148 | (fspec (cadr iff))) | |
47f01a8a | 149 | (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? |
1668ea90 SM |
150 | (setq fspec (nth 1 fspec))) |
151 | (if (functionp fspec) | |
adbfe42c SM |
152 | `(funcall ',fspec ',(cadr ifm)) |
153 | (cadr (or iff ifm))))) | |
231d8498 | 154 | |
adbfe42c | 155 | (defun advice--make-1 (byte-code stack-depth function main props) |
231d8498 SM |
156 | "Build a function value that adds FUNCTION to MAIN." |
157 | (let ((adv-sig (gethash main advertised-signature-table)) | |
158 | (advice | |
159 | (apply #'make-byte-code 128 byte-code | |
1ea22560 | 160 | (vector #'apply function main props) stack-depth nil |
cb3a1380 | 161 | (and (or (commandp function) (commandp main)) |
cb3a1380 SM |
162 | (list (advice--make-interactive-form |
163 | function main)))))) | |
231d8498 SM |
164 | (when adv-sig (puthash advice adv-sig advertised-signature-table)) |
165 | advice)) | |
166 | ||
167 | (defun advice--make (where function main props) | |
168 | "Build a function value that adds FUNCTION to MAIN at WHERE. | |
169 | WHERE is a symbol to select an entry in `advice--where-alist'." | |
cb3a1380 SM |
170 | (let ((fd (or (cdr (assq 'depth props)) 0)) |
171 | (md (if (advice--p main) | |
172 | (or (cdr (assq 'depth (advice--props main))) 0)))) | |
173 | (if (and md (> fd md)) | |
174 | ;; `function' should go deeper. | |
175 | (let ((rest (advice--make where function (advice--cdr main) props))) | |
176 | (advice--make-1 (aref main 1) (aref main 3) | |
177 | (advice--car main) rest (advice--props main))) | |
178 | (let ((desc (assq where advice--where-alist))) | |
179 | (unless desc (error "Unknown add-function location `%S'" where)) | |
180 | (advice--make-1 (nth 1 desc) (nth 2 desc) | |
181 | function main props))))) | |
231d8498 | 182 | |
dabefae5 | 183 | (defun advice--member-p (function name definition) |
231d8498 SM |
184 | (let ((found nil)) |
185 | (while (and (not found) (advice--p definition)) | |
5d03fb43 SM |
186 | (if (if name |
187 | (equal name (cdr (assq 'name (advice--props definition)))) | |
188 | (equal function (advice--car definition))) | |
c67c0839 | 189 | (setq found definition) |
231d8498 SM |
190 | (setq definition (advice--cdr definition)))) |
191 | found)) | |
192 | ||
a731fc1b | 193 | (defun advice--tweak (flist tweaker) |
231d8498 | 194 | (if (not (advice--p flist)) |
a731fc1b | 195 | (funcall tweaker nil flist nil) |
231d8498 | 196 | (let ((first (advice--car flist)) |
a731fc1b | 197 | (rest (advice--cdr flist)) |
231d8498 | 198 | (props (advice--props flist))) |
cb9c0a53 SM |
199 | (let ((val (funcall tweaker first rest props))) |
200 | (if val (car val) | |
a731fc1b SM |
201 | (let ((nrest (advice--tweak rest tweaker))) |
202 | (if (eq rest nrest) flist | |
203 | (advice--make-1 (aref flist 1) (aref flist 3) | |
cb9c0a53 | 204 | first nrest props)))))))) |
a731fc1b SM |
205 | |
206 | ;;;###autoload | |
207 | (defun advice--remove-function (flist function) | |
208 | (advice--tweak flist | |
209 | (lambda (first rest props) | |
cb9c0a53 SM |
210 | (cond ((not first) rest) |
211 | ((or (equal function first) | |
5d03fb43 SM |
212 | (equal function (cdr (assq 'name props)))) |
213 | (list (advice--remove-function rest function))))))) | |
231d8498 | 214 | |
1d44e9dc SM |
215 | (defvar advice--buffer-local-function-sample nil |
216 | "keeps an example of the special \"run the default value\" functions. | |
217 | These functions play the same role as t in buffer-local hooks, and to recognize | |
218 | them, we keep a sample here against which to compare. Each instance is | |
219 | different, but `function-equal' will hopefully ignore those differences.") | |
a61428c4 SM |
220 | |
221 | (defun advice--set-buffer-local (var val) | |
222 | (if (function-equal val advice--buffer-local-function-sample) | |
223 | (kill-local-variable var) | |
224 | (set (make-local-variable var) val))) | |
225 | ||
226 | ;;;###autoload | |
227 | (defun advice--buffer-local (var) | |
228 | "Buffer-local value of VAR, presumed to contain a function." | |
229 | (declare (gv-setter advice--set-buffer-local)) | |
230 | (if (local-variable-p var) (symbol-value var) | |
231 | (setq advice--buffer-local-function-sample | |
1d44e9dc | 232 | ;; This function acts like the t special value in buffer-local hooks. |
a61428c4 SM |
233 | (lambda (&rest args) (apply (default-value var) args))))) |
234 | ||
5d03fb43 SM |
235 | (defun advice--normalize-place (place) |
236 | (cond ((eq 'local (car-safe place)) `(advice--buffer-local ,@(cdr place))) | |
237 | ((eq 'var (car-safe place)) (nth 1 place)) | |
238 | ((symbolp place) `(default-value ',place)) | |
239 | (t place))) | |
240 | ||
231d8498 SM |
241 | ;;;###autoload |
242 | (defmacro add-function (where place function &optional props) | |
243 | ;; TODO: | |
a61428c4 | 244 | ;; - maybe let `where' specify some kind of predicate and use it |
231d8498 | 245 | ;; to implement things like mode-local or eieio-defmethod. |
a61428c4 SM |
246 | ;; Of course, that only makes sense if the predicates of all advices can |
247 | ;; be combined and made more efficient. | |
231d8498 SM |
248 | ;; :before is like a normal add-hook on a normal hook. |
249 | ;; :before-while is like add-hook on run-hook-with-args-until-failure. | |
250 | ;; :before-until is like add-hook on run-hook-with-args-until-success. | |
251 | ;; Same with :after-* but for (add-hook ... 'append). | |
252 | "Add a piece of advice on the function stored at PLACE. | |
253 | FUNCTION describes the code to add. WHERE describes where to add it. | |
254 | WHERE can be explained by showing the resulting new function, as the | |
255 | result of combining FUNCTION and the previous value of PLACE, which we | |
256 | call OLDFUN here: | |
257 | `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) | |
258 | `:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) | |
259 | `:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) | |
bcd7a0a4 | 260 | `:override' (lambda (&rest r) (apply FUNCTION r)) |
231d8498 SM |
261 | `:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) |
262 | `:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) | |
263 | `:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) | |
264 | `:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) | |
d36ed1c8 SM |
265 | `:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) |
266 | `:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) | |
231d8498 SM |
267 | If FUNCTION was already added, do nothing. |
268 | PROPS is an alist of additional properties, among which the following have | |
269 | a special meaning: | |
1668ea90 | 270 | - `name': a string or symbol. It can be used to refer to this piece of advice. |
cb3a1380 SM |
271 | - `depth': a number indicating a preference w.r.t ordering. |
272 | The default depth is 0. By convention, a depth of 100 means that | |
273 | the advice should be innermost (i.e. at the end of the list), | |
274 | whereas a depth of -100 means that the advice should be outermost. | |
1668ea90 | 275 | |
5d03fb43 SM |
276 | If PLACE is a symbol, its `default-value' will be affected. |
277 | Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. | |
278 | Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR. | |
a61428c4 | 279 | |
1668ea90 SM |
280 | If one of FUNCTION or OLDFUN is interactive, then the resulting function |
281 | is also interactive. There are 3 cases: | |
282 | - FUNCTION is not interactive: the interactive spec of OLDFUN is used. | |
283 | - The interactive spec of FUNCTION is itself a function: it should take one | |
284 | argument (the interactive spec of OLDFUN, which it can pass to | |
285 | `advice-eval-interactive-spec') and return the list of arguments to use. | |
286 | - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." | |
231d8498 | 287 | (declare (debug t)) ;;(indent 2) |
5d03fb43 SM |
288 | `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) |
289 | ,function ,props)) | |
231d8498 SM |
290 | |
291 | ;;;###autoload | |
292 | (defun advice--add-function (where ref function props) | |
5d03fb43 SM |
293 | (let* ((name (cdr (assq 'name props))) |
294 | (a (advice--member-p function name (gv-deref ref)))) | |
c67c0839 SM |
295 | (when a |
296 | ;; The advice is already present. Remove the old one, first. | |
297 | (setf (gv-deref ref) | |
5d03fb43 SM |
298 | (advice--remove-function (gv-deref ref) |
299 | (or name (advice--car a))))) | |
231d8498 SM |
300 | (setf (gv-deref ref) |
301 | (advice--make where function (gv-deref ref) props)))) | |
302 | ||
bcd7a0a4 | 303 | ;;;###autoload |
231d8498 SM |
304 | (defmacro remove-function (place function) |
305 | "Remove the FUNCTION piece of advice from PLACE. | |
306 | If FUNCTION was not added to PLACE, do nothing. | |
307 | Instead of FUNCTION being the actual function, it can also be the `name' | |
308 | of the piece of advice." | |
309 | (declare (debug t)) | |
5d03fb43 | 310 | (gv-letplace (getter setter) (advice--normalize-place place) |
231d8498 SM |
311 | (macroexp-let2 nil new `(advice--remove-function ,getter ,function) |
312 | `(unless (eq ,new ,getter) ,(funcall setter new))))) | |
313 | ||
1d44e9dc SM |
314 | (defun advice-function-mapc (f function-def) |
315 | "Apply F to every advice function in FUNCTION-DEF. | |
316 | F is called with two arguments: the function that was added, and the | |
317 | properties alist that was specified when it was added." | |
318 | (while (advice--p function-def) | |
319 | (funcall f (advice--car function-def) (advice--props function-def)) | |
320 | (setq function-def (advice--cdr function-def)))) | |
321 | ||
322 | (defun advice-function-member-p (advice function-def) | |
323 | "Return non-nil if ADVICE is already in FUNCTION-DEF. | |
324 | Instead of ADVICE being the actual function, it can also be the `name' | |
325 | of the piece of advice." | |
326 | (advice--member-p advice advice function-def)) | |
327 | ||
231d8498 SM |
328 | ;;;; Specific application of add-function to `symbol-function' for advice. |
329 | ||
330 | (defun advice--subst-main (old new) | |
a731fc1b SM |
331 | (advice--tweak old |
332 | (lambda (first _rest _props) (if (not first) new)))) | |
231d8498 | 333 | |
413d4689 SM |
334 | (defun advice--normalize (symbol def) |
335 | (cond | |
336 | ((special-form-p def) | |
337 | ;; Not worth the trouble trying to handle this, I think. | |
1d44e9dc | 338 | (error "Advice impossible: %S is a special form" symbol)) |
671d5c16 SM |
339 | ((and (symbolp def) (macrop def)) |
340 | (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r)))))) | |
1d44e9dc | 341 | (put symbol 'advice--saved-rewrite (cons def (cdr newval))) |
413d4689 SM |
342 | newval)) |
343 | ;; `f' might be a pure (hence read-only) cons! | |
344 | ((and (eq 'macro (car-safe def)) | |
345 | (not (ignore-errors (setcdr def (cdr def)) t))) | |
346 | (cons 'macro (cdr def))) | |
347 | (t def))) | |
348 | ||
349 | (defsubst advice--strip-macro (x) | |
350 | (if (eq 'macro (car-safe x)) (cdr x) x)) | |
351 | ||
1d44e9dc SM |
352 | (defun advice--symbol-function (symbol) |
353 | ;; The value conceptually stored in `symbol-function' is split into two | |
354 | ;; parts: | |
355 | ;; - the normal function definition. | |
356 | ;; - the list of advice applied to it. | |
357 | ;; `advice--symbol-function' is intended to return the second part (i.e. the | |
358 | ;; list of advice, which includes a hole at the end which typically holds the | |
359 | ;; first part, but this function doesn't care much which value is found | |
360 | ;; there). | |
361 | ;; In the "normal" state both parts are combined into a single value stored | |
362 | ;; in the "function slot" of the symbol. But the way they are combined is | |
363 | ;; different depending on whether the definition is a function or a macro. | |
364 | ;; Also if the function definition is nil (i.e. unbound) or is an autoload, | |
365 | ;; the second part is stashed away temporarily in the `advice--pending' | |
366 | ;; symbol property. | |
367 | (or (get symbol 'advice--pending) | |
368 | (advice--strip-macro (symbol-function symbol)))) | |
369 | ||
231d8498 | 370 | (defun advice--defalias-fset (fsetfun symbol newdef) |
1d44e9dc | 371 | (unless fsetfun (setq fsetfun #'fset)) |
413d4689 SM |
372 | (when (get symbol 'advice--saved-rewrite) |
373 | (put symbol 'advice--saved-rewrite nil)) | |
374 | (setq newdef (advice--normalize symbol newdef)) | |
671d5c16 | 375 | (let ((oldadv (advice--symbol-function symbol))) |
539f75f4 SM |
376 | (if (and newdef (not (autoloadp newdef))) |
377 | (let* ((snewdef (advice--strip-macro newdef)) | |
378 | (snewadv (advice--subst-main oldadv snewdef))) | |
379 | (put symbol 'advice--pending nil) | |
1d44e9dc | 380 | (funcall fsetfun symbol |
539f75f4 SM |
381 | (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))) |
382 | (unless (eq oldadv (get symbol 'advice--pending)) | |
383 | (put symbol 'advice--pending (advice--subst-main oldadv nil))) | |
1d44e9dc | 384 | (funcall fsetfun symbol newdef)))) |
231d8498 SM |
385 | |
386 | ;;;###autoload | |
387 | (defun advice-add (symbol where function &optional props) | |
388 | "Like `add-function' but for the function named SYMBOL. | |
389 | Contrary to `add-function', this will properly handle the cases where SYMBOL | |
390 | is defined as a macro, alias, command, ..." | |
391 | ;; TODO: | |
392 | ;; - record the advice location, to display in describe-function. | |
393 | ;; - change all defadvice in lisp/**/*.el. | |
231d8498 | 394 | ;; - obsolete advice.el. |
539f75f4 | 395 | (let* ((f (symbol-function symbol)) |
413d4689 | 396 | (nf (advice--normalize symbol f))) |
1d44e9dc | 397 | (unless (eq f nf) (fset symbol nf)) |
231d8498 | 398 | (add-function where (cond |
413d4689 | 399 | ((eq (car-safe nf) 'macro) (cdr nf)) |
1668ea90 SM |
400 | ;; Reasons to delay installation of the advice: |
401 | ;; - If the function is not yet defined, installing | |
402 | ;; the advice would affect `fboundp'ness. | |
adbfe42c SM |
403 | ;; - the symbol-function slot of an autoloaded |
404 | ;; function is not itself a function value. | |
1668ea90 SM |
405 | ;; - `autoload' does nothing if the function is |
406 | ;; not an autoload or undefined. | |
407 | ((or (not nf) (autoloadp nf)) | |
231d8498 SM |
408 | (get symbol 'advice--pending)) |
409 | (t (symbol-function symbol))) | |
410 | function props) | |
0d53f628 | 411 | (put symbol 'function-documentation `(advice--make-docstring ',symbol)) |
231d8498 SM |
412 | (add-function :around (get symbol 'defalias-fset-function) |
413 | #'advice--defalias-fset)) | |
414 | nil) | |
415 | ||
416 | ;;;###autoload | |
417 | (defun advice-remove (symbol function) | |
418 | "Like `remove-function' but for the function named SYMBOL. | |
539f75f4 SM |
419 | Contrary to `remove-function', this also works when SYMBOL is a macro |
420 | or an autoload and it preserves `fboundp'. | |
231d8498 SM |
421 | Instead of the actual function to remove, FUNCTION can also be the `name' |
422 | of the piece of advice." | |
539f75f4 | 423 | (let ((f (symbol-function symbol))) |
1d44e9dc SM |
424 | (remove-function (cond ;This is `advice--symbol-function' but as a "place". |
425 | ((get symbol 'advice--pending) | |
426 | (get symbol 'advice--pending)) | |
427 | ((eq (car-safe f) 'macro) (cdr f)) | |
428 | (t (symbol-function symbol))) | |
539f75f4 | 429 | function) |
671d5c16 | 430 | (unless (advice--p (advice--symbol-function symbol)) |
539f75f4 SM |
431 | (remove-function (get symbol 'defalias-fset-function) |
432 | #'advice--defalias-fset) | |
1d44e9dc SM |
433 | (let ((asr (get symbol 'advice--saved-rewrite))) |
434 | (and asr (eq (cdr-safe (symbol-function symbol)) | |
435 | (cdr asr)) | |
436 | (fset symbol (car (get symbol 'advice--saved-rewrite))))))) | |
539f75f4 SM |
437 | nil) |
438 | ||
1d44e9dc SM |
439 | (defun advice-mapc (fun symbol) |
440 | "Apply FUN to every advice function in SYMBOL. | |
539f75f4 SM |
441 | FUN is called with a two arguments: the function that was added, and the |
442 | properties alist that was specified when it was added." | |
1d44e9dc | 443 | (advice-function-mapc fun (advice--symbol-function symbol))) |
231d8498 SM |
444 | |
445 | ;;;###autoload | |
1d44e9dc SM |
446 | (defun advice-member-p (advice symbol) |
447 | "Return non-nil if ADVICE has been added to SYMBOL. | |
413d4689 | 448 | Instead of ADVICE being the actual function, it can also be the `name' |
231d8498 | 449 | of the piece of advice." |
1d44e9dc | 450 | (advice-function-member-p advice (advice--symbol-function symbol))) |
231d8498 | 451 | |
23ba2705 SM |
452 | ;; When code is advised, called-interactively-p needs to be taught to skip |
453 | ;; the advising frames. | |
454 | ;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p | |
455 | ;; done from the advised function if the deepest advice is an around advice! | |
456 | ;; In other cases (calls from an advice or calls from the advised function when | |
457 | ;; the deepest advice is not an around advice), it should hopefully get | |
458 | ;; it right. | |
459 | (add-hook 'called-interactively-p-functions | |
460 | #'advice--called-interactively-skip) | |
461 | (defun advice--called-interactively-skip (origi frame1 frame2) | |
462 | (let* ((i origi) | |
463 | (get-next-frame | |
464 | (lambda () | |
465 | (setq frame1 frame2) | |
7ced0d04 | 466 | (setq frame2 (backtrace-frame i #'called-interactively-p)) |
23ba2705 SM |
467 | ;; (message "Advice Frame %d = %S" i frame2) |
468 | (setq i (1+ i))))) | |
469 | (when (and (eq (nth 1 frame2) 'apply) | |
470 | (progn | |
471 | (funcall get-next-frame) | |
472 | (advice--p (indirect-function (nth 1 frame2))))) | |
473 | (funcall get-next-frame) | |
474 | ;; If we now have the symbol, this was the head advice and | |
475 | ;; we're done. | |
476 | (while (advice--p (nth 1 frame1)) | |
477 | ;; This was an inner advice called from some earlier advice. | |
478 | ;; The stack frames look different depending on the particular | |
479 | ;; kind of the earlier advice. | |
480 | (let ((inneradvice (nth 1 frame1))) | |
481 | (if (and (eq (nth 1 frame2) 'apply) | |
482 | (progn | |
483 | (funcall get-next-frame) | |
484 | (advice--p (indirect-function | |
485 | (nth 1 frame2))))) | |
486 | ;; The earlier advice was something like a before/after | |
487 | ;; advice where the "next" code is called directly by the | |
488 | ;; advice--p object. | |
489 | (funcall get-next-frame) | |
490 | ;; It's apparently an around advice, where the "next" is | |
491 | ;; called by the body of the advice in any way it sees fit, | |
492 | ;; so we need to skip the frames of that body. | |
493 | (while | |
494 | (progn | |
495 | (funcall get-next-frame) | |
496 | (not (and (eq (nth 1 frame2) 'apply) | |
497 | (eq (nth 3 frame2) inneradvice))))) | |
498 | (funcall get-next-frame) | |
499 | (funcall get-next-frame)))) | |
500 | (- i origi 1)))) | |
501 | ||
231d8498 SM |
502 | |
503 | (provide 'nadvice) | |
504 | ;;; nadvice.el ends here |