Line data Source code
1 : ;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1993-1994, 2000-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
6 : ;; Maintainer: emacs-devel@gnu.org
7 : ;; Created: 12 Dec 1992
8 : ;; Keywords: extensions, lisp, tools
9 : ;; Package: emacs
10 :
11 : ;; This file is part of GNU Emacs.
12 :
13 : ;; GNU Emacs is free software: you can redistribute it and/or modify
14 : ;; it under the terms of the GNU General Public License as published by
15 : ;; the Free Software Foundation, either version 3 of the License, or
16 : ;; (at your option) any later version.
17 :
18 : ;; GNU Emacs is distributed in the hope that it will be useful,
19 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 : ;; GNU General Public License for more details.
22 :
23 : ;; You should have received a copy of the GNU General Public License
24 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 :
26 : ;; LCD Archive Entry:
27 : ;; advice|Hans Chalupsky|hans@cs.buffalo.edu|
28 : ;; Overloading mechanism for Emacs Lisp functions|
29 : ;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z|
30 :
31 :
32 : ;;; Commentary:
33 :
34 : ;; Advice is documented in the Emacs Lisp Manual.
35 :
36 : ;; @ Introduction:
37 : ;; ===============
38 : ;; This package implements a full-fledged Lisp-style advice mechanism
39 : ;; for Emacs Lisp. Advice is a clean and efficient way to modify the
40 : ;; behavior of Emacs Lisp functions without having to keep personal
41 : ;; modified copies of such functions around. A great number of such
42 : ;; modifications can be achieved by treating the original function as a
43 : ;; black box and specifying a different execution environment for it
44 : ;; with a piece of advice. Think of a piece of advice as a kind of fancy
45 : ;; hook that you can attach to any function/macro/subr.
46 :
47 : ;; @ Highlights:
48 : ;; =============
49 : ;; - Clean definition of multiple, named before/around/after advices
50 : ;; for functions and macros.
51 : ;; - Full control over the arguments an advised function will receive,
52 : ;; the binding environment in which it will be executed, as well as the
53 : ;; value it will return.
54 : ;; - Allows re/definition of interactive behavior for commands.
55 : ;; - Every piece of advice can have its documentation string.
56 : ;; - The execution of every piece of advice can be protected against error
57 : ;; and non-local exits in preceding code or advices.
58 : ;; - Simple argument access either by name, or, more portable but as
59 : ;; efficient, via access macros
60 : ;; - Allows the specification of a different argument list for the advised
61 : ;; version of a function.
62 : ;; - Advised functions can be byte-compiled either at file-compile time
63 : ;; (see preactivation) or activation time.
64 : ;; - Separation of advice definition and activation.
65 : ;; - Forward advice is possible, that is
66 : ;; as yet undefined or autoload functions can be advised without having to
67 : ;; preload the file in which they are defined.
68 : ;; - Forward redefinition is possible because around advice can be used to
69 : ;; completely redefine a function.
70 : ;; - A caching mechanism for advised definition provides for cheap deactivation
71 : ;; and reactivation of advised functions.
72 : ;; - Preactivation allows efficient construction and compilation of advised
73 : ;; definitions at file compile time without giving up the flexibility of
74 : ;; the advice mechanism.
75 : ;; - En/disablement mechanism allows the use of different "views" of advised
76 : ;; functions depending on what pieces of advice are currently en/disabled
77 : ;; - Provides manipulation mechanisms for sets of advised functions via
78 : ;; regular expressions that match advice names.
79 :
80 : ;; @ Overview, or how to read this file:
81 : ;; =====================================
82 : ;; You can use `outline-mode' to help you read this documentation (set
83 : ;; `outline-regexp' to `";; @+"').
84 : ;;
85 : ;; The four major sections of this file are:
86 : ;;
87 : ;; @ This initial information ...installation, customization etc.
88 : ;; @ Advice documentation: ...general documentation
89 : ;; @ Foo games: An advice tutorial ...teaches about Advice by example
90 : ;; @ Advice implementation: ...actual code, yeah!!
91 : ;;
92 : ;; The latter three are actual headings which you can search for
93 : ;; directly in case `outline-mode' doesn't work for you.
94 :
95 : ;; @ Restrictions:
96 : ;; ===============
97 : ;; - Advised functions/macros/subrs will only exhibit their advised behavior
98 : ;; when they are invoked via their function cell. This means that advice will
99 : ;; not work for the following:
100 : ;; + advised subrs that are called directly from other subrs or C-code
101 : ;; + advised subrs that got replaced with their byte-code during
102 : ;; byte-compilation (e.g., car)
103 : ;; + advised macros which were expanded during byte-compilation before
104 : ;; their advice was activated.
105 :
106 : ;; @ Credits:
107 : ;; ==========
108 : ;; This package is an extension and generalization of packages such as
109 : ;; insert-hooks.el written by Noah S. Friedman, and advise.el written by
110 : ;; Raul J. Acevedo. Some ideas used in here come from these packages,
111 : ;; others come from the various Lisp advice mechanisms I've come across
112 : ;; so far, and a few are simply mine.
113 :
114 : ;; @ Safety Rules and Emergency Exits:
115 : ;; ===================================
116 : ;; Before we begin: CAUTION!!
117 : ;; Advice provides you with a lot of rope to hang yourself on very
118 : ;; easily accessible trees, so, here are a few important things you
119 : ;; should know:
120 : ;;
121 : ;; If you experience any strange behavior/errors etc. that you attribute to
122 : ;; Advice or to some ill-advised function do one of the following:
123 :
124 : ;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what
125 : ;; function gives you problems)
126 : ;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong)
127 : ;; - M-x ad-recover-normality (for real emergencies)
128 : ;; - If none of the above solves your Advice-related problem go to another
129 : ;; terminal, kill your Emacs process and send me some hate mail.
130 :
131 : ;; The first two measures have restarts, i.e., once you've figured out
132 : ;; the problem you can reactivate advised functions with either `ad-activate',
133 : ;; or `ad-activate-all'. `ad-recover-normality' unadvises
134 : ;; everything so you won't be able to reactivate any advised functions, you'll
135 : ;; have to stick with their standard incarnations for the rest of the session.
136 :
137 : ;; RELAX: Advice is pretty safe even if you are oblivious to the above.
138 : ;; I use it extensively and haven't run into any serious trouble in a long
139 : ;; time. Just wanted you to be warned.
140 :
141 : ;; @ Customization:
142 : ;; ================
143 :
144 : ;; Look at the documentation of `ad-redefinition-action' for possible values
145 : ;; of this variable. Its default value is `warn' which will print a warning
146 : ;; message when an already defined advised function gets redefined with a
147 : ;; new original definition and de/activated.
148 :
149 : ;; Look at the documentation of `ad-default-compilation-action' for possible
150 : ;; values of this variable. Its default value is `maybe' which will compile
151 : ;; advised definitions during activation in case the byte-compiler is already
152 : ;; loaded. Otherwise, it will leave them uncompiled.
153 :
154 : ;; @ Motivation:
155 : ;; =============
156 : ;; Before I go on explaining how advice works, here are four simple examples
157 : ;; how this package can be used. The first three are very useful, the last one
158 : ;; is just a joke:
159 :
160 : ;;(defadvice switch-to-buffer (before existing-buffers-only activate)
161 : ;; "When called interactively switch to existing buffers only, unless
162 : ;;when called with a prefix argument."
163 : ;; (interactive
164 : ;; (list (read-buffer "Switch to buffer: " (other-buffer)
165 : ;; (null current-prefix-arg)))))
166 : ;;
167 : ;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate)
168 : ;; "Switch to non-existing buffers only upon confirmation."
169 : ;; (interactive "BSwitch to buffer: ")
170 : ;; (if (or (get-buffer (ad-get-arg 0))
171 : ;; (y-or-n-p (format-message "`%s' does not exist, create? "
172 : ;; (ad-get-arg 0))))
173 : ;; ad-do-it))
174 : ;;
175 : ;;(defadvice find-file (before existing-files-only activate)
176 : ;; "Find existing files only"
177 : ;; (interactive "fFind file: "))
178 : ;;
179 : ;;(defadvice car (around interactive activate)
180 : ;; "Make `car' an interactive function."
181 : ;; (interactive "xCar of list: ")
182 : ;; ad-do-it
183 : ;; (if (called-interactively-p 'interactive)
184 : ;; (message "%s" ad-return-value)))
185 :
186 :
187 : ;; @ Advice documentation:
188 : ;; =======================
189 : ;; Below is general documentation of the various features of advice. For more
190 : ;; concrete examples check the corresponding sections in the tutorial part.
191 :
192 : ;; @@ Terminology:
193 : ;; ===============
194 : ;; - Emacs: Emacs as released by the GNU Project
195 : ;; - Advice: The name of this package.
196 : ;; - advices: Short for "pieces of advice".
197 :
198 : ;; @@ Defining a piece of advice with `defadvice':
199 : ;; ===============================================
200 : ;; The main means of defining a piece of advice is the macro `defadvice',
201 : ;; there is no interactive way of specifying a piece of advice. A call to
202 : ;; `defadvice' has the following syntax which is similar to the syntax of
203 : ;; `defun/defmacro':
204 : ;;
205 : ;; (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*)
206 : ;; [ [<documentation-string>] [<interactive-form>] ]
207 : ;; {<body-form>}* )
208 :
209 : ;; <function> is the name of the function/macro/subr to be advised.
210 :
211 : ;; <class> is the class of the advice which has to be one of `before',
212 : ;; `around', `after', `activation' or `deactivation' (the last two allow
213 : ;; definition of special act/deactivation hooks).
214 :
215 : ;; <name> is the name of the advice which has to be a non-nil symbol.
216 : ;; Names uniquely identify a piece of advice in a certain advice class,
217 : ;; hence, advices can be redefined by defining an advice with the same class
218 : ;; and name. Advice names are global symbols, hence, the same name space
219 : ;; conventions used for function names should be applied.
220 :
221 : ;; An optional <position> specifies where in the current list of advices of
222 : ;; the specified <class> this new advice will be placed. <position> has to
223 : ;; be either `first', `last' or a number that specifies a zero-based
224 : ;; position (`first' is equivalent to 0). If no position is specified
225 : ;; `first' will be used as a default. If this call to `defadvice' redefines
226 : ;; an already existing advice (see above) then the position argument will
227 : ;; be ignored and the position of the already existing advice will be used.
228 :
229 : ;; An optional <arglist> which has to be a list can be used to define the
230 : ;; argument list of the advised function. This argument list should of
231 : ;; course be compatible with the argument list of the original function,
232 : ;; otherwise functions that call the advised function with the original
233 : ;; argument list in mind will break. If more than one advice specify an
234 : ;; argument list then the first one (the one with the smallest position)
235 : ;; found in the list of before/around/after advices will be used.
236 :
237 : ;; <flags> is a list of symbols that specify further information about the
238 : ;; advice. All flags can be specified with unambiguous initial substrings.
239 : ;; `activate': Specifies that the advice information of the advised
240 : ;; function should be activated right after this advice has been
241 : ;; defined. In forward advices `activate' will be ignored.
242 : ;; `protect': Specifies that this advice should be protected against
243 : ;; non-local exits and errors in preceding code/advices.
244 : ;; `compile': Specifies that the advised function should be byte-compiled.
245 : ;; This flag will be ignored unless `activate' is also specified.
246 : ;; `disable': Specifies that the defined advice should be disabled, hence,
247 : ;; it will not be used in an activation until somebody enables it.
248 : ;; `preactivate': Specifies that the advised function should get preactivated
249 : ;; at macro-expansion/compile time of this `defadvice'. This
250 : ;; generates a compiled advised definition according to the
251 : ;; current advice state which will be used during activation
252 : ;; if appropriate. Only use this if the `defadvice' gets
253 : ;; actually compiled.
254 :
255 : ;; An optional <documentation-string> can be supplied to document the advice.
256 : ;; On call of the `documentation' function it will be combined with the
257 : ;; documentation strings of the original function and other advices.
258 :
259 : ;; An optional <interactive-form> form can be supplied to change/add
260 : ;; interactive behavior of the original function. If more than one advice
261 : ;; has an `(interactive ...)' specification then the first one (the one
262 : ;; with the smallest position) found in the list of before/around/after
263 : ;; advices will be used.
264 :
265 : ;; A possibly empty list of <body-forms> specifies the body of the advice in
266 : ;; an implicit progn. The body of an advice can access/change arguments,
267 : ;; the return value, the binding environment, and can have all sorts of
268 : ;; other side effects.
269 :
270 : ;; @@ Assembling advised definitions:
271 : ;; ==================================
272 : ;; Suppose a function/macro/subr/special-form has N pieces of before advice,
273 : ;; M pieces of around advice and K pieces of after advice. Assuming none of
274 : ;; the advices is protected, its advised definition will look like this
275 : ;; (body-form indices correspond to the position of the respective advice in
276 : ;; that advice class):
277 :
278 : ;; ([macro] lambda <arglist>
279 : ;; [ [<advised-docstring>] [(interactive ...)] ]
280 : ;; (let (ad-return-value)
281 : ;; {<before-0-body-form>}*
282 : ;; ....
283 : ;; {<before-N-1-body-form>}*
284 : ;; {<around-0-body-form>}*
285 : ;; {<around-1-body-form>}*
286 : ;; ....
287 : ;; {<around-M-1-body-form>}*
288 : ;; (setq ad-return-value
289 : ;; <apply original definition to <arglist>>)
290 : ;; {<other-around-M-1-body-form>}*
291 : ;; ....
292 : ;; {<other-around-1-body-form>}*
293 : ;; {<other-around-0-body-form>}*
294 : ;; {<after-0-body-form>}*
295 : ;; ....
296 : ;; {<after-K-1-body-form>}*
297 : ;; ad-return-value))
298 :
299 : ;; Macros are redefined as macros, hence the optional [macro] in the
300 : ;; beginning of the definition.
301 :
302 : ;; <arglist> is either the argument list of the original function or the
303 : ;; first argument list defined in the list of before/around/after advices.
304 : ;; The values of <arglist> variables can be accessed/changed in the body of
305 : ;; an advice by simply referring to them by their original name, however,
306 : ;; more portable argument access macros are also provided (see below).
307 :
308 : ;; <advised-docstring> is an optional, special documentation string which will
309 : ;; be expanded into a proper documentation string upon call of `documentation'.
310 :
311 : ;; (interactive ...) is an optional interactive form either taken from the
312 : ;; original function or from a before/around/after advice. For advised
313 : ;; interactive subrs that do not have an interactive form specified in any
314 : ;; advice we have to use (interactive) and then call the subr interactively
315 : ;; if the advised function was called interactively, because the
316 : ;; interactive specification of subrs is not accessible. This is the only
317 : ;; case where changing the values of arguments will not have an affect
318 : ;; because they will be reset by the interactive specification of the subr.
319 : ;; If this is a problem one can always specify an interactive form in a
320 : ;; before/around/after advice to gain control over argument values that
321 : ;; were supplied interactively.
322 : ;;
323 : ;; Then the body forms of the various advices in the various classes of advice
324 : ;; are assembled in order. The forms of around advice L are normally part of
325 : ;; one of the forms of around advice L-1. An around advice can specify where
326 : ;; the forms of the wrapped or surrounded forms should go with the special
327 : ;; keyword `ad-do-it', which will run the forms of the surrounded code.
328 :
329 : ;; The innermost part of the around advice onion is
330 : ;; <apply original definition to <arglist>>
331 : ;; whose form depends on the type of the original function. The variable
332 : ;; `ad-return-value' will be set to its result. This variable is visible to
333 : ;; all pieces of advice which can access and modify it before it gets returned.
334 : ;;
335 : ;; The semantic structure of advised functions that contain protected pieces
336 : ;; of advice is the same. The only difference is that `unwind-protect' forms
337 : ;; make sure that the protected advice gets executed even if some previous
338 : ;; piece of advice had an error or a non-local exit. If any around advice is
339 : ;; protected then the whole around advice onion will be protected.
340 :
341 : ;; @@ Argument access in advised functions:
342 : ;; ========================================
343 : ;; As already mentioned, the simplest way to access the arguments of an
344 : ;; advised function in the body of an advice is to refer to them by name.
345 : ;; To do that, the advice programmer needs to know either the names of the
346 : ;; argument variables of the original function, or the names used in the
347 : ;; argument list redefinition given in a piece of advice. While this simple
348 : ;; method might be sufficient in many cases, it has the disadvantage that it
349 : ;; is not very portable because it hardcodes the argument names into the
350 : ;; advice. If the definition of the original function changes the advice
351 : ;; might break even though the code might still be correct. Situations like
352 : ;; that arise, for example, if one advises a subr like `eval-region' which
353 : ;; gets redefined in a non-advice style into a function by the edebug
354 : ;; package. If the advice assumes `eval-region' to be a subr it might break
355 : ;; once edebug is loaded. Similar situations arise when one wants to use the
356 : ;; same piece of advice across different versions of Emacs.
357 :
358 : ;; As a solution to that advice provides argument list access macros that get
359 : ;; translated into the proper access forms at activation time, i.e., when the
360 : ;; advised definition gets constructed. Access macros access actual arguments
361 : ;; by position regardless of how these actual argument get distributed onto
362 : ;; the argument variables of a function. The rational behind this is that in
363 : ;; Emacs Lisp the semantics of an argument is strictly determined by its
364 : ;; position (there are no keyword arguments).
365 :
366 : ;; Suppose the function `foo' is defined as
367 : ;;
368 : ;; (defun foo (x y &optional z &rest r) ....)
369 : ;;
370 : ;; and is then called with
371 : ;;
372 : ;; (foo 0 1 2 3 4 5 6)
373 :
374 : ;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that
375 : ;; the semantics of an actual argument is determined by its position. It is
376 : ;; this semantics that has to be known by the advice programmer. Then s/he
377 : ;; can access these arguments in a piece of advice with some of the
378 : ;; following macros (the arrows indicate what value they will return):
379 :
380 : ;; (ad-get-arg 0) -> 0
381 : ;; (ad-get-arg 1) -> 1
382 : ;; (ad-get-arg 2) -> 2
383 : ;; (ad-get-arg 3) -> 3
384 : ;; (ad-get-args 2) -> (2 3 4 5 6)
385 : ;; (ad-get-args 4) -> (4 5 6)
386 :
387 : ;; `(ad-get-arg <position>)' will return the actual argument that was supplied
388 : ;; at <position>, `(ad-get-args <position>)' will return the list of actual
389 : ;; arguments supplied starting at <position>. Note that these macros can be
390 : ;; used without any knowledge about the form of the actual argument list of
391 : ;; the original function.
392 :
393 : ;; Similarly, `(ad-set-arg <position> <value-form>)' can be used to set the
394 : ;; value of the actual argument at <position> to <value-form>. For example,
395 : ;;
396 : ;; (ad-set-arg 5 "five")
397 : ;;
398 : ;; will have the effect that R=(3 4 "five" 6) once the original function is
399 : ;; called. `(ad-set-args <position> <value-list-form>)' can be used to set
400 : ;; the list of actual arguments starting at <position> to <value-list-form>.
401 : ;; For example,
402 : ;;
403 : ;; (ad-set-args 0 '(5 4 3 2 1 0))
404 : ;;
405 : ;; will have the effect that X=5, Y=4, Z=3 and R=(2 1 0) once the original
406 : ;; function is called.
407 :
408 : ;; All these access macros are text macros rather than real Lisp macros. When
409 : ;; the advised definition gets constructed they get replaced with actual access
410 : ;; forms depending on the argument list of the advised function, i.e., after
411 : ;; that argument access is in most cases as efficient as using the argument
412 : ;; variable names directly.
413 :
414 : ;; @@@ Accessing argument bindings of arbitrary functions:
415 : ;; =======================================================
416 : ;; Some functions (such as `trace-function' defined in trace.el) need a
417 : ;; method of accessing the names and bindings of the arguments of an
418 : ;; arbitrary advised function. To do that within an advice one can use the
419 : ;; special keyword `ad-arg-bindings' which is a text macro that will be
420 : ;; substituted with a form that will evaluate to a list of binding
421 : ;; specifications, one for every argument variable. These binding
422 : ;; specifications can then be examined in the body of the advice. For
423 : ;; example, somewhere in an advice we could do this:
424 : ;;
425 : ;; (let* ((bindings ad-arg-bindings)
426 : ;; (firstarg (car bindings))
427 : ;; (secondarg (car (cdr bindings))))
428 : ;; ;; Print info about first argument
429 : ;; (print (format "%s=%s (%s)"
430 : ;; (ad-arg-binding-field firstarg 'name)
431 : ;; (ad-arg-binding-field firstarg 'value)
432 : ;; (ad-arg-binding-field firstarg 'type)))
433 : ;; ....)
434 : ;;
435 : ;; The `type' of an argument is either `required', `optional' or `rest'.
436 : ;; Wherever `ad-arg-bindings' appears a form will be inserted that evaluates
437 : ;; to the list of bindings, hence, in order to avoid multiple unnecessary
438 : ;; evaluations one should always bind it to some variable.
439 :
440 : ;; @@@ Argument list mapping:
441 : ;; ==========================
442 : ;; Because `defadvice' allows the specification of the argument list
443 : ;; of the advised function we need a mapping mechanism that maps this
444 : ;; argument list onto that of the original function. Hence SYM and
445 : ;; NEWDEF have to be properly mapped onto the &rest variable when the
446 : ;; original definition is called. Advice automatically takes care of
447 : ;; that mapping, hence, the advice programmer can specify an argument
448 : ;; list without having to know about the exact structure of the
449 : ;; original argument list as long as the new argument list takes a
450 : ;; compatible number/magnitude of actual arguments.
451 :
452 : ;; @@ Activation and deactivation:
453 : ;; ===============================
454 : ;; The definition of an advised function does not change until all its advice
455 : ;; gets actually activated. Activation can either happen with the `activate'
456 : ;; flag specified in the `defadvice', with an explicit call or interactive
457 : ;; invocation of `ad-activate', or at the time an already advised function
458 : ;; gets defined.
459 :
460 : ;; When a function gets first activated its original definition gets saved,
461 : ;; all defined and enabled pieces of advice will get combined with the
462 : ;; original definition, the resulting definition might get compiled depending
463 : ;; on some conditions described below, and then the function will get
464 : ;; redefined with the advised definition. This also means that undefined
465 : ;; functions cannot get activated even though they might be already advised.
466 :
467 : ;; The advised definition will get compiled either if `ad-activate' was called
468 : ;; interactively with a prefix argument, or called explicitly with its second
469 : ;; argument as t, or, if `ad-default-compilation-action' justifies it according
470 : ;; to the current system state. If the advised definition was
471 : ;; constructed during "preactivation" (see below) then that definition will
472 : ;; be already compiled because it was constructed during byte-compilation of
473 : ;; the file that contained the `defadvice' with the `preactivate' flag.
474 :
475 : ;; `ad-deactivate' can be used to back-define an advised function to its
476 : ;; original definition. It can be called interactively or directly. Because
477 : ;; `ad-activate' caches the advised definition the function can be
478 : ;; reactivated via `ad-activate' with only minor overhead (it is checked
479 : ;; whether the current advice state is consistent with the cached
480 : ;; definition, see the section on caching below).
481 :
482 : ;; `ad-activate-regexp' and `ad-deactivate-regexp' can be used to de/activate
483 : ;; all currently advised function that have a piece of advice with a name that
484 : ;; contains a match for a regular expression. These functions can be used to
485 : ;; de/activate sets of functions depending on certain advice naming
486 : ;; conventions.
487 :
488 : ;; Finally, `ad-activate-all' and `ad-deactivate-all' can be used to
489 : ;; de/activate all currently advised functions. These are useful to
490 : ;; (temporarily) return to an un/advised state.
491 :
492 : ;; @@@ Reasons for the separation of advice definition and activation:
493 : ;; ===================================================================
494 : ;; As already mentioned, advising happens in two stages:
495 :
496 : ;; 1) definition of various pieces of advice
497 : ;; 2) activation of all advice currently defined and enabled
498 :
499 : ;; The advantage of this is that various pieces of advice can be defined
500 : ;; before they get combined into an advised definition which avoids
501 : ;; unnecessary constructions of intermediate advised definitions. The more
502 : ;; important advantage is that it allows the implementation of forward advice.
503 : ;; Advice information for a certain function accumulates as the value of the
504 : ;; `advice-info' property of the function symbol. This accumulation is
505 : ;; completely independent of the fact that that function might not yet be
506 : ;; defined. The macros `defun' and `defmacro' check whether the
507 : ;; function/macro they defined had advice information
508 : ;; associated with it. If so and forward advice is enabled, the original
509 : ;; definition will be saved, and then the advice will be activated.
510 :
511 : ;; @@ Enabling/disabling pieces or sets of advice:
512 : ;; ===============================================
513 : ;; A major motivation for the development of this advice package was to bring
514 : ;; a little bit more structure into the function overloading chaos in Emacs
515 : ;; Lisp. Many packages achieve some of their functionality by adding a little
516 : ;; bit (or a lot) to the standard functionality of some Emacs Lisp function.
517 : ;; ange-ftp is a very popular package that used to achieve its magic by
518 : ;; overloading most Emacs Lisp functions that deal with files. A popular
519 : ;; function that's overloaded by many packages is `expand-file-name'.
520 : ;; The situation that one function is multiply overloaded can arise easily.
521 :
522 : ;; Once in a while it would be desirable to be able to disable some/all
523 : ;; overloads of a particular package while keeping all the rest. Ideally -
524 : ;; at least in my opinion - these overloads would all be done with advice,
525 : ;; I know I am dreaming right now... In that ideal case the enable/disable
526 : ;; mechanism of advice could be used to achieve just that.
527 :
528 : ;; Every piece of advice is associated with an enablement flag. When the
529 : ;; advised definition of a particular function gets constructed (e.g., during
530 : ;; activation) only the currently enabled pieces of advice will be considered.
531 : ;; This mechanism allows one to have different "views" of an advised function
532 : ;; dependent on what pieces of advice are currently enabled.
533 :
534 : ;; Another motivation for this mechanism is that it allows one to define a
535 : ;; piece of advice for some function yet keep it dormant until a certain
536 : ;; condition is met. Until then activation of the function will not make use
537 : ;; of that piece of advice. Once the condition is met the advice can be
538 : ;; enabled and a reactivation of the function will add its functionality as
539 : ;; part of the new advised definition. Hence, if somebody
540 : ;; else advised these functions too and activates them the advices defined
541 : ;; by advice will get used only if they are intended to be used.
542 :
543 : ;; The main interface to this mechanism are the interactive functions
544 : ;; `ad-enable-advice' and `ad-disable-advice'. For example, the following
545 : ;; would disable a particular advice of the function `foo':
546 : ;;
547 : ;; (ad-disable-advice 'foo 'before 'my-advice)
548 : ;;
549 : ;; This call by itself only changes the flag, to get the proper effect in
550 : ;; the advised definition too one has to activate `foo' with
551 : ;;
552 : ;; (ad-activate 'foo)
553 : ;;
554 : ;; or interactively. To disable whole sets of advices one can use a regular
555 : ;; expression mechanism. For example, let us assume that ange-ftp actually
556 : ;; used advice to overload all its functions, and that it used the
557 : ;; "ange-ftp-" prefix for all its advice names, then we could temporarily
558 : ;; disable all its advices with
559 : ;;
560 : ;; (ad-disable-regexp "\\`ange-ftp-")
561 : ;;
562 : ;; and the following call would put that actually into effect:
563 : ;;
564 : ;; (ad-activate-regexp "\\`ange-ftp-")
565 : ;;
566 : ;; A safer way would have been to use
567 : ;;
568 : ;; (ad-update-regexp "\\`ange-ftp-")
569 : ;;
570 : ;; instead which would have only reactivated currently actively advised
571 : ;; functions, but not functions that were currently inactive. All these
572 : ;; functions can also be called interactively.
573 :
574 : ;; A certain piece of advice is considered a match if its name contains a
575 : ;; match for the regular expression. To enable ange-ftp again we would use
576 : ;; `ad-enable-regexp' and then activate or update again.
577 :
578 : ;; @@ Forward advice, automatic advice activation:
579 : ;; ===============================================
580 : ;; Because most Emacs Lisp packages are loaded on demand via an autoload
581 : ;; mechanism it is essential to be able to "forward advise" functions.
582 : ;; Otherwise, proper advice definition and activation would make it necessary
583 : ;; to preload every file that defines a certain function before it can be
584 : ;; advised, which would partly defeat the purpose of the advice mechanism.
585 :
586 : ;; In the following, "forward advice" always implies its automatic activation
587 : ;; once a function gets defined, and not just the accumulation of advice
588 : ;; information for a possibly undefined function.
589 :
590 : ;; Advice implements forward advice mainly via the following: 1) Separation
591 : ;; of advice definition and activation that makes it possible to accumulate
592 : ;; advice information without having the original function already defined,
593 : ;; 2) Use of the `defalias-fset-function' symbol property which lets
594 : ;; us advise the function when it gets defined.
595 :
596 : ;; Automatic advice activation means, that whenever a function gets defined
597 : ;; with either `defun', `defmacro', `defalias' or by loading a byte-compiled
598 : ;; file, and the function has some advice-info stored with it then that
599 : ;; advice will get activated right away.
600 :
601 : ;; @@ Caching of advised definitions:
602 : ;; ==================================
603 : ;; After an advised definition got constructed it gets cached as part of the
604 : ;; advised function's advice-info so it can be reused, for example, after an
605 : ;; intermediate deactivation. Because the advice-info of a function might
606 : ;; change between the time of caching and reuse a cached definition gets
607 : ;; a cache-id associated with it so it can be verified whether the cached
608 : ;; definition is still valid (the main application of this is preactivation
609 : ;; - see below).
610 :
611 : ;; When an advised function gets activated and a verifiable cached definition
612 : ;; is available, then that definition will be used instead of creating a new
613 : ;; advised definition from scratch. If you want to make sure that a new
614 : ;; definition gets constructed then you should use `ad-clear-cache' before you
615 : ;; activate the advised function.
616 :
617 : ;; @@ Preactivation:
618 : ;; =================
619 : ;; Constructing an advised definition is moderately expensive. In a situation
620 : ;; where one package defines a lot of advised functions it might be
621 : ;; prohibitively expensive to do all the advised definition construction at
622 : ;; runtime. Preactivation is a mechanism that allows compile-time construction
623 : ;; of compiled advised definitions that can be activated cheaply during
624 : ;; runtime. Preactivation uses the caching mechanism to do that. Here's how
625 : ;; it works:
626 :
627 : ;; When the byte-compiler compiles a `defadvice' that has the `preactivate'
628 : ;; flag specified, it uses the current original definition of the advised
629 : ;; function plus the advice specified in this `defadvice' (even if it is
630 : ;; specified as disabled) and all other currently enabled pieces of advice to
631 : ;; construct an advised definition and an identifying cache-id and makes them
632 : ;; part of the `defadvice' expansion which will then be compiled by the
633 : ;; byte-compiler.
634 : ;; When the file with the compiled, preactivating `defadvice' gets loaded the
635 : ;; precompiled advised definition will be cached on the advised function's
636 : ;; advice-info. When it gets activated (can be immediately on execution of the
637 : ;; `defadvice' or any time later) the cache-id gets checked against the
638 : ;; current state of advice and if it is verified the precompiled definition
639 : ;; will be used directly (the verification is pretty cheap). If it couldn't
640 : ;; get verified a new advised definition for that function will be built from
641 : ;; scratch, hence, the efficiency added by the preactivation mechanism does not
642 : ;; at all impair the flexibility of the advice mechanism.
643 :
644 : ;; MORAL: In order get all the efficiency out of preactivation the advice
645 : ;; state of an advised function at the time the file with the
646 : ;; preactivating `defadvice' gets byte-compiled should be exactly
647 : ;; the same as it will be when the advice of that function gets
648 : ;; actually activated. If it is not there is a high chance that the
649 : ;; cache-id will not match and hence a new advised definition will
650 : ;; have to be constructed at runtime.
651 :
652 : ;; Preactivation and forward advice do not contradict each other. It is
653 : ;; perfectly ok to load a file with a preactivating `defadvice' before the
654 : ;; original definition of the advised function is available. The constructed
655 : ;; advised definition will be used once the original function gets defined and
656 : ;; its advice gets activated. The only constraint is that at the time the
657 : ;; file with the preactivating `defadvice' got compiled the original function
658 : ;; definition was available.
659 :
660 : ;; TIPS: Here are some indications that a preactivation did not work the way
661 : ;; you intended it to work:
662 : ;; - Activation of the advised function takes longer than usual/expected
663 : ;; - The byte-compiler gets loaded while an advised function gets
664 : ;; activated
665 : ;; - `byte-compile' is part of the `features' variable even though you
666 : ;; did not use the byte-compiler
667 : ;; Right now advice does not provide an elegant way to find out whether
668 : ;; and why a preactivation failed. What you can do is to trace the
669 : ;; function `ad-cache-id-verification-code' (with the function
670 : ;; `trace-function-background' defined in my trace.el package) before
671 : ;; any of your advised functions get activated. After they got
672 : ;; activated check whether all calls to `ad-cache-id-verification-code'
673 : ;; returned `verified' as a result. Other values indicate why the
674 : ;; verification failed which should give you enough information to
675 : ;; fix your preactivation/compile/load/activation sequence.
676 :
677 : ;; IMPORTANT: There is one case (that I am aware of) that can make
678 : ;; preactivation fail, i.e., a preconstructed advised definition that does
679 : ;; NOT match the current state of advice gets used nevertheless. That case
680 : ;; arises if one package defines a certain piece of advice which gets used
681 : ;; during preactivation, and another package incompatibly redefines that
682 : ;; very advice (i.e., same function/class/name), and it is the second advice
683 : ;; that is available when the preconstructed definition gets activated, and
684 : ;; that was the only definition of that advice so far (`ad-add-advice'
685 : ;; catches advice redefinitions and clears the cache in such a case).
686 : ;; Catching that would make the cache verification too expensive.
687 :
688 : ;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with
689 : ;; George Walker Bush), and why would you redefine your own advice anyway?
690 : ;; Advice is a mechanism to facilitate function redefinition, not advice
691 : ;; redefinition (wait until I write Meta-Advice :-). If you really have
692 : ;; to undo somebody else's advice, try to write a "neutralizing" advice.
693 :
694 : ;; @@ Advising macros and other dangerous things:
695 : ;; ==============================================
696 : ;; Look at the corresponding tutorial sections for more information on
697 : ;; these topics. Here it suffices to point out that the special treatment
698 : ;; of macros can lead to problems when they get advised. Macros can create
699 : ;; problems because they get expanded at compile or load time, hence, they
700 : ;; might not have all the necessary runtime support and such advice cannot be
701 : ;; de/activated or changed as it is possible for functions.
702 : ;;
703 : ;; Special forms cannot be advised.
704 : ;;
705 : ;; MORAL: - Only advise macros when you are absolutely sure what you are doing.
706 :
707 : ;; @@ Adding a piece of advice with `ad-add-advice':
708 : ;; =================================================
709 : ;; The non-interactive function `ad-add-advice' can be used to add a piece of
710 : ;; advice to some function without using `defadvice'. This is useful if advice
711 : ;; has to be added somewhere by a function (also look at `ad-make-advice').
712 :
713 : ;; @@ Activation/deactivation advices, file load hooks:
714 : ;; ====================================================
715 : ;; There are two special classes of advice called `activation' and
716 : ;; `deactivation'. The body forms of these advices are not included into the
717 : ;; advised definition of a function, rather they are assembled into a hook
718 : ;; form which will be evaluated whenever the advice-info of the advised
719 : ;; function gets activated or deactivated. One application of this mechanism
720 : ;; is to define file load hooks for files that do not provide such hooks.
721 : ;; For example, suppose you want to print a message whenever `file-x' gets
722 : ;; loaded, and suppose the last function defined in `file-x' is
723 : ;; `file-x-last-fn'. Then we can define the following advice:
724 : ;;
725 : ;; (defadvice file-x-last-fn (activation file-x-load-hook)
726 : ;; "Executed whenever file-x is loaded"
727 : ;; (if load-in-progress (message "Loaded file-x")))
728 : ;;
729 : ;; This will constitute a forward advice for function `file-x-last-fn' which
730 : ;; will get activated when `file-x' is loaded (only if forward advice is
731 : ;; enabled of course). Because there are no "real" pieces of advice
732 : ;; available for it, its definition will not be changed, but the activation
733 : ;; advice will be run during its activation which is equivalent to having a
734 : ;; file load hook for `file-x'.
735 :
736 : ;; @@ Summary of main advice concepts:
737 : ;; ===================================
738 : ;; - Definition:
739 : ;; A piece of advice gets defined with `defadvice' and added to the
740 : ;; `advice-info' property of a function.
741 : ;; - Enablement:
742 : ;; Every piece of advice has an enablement flag associated with it. Only
743 : ;; enabled advices are considered during construction of an advised
744 : ;; definition.
745 : ;; - Activation:
746 : ;; Redefine an advised function with its advised definition. Constructs
747 : ;; an advised definition from scratch if no verifiable cached advised
748 : ;; definition is available and caches it.
749 : ;; - Deactivation:
750 : ;; Back-define an advised function to its original definition.
751 : ;; - Update:
752 : ;; Reactivate an advised function but only if its advice is currently
753 : ;; active. This can be used to bring all currently advised function up
754 : ;; to date with the current state of advice without also activating
755 : ;; currently inactive functions.
756 : ;; - Caching:
757 : ;; Is the saving of an advised definition and an identifying cache-id so
758 : ;; it can be reused, for example, for activation after deactivation.
759 : ;; - Preactivation:
760 : ;; Is the construction of an advised definition according to the current
761 : ;; state of advice during byte-compilation of a file with a preactivating
762 : ;; `defadvice'. That advised definition can then rather cheaply be used
763 : ;; during activation without having to construct an advised definition
764 : ;; from scratch at runtime.
765 :
766 : ;; @@ Summary of interactive advice manipulation functions:
767 : ;; ========================================================
768 : ;; The following interactive functions can be used to manipulate the state
769 : ;; of advised functions (all of them support completion on function names,
770 : ;; advice classes and advice names):
771 :
772 : ;; - ad-activate to activate the advice of a FUNCTION
773 : ;; - ad-deactivate to deactivate the advice of a FUNCTION
774 : ;; - ad-update to activate the advice of a FUNCTION unless it was not
775 : ;; yet activated or is currently inactive.
776 : ;; - ad-unadvise deactivates a FUNCTION and removes all of its advice
777 : ;; information, hence, it cannot be activated again
778 : ;; - ad-recover tries to redefine a FUNCTION to its original definition and
779 : ;; discards all advice information (a low-level `ad-unadvise').
780 : ;; Use only in emergencies.
781 :
782 : ;; - ad-remove-advice removes a particular piece of advice of a FUNCTION.
783 : ;; You still have to do call `ad-activate' or `ad-update' to
784 : ;; activate the new state of advice.
785 : ;; - ad-enable-advice enables a particular piece of advice of a FUNCTION.
786 : ;; - ad-disable-advice disables a particular piece of advice of a FUNCTION.
787 : ;; - ad-enable-regexp maps over all currently advised functions and enables
788 : ;; every advice whose name contains a match for a regular
789 : ;; expression.
790 : ;; - ad-disable-regexp disables matching advices.
791 :
792 : ;; - ad-activate-regexp activates all advised function with a matching advice
793 : ;; - ad-deactivate-regexp deactivates all advised function with matching advice
794 : ;; - ad-update-regexp updates all advised function with a matching advice
795 : ;; - ad-activate-all activates all advised functions
796 : ;; - ad-deactivate-all deactivates all advised functions
797 : ;; - ad-update-all updates all advised functions
798 : ;; - ad-unadvise-all unadvises all advised functions
799 : ;; - ad-recover-all recovers all advised functions
800 :
801 : ;; - ad-compile byte-compiles a function/macro if it is compilable.
802 :
803 : ;; @@ Summary of forms with special meanings when used within an advice:
804 : ;; =====================================================================
805 : ;; ad-return-value name of the return value variable (get/settable)
806 : ;; (ad-get-arg <pos>), (ad-get-args <pos>),
807 : ;; (ad-set-arg <pos> <value>), (ad-set-args <pos> <value-list>)
808 : ;; argument access text macros to get/set the values of
809 : ;; actual arguments at a certain position
810 : ;; ad-arg-bindings text macro that returns the actual names, values
811 : ;; and types of the arguments as a list of bindings. The
812 : ;; order of the bindings corresponds to the order of the
813 : ;; arguments. The individual fields of every binding (name,
814 : ;; value and type) can be accessed with the function
815 : ;; `ad-arg-binding-field' (see example above).
816 : ;; ad-do-it text macro that identifies the place where the original
817 : ;; or wrapped definition should go in an around advice
818 :
819 :
820 : ;; @ Foo games: An advice tutorial
821 : ;; ===============================
822 : ;; The following tutorial was created in Emacs 18.59. Left-justified
823 : ;; s-expressions are input forms followed by one or more result forms.
824 : ;;
825 : ;; We start by defining an innocent looking function `foo' that simply
826 : ;; adds 1 to its argument X:
827 : ;;
828 : ;; (defun foo (x)
829 : ;; "Add 1 to X."
830 : ;; (1+ x))
831 : ;; foo
832 : ;;
833 : ;; (foo 3)
834 : ;; 4
835 : ;;
836 : ;; @@ Defining a simple piece of advice:
837 : ;; =====================================
838 : ;; Now let's define the first piece of advice for `foo'. To do that we
839 : ;; use the macro `defadvice' which takes a function name, a list of advice
840 : ;; specifiers and a list of body forms as arguments. The first element of
841 : ;; the advice specifiers is the class of the advice, the second is its name,
842 : ;; the third its position and the rest are some flags. The class of our
843 : ;; first advice is `before', its name is `fg-add2', its position among the
844 : ;; currently defined before advices (none so far) is `first', and the advice
845 : ;; will be `activate'ed immediately. Advice names are global symbols, hence,
846 : ;; the name space conventions used for function names should be applied. All
847 : ;; advice names in this tutorial will be prefixed with `fg' for `Foo Games'
848 : ;; (because everybody has the right to be inconsistent all the function names
849 : ;; used in this tutorial do NOT follow this convention).
850 : ;;
851 : ;; In the body of an advice we can refer to the argument variables of the
852 : ;; original function by name. Here we add 1 to X so the effect of calling
853 : ;; `foo' will be to actually add 2. All of the advice definitions below only
854 : ;; have one body form for simplicity, but there is no restriction to that
855 : ;; extent. Every piece of advice can have a documentation string which will
856 : ;; be combined with the documentation of the original function.
857 : ;;
858 : ;; (defadvice foo (before fg-add2 first activate)
859 : ;; "Add 2 to X."
860 : ;; (setq x (1+ x)))
861 : ;; foo
862 : ;;
863 : ;; (foo 3)
864 : ;; 5
865 : ;;
866 : ;; @@ Specifying the position of an advice:
867 : ;; ========================================
868 : ;; Now we define the second before advice which will cancel the effect of
869 : ;; the previous advice. This time we specify the position as 0 which is
870 : ;; equivalent to `first'. A number can be used to specify the zero-based
871 : ;; position of an advice among the list of advices in the same class. This
872 : ;; time we already have one before advice hence the position specification
873 : ;; actually has an effect. So, after the following definition the position
874 : ;; of the previous advice will be 1 even though we specified it with `first'
875 : ;; above, the reason for this is that the position argument is relative to
876 : ;; the currently defined pieces of advice which by now has changed.
877 : ;;
878 : ;; (defadvice foo (before fg-cancel-add2 0 activate)
879 : ;; "Again only add 1 to X."
880 : ;; (setq x (1- x)))
881 : ;; foo
882 : ;;
883 : ;; (foo 3)
884 : ;; 4
885 : ;;
886 : ;; @@ Redefining a piece of advice:
887 : ;; ================================
888 : ;; Now we define an advice with the same class and same name but with a
889 : ;; different position. Defining an advice in a class in which an advice with
890 : ;; that name already exists is interpreted as a redefinition of that
891 : ;; particular advice, in which case the position argument will be ignored
892 : ;; and the previous position of the redefined piece of advice is used.
893 : ;; Advice flags can be specified with non-ambiguous initial substrings, hence,
894 : ;; from now on we'll use `act' instead of the verbose `activate'.
895 : ;;
896 : ;; (defadvice foo (before fg-cancel-add2 last act)
897 : ;; "Again only add 1 to X."
898 : ;; (setq x (1- x)))
899 : ;; foo
900 : ;;
901 : ;; @@ Assembly of advised documentation:
902 : ;; =====================================
903 : ;; The documentation strings of the various pieces of advice are assembled
904 : ;; in order which shows that advice `fg-cancel-add2' is still the first
905 : ;; `before' advice even though we specified position `last' above:
906 : ;;
907 : ;; (documentation 'foo)
908 : ;; "Add 1 to X.
909 : ;;
910 : ;; This function is advised with the following advice(s):
911 : ;;
912 : ;; fg-cancel-add2 (before):
913 : ;; Again only add 1 to X.
914 : ;;
915 : ;; fg-add2 (before):
916 : ;; Add 2 to X."
917 : ;;
918 : ;; @@ Advising interactive behavior:
919 : ;; =================================
920 : ;; We can make a function interactive (or change its interactive behavior)
921 : ;; by specifying an interactive form in one of the before or around
922 : ;; advices (there could also be body forms in this advice). The particular
923 : ;; definition always assigns 5 as an argument to X which gives us 6 as a
924 : ;; result when we call foo interactively:
925 : ;;
926 : ;; (defadvice foo (before fg-inter last act)
927 : ;; "Use 5 as argument when called interactively."
928 : ;; (interactive (list 5)))
929 : ;; foo
930 : ;;
931 : ;; (call-interactively 'foo)
932 : ;; 6
933 : ;;
934 : ;; If more than one advice have an interactive declaration, then the one of
935 : ;; the advice with the smallest position will be used (before advices go
936 : ;; before around and after advices), hence, the declaration below does
937 : ;; not have any effect:
938 : ;;
939 : ;; (defadvice foo (before fg-inter2 last act)
940 : ;; (interactive (list 6)))
941 : ;; foo
942 : ;;
943 : ;; (call-interactively 'foo)
944 : ;; 6
945 : ;;
946 : ;; @@ Around advices:
947 : ;; ==================
948 : ;; Now we'll try some `around' advices. An around advice is a wrapper around
949 : ;; the original definition. It can shadow or establish bindings for the
950 : ;; original definition, and it can look at and manipulate the value returned
951 : ;; by the original function. The position of the special keyword `ad-do-it'
952 : ;; specifies where the code of the original function will be executed. The
953 : ;; keyword can appear multiple times which will result in multiple calls of
954 : ;; the original function in the resulting advised code. Note, that if we don't
955 : ;; specify a position argument (i.e., `first', `last' or a number), then
956 : ;; `first' (or 0) is the default):
957 : ;;
958 : ;; (defadvice foo (around fg-times-2 act)
959 : ;; "First double X."
960 : ;; (let ((x (* x 2)))
961 : ;; ad-do-it))
962 : ;; foo
963 : ;;
964 : ;; (foo 3)
965 : ;; 7
966 : ;;
967 : ;; Around advices are assembled like onion skins where the around advice
968 : ;; with position 0 is the outermost skin and the advice at the last position
969 : ;; is the innermost skin which is directly wrapped around the call of the
970 : ;; original definition of the function. Hence, after the next `defadvice' we
971 : ;; will first multiply X by 2 then add 1 and then call the original
972 : ;; definition (i.e., add 1 again):
973 : ;;
974 : ;; (defadvice foo (around fg-add-1 last act)
975 : ;; "Add 1 to X."
976 : ;; (let ((x (1+ x)))
977 : ;; ad-do-it))
978 : ;; foo
979 : ;;
980 : ;; (foo 3)
981 : ;; 8
982 : ;;
983 : ;; @@ Controlling advice activation:
984 : ;; =================================
985 : ;; In every `defadvice' so far we have used the flag `activate' to activate
986 : ;; the advice immediately after its definition, and that's what we want in
987 : ;; most cases. However, if we define multiple pieces of advice for a single
988 : ;; function then activating every advice immediately is inefficient. A
989 : ;; better way to do this is to only activate the last defined advice.
990 : ;; For example:
991 : ;;
992 : ;; (defadvice foo (after fg-times-x)
993 : ;; "Multiply the result with X."
994 : ;; (setq ad-return-value (* ad-return-value x)))
995 : ;; foo
996 : ;;
997 : ;; This still yields the same result as before:
998 : ;; (foo 3)
999 : ;; 8
1000 : ;;
1001 : ;; Now we define another advice and activate which will also activate the
1002 : ;; previous advice `fg-times-x'. Note the use of the special variable
1003 : ;; `ad-return-value' in the body of the advice which is set to the result of
1004 : ;; the original function. If we change its value then the value returned by
1005 : ;; the advised function will be changed accordingly:
1006 : ;;
1007 : ;; (defadvice foo (after fg-times-x-again act)
1008 : ;; "Again multiply the result with X."
1009 : ;; (setq ad-return-value (* ad-return-value x)))
1010 : ;; foo
1011 : ;;
1012 : ;; Now the advices have an effect:
1013 : ;;
1014 : ;; (foo 3)
1015 : ;; 72
1016 : ;;
1017 : ;; @@ Protecting advice execution:
1018 : ;; ===============================
1019 : ;; Once in a while we define an advice to perform some cleanup action,
1020 : ;; for example:
1021 : ;;
1022 : ;; (defadvice foo (after fg-cleanup last act)
1023 : ;; "Do some cleanup."
1024 : ;; (print "Let's clean up now!"))
1025 : ;; foo
1026 : ;;
1027 : ;; However, in case of an error the cleanup won't be performed:
1028 : ;;
1029 : ;; (condition-case error
1030 : ;; (foo t)
1031 : ;; (error 'error-in-foo))
1032 : ;; error-in-foo
1033 : ;;
1034 : ;; To make sure a certain piece of advice gets executed even if some error or
1035 : ;; non-local exit occurred in any preceding code, we can protect it by using
1036 : ;; the `protect' keyword. (if any of the around advices is protected then the
1037 : ;; whole around advice onion will be protected):
1038 : ;;
1039 : ;; (defadvice foo (after fg-cleanup prot act)
1040 : ;; "Do some protected cleanup."
1041 : ;; (print "Let's clean up now!"))
1042 : ;; foo
1043 : ;;
1044 : ;; Now the cleanup form will be executed even in case of an error:
1045 : ;;
1046 : ;; (condition-case error
1047 : ;; (foo t)
1048 : ;; (error 'error-in-foo))
1049 : ;; "Let's clean up now!"
1050 : ;; error-in-foo
1051 : ;;
1052 : ;; @@ Compilation of advised definitions:
1053 : ;; ======================================
1054 : ;; Finally, we can specify the `compile' keyword in a `defadvice' to say
1055 : ;; that we want the resulting advised function to be byte-compiled
1056 : ;; (`compile' will be ignored unless we also specified `activate'):
1057 : ;;
1058 : ;; (defadvice foo (after fg-cleanup prot act comp)
1059 : ;; "Do some protected cleanup."
1060 : ;; (print "Let's clean up now!"))
1061 : ;; foo
1062 : ;;
1063 : ;; Now `foo's advice is byte-compiled:
1064 : ;;
1065 : ;; (byte-code-function-p 'ad-Advice-foo)
1066 : ;; t
1067 : ;;
1068 : ;; (foo 3)
1069 : ;; "Let's clean up now!"
1070 : ;; 72
1071 : ;;
1072 : ;; @@ Enabling and disabling pieces of advice:
1073 : ;; ===========================================
1074 : ;; Once in a while it is desirable to temporarily disable a piece of advice
1075 : ;; so that it won't be considered during activation, for example, if two
1076 : ;; different packages advise the same function and one wants to temporarily
1077 : ;; neutralize the effect of the advice of one of the packages.
1078 : ;;
1079 : ;; The following disables the after advice `fg-times-x' in the function `foo'.
1080 : ;; All that does is to change a flag for this particular advice. All the
1081 : ;; other information defining it will be left unchanged (e.g., its relative
1082 : ;; position in this advice class, etc.).
1083 : ;;
1084 : ;; (ad-disable-advice 'foo 'after 'fg-times-x)
1085 : ;; nil
1086 : ;;
1087 : ;; For this to have an effect we have to activate `foo':
1088 : ;;
1089 : ;; (ad-activate 'foo)
1090 : ;; foo
1091 : ;;
1092 : ;; (foo 3)
1093 : ;; "Let's clean up now!"
1094 : ;; 24
1095 : ;;
1096 : ;; If we want to disable all multiplication advices in `foo' we can use a
1097 : ;; regular expression that matches the names of such advices. Actually, any
1098 : ;; advice name that contains a match for the regular expression will be
1099 : ;; called a match. A special advice class `any' can be used to consider
1100 : ;; all advice classes:
1101 : ;;
1102 : ;; (ad-disable-advice 'foo 'any "^fg-.*times")
1103 : ;; nil
1104 : ;;
1105 : ;; (ad-activate 'foo)
1106 : ;; foo
1107 : ;;
1108 : ;; (foo 3)
1109 : ;; "Let's clean up now!"
1110 : ;; 5
1111 : ;;
1112 : ;; To enable the disabled advice we could use either `ad-enable-advice'
1113 : ;; similar to `ad-disable-advice', or as an alternative `ad-enable-regexp'
1114 : ;; which will enable matching advices in ALL currently advised functions.
1115 : ;; Hence, this can be used to dis/enable advices made by a particular
1116 : ;; package to a set of functions as long as that package obeys standard
1117 : ;; advice name conventions. We prefixed all advice names with `fg-', hence
1118 : ;; the following will do the trick (`ad-enable-regexp' returns the number
1119 : ;; of matched advices):
1120 : ;;
1121 : ;; (ad-enable-regexp "^fg-")
1122 : ;; 9
1123 : ;;
1124 : ;; The following will activate all currently active advised functions that
1125 : ;; contain some advice matched by the regular expression. This is a save
1126 : ;; way to update the activation of advised functions whose advice changed
1127 : ;; in some way or other without accidentally also activating currently
1128 : ;; inactive functions:
1129 : ;;
1130 : ;; (ad-update-regexp "^fg-")
1131 : ;; nil
1132 : ;;
1133 : ;; (foo 3)
1134 : ;; "Let's clean up now!"
1135 : ;; 72
1136 : ;;
1137 : ;; Another use for the dis/enablement mechanism is to define a piece of advice
1138 : ;; and keep it "dormant" until a particular condition is satisfied, i.e., until
1139 : ;; then the advice will not be used during activation. The `disable' flag lets
1140 : ;; one do that with `defadvice':
1141 : ;;
1142 : ;; (defadvice foo (before fg-1-more dis)
1143 : ;; "Add yet 1 more."
1144 : ;; (setq x (1+ x)))
1145 : ;; foo
1146 : ;;
1147 : ;; (ad-activate 'foo)
1148 : ;; foo
1149 : ;;
1150 : ;; (foo 3)
1151 : ;; "Let's clean up now!"
1152 : ;; 72
1153 : ;;
1154 : ;; (ad-enable-advice 'foo 'before 'fg-1-more)
1155 : ;; nil
1156 : ;;
1157 : ;; (ad-activate 'foo)
1158 : ;; foo
1159 : ;;
1160 : ;; (foo 3)
1161 : ;; "Let's clean up now!"
1162 : ;; 160
1163 : ;;
1164 : ;; @@ Caching:
1165 : ;; ===========
1166 : ;; Advised definitions get cached to allow efficient activation/deactivation
1167 : ;; without having to reconstruct them if nothing in the advice-info of a
1168 : ;; function has changed. The following idiom can be used to temporarily
1169 : ;; deactivate functions that have a piece of advice defined by a certain
1170 : ;; package (we save the old definition to check out caching):
1171 : ;;
1172 : ;; (setq old-definition (symbol-function 'ad-Advice-foo))
1173 : ;; (lambda (x) ....)
1174 : ;;
1175 : ;; (ad-deactivate-regexp "^fg-")
1176 : ;; nil
1177 : ;;
1178 : ;; (foo 3)
1179 : ;; 4
1180 : ;;
1181 : ;; (ad-activate-regexp "^fg-")
1182 : ;; nil
1183 : ;;
1184 : ;; (eq old-definition (symbol-function 'ad-Advice-foo))
1185 : ;; t
1186 : ;;
1187 : ;; (foo 3)
1188 : ;; "Let's clean up now!"
1189 : ;; 160
1190 : ;;
1191 : ;; @@ Forward advice:
1192 : ;; ==================
1193 : ;;
1194 : ;; Let's define a piece of advice for an undefined function:
1195 : ;;
1196 : ;; (defadvice bar (before fg-sub-1-more act)
1197 : ;; "Subtract one more from X."
1198 : ;; (setq x (1- x)))
1199 : ;; bar
1200 : ;;
1201 : ;; `bar' is not yet defined:
1202 : ;; (fboundp 'bar)
1203 : ;; nil
1204 : ;;
1205 : ;; Now we define it and the forward advice will get activated:
1206 : ;;
1207 : ;; (defun bar (x)
1208 : ;; "Subtract 1 from X."
1209 : ;; (1- x))
1210 : ;; bar
1211 : ;;
1212 : ;; (bar 4)
1213 : ;; 2
1214 : ;;
1215 : ;; Redefinition will activate any available advice if the value of
1216 : ;; `ad-redefinition-action' is either `warn', `accept' or `discard':
1217 : ;;
1218 : ;; (defun bar (x)
1219 : ;; "Subtract 2 from X."
1220 : ;; (- x 2))
1221 : ;; bar
1222 : ;;
1223 : ;; (bar 4)
1224 : ;; 1
1225 : ;;
1226 : ;; @@ Preactivation:
1227 : ;; =================
1228 : ;; Constructing advised definitions is moderately expensive, hence, it is
1229 : ;; desirable to have a way to construct them at byte-compile time.
1230 : ;; Preactivation is a mechanism that allows one to do that.
1231 : ;;
1232 : ;; (defun fie (x)
1233 : ;; "Multiply X by 2."
1234 : ;; (* x 2))
1235 : ;; fie
1236 : ;;
1237 : ;; (defadvice fie (before fg-times-4 preact)
1238 : ;; "Multiply X by 4."
1239 : ;; (setq x (* x 2)))
1240 : ;; fie
1241 : ;;
1242 : ;; This advice did not affect `fie'...
1243 : ;;
1244 : ;; (fie 2)
1245 : ;; 4
1246 : ;;
1247 : ;; ...but it constructed a cached definition that will be used once `fie' gets
1248 : ;; activated as long as its current advice state is the same as it was during
1249 : ;; preactivation:
1250 : ;;
1251 : ;; (setq cached-definition (ad-get-cache-definition 'fie))
1252 : ;; (lambda (x) ....)
1253 : ;;
1254 : ;; (ad-activate 'fie)
1255 : ;; fie
1256 : ;;
1257 : ;; (eq cached-definition (symbol-function 'ad-Advice-fie))
1258 : ;; t
1259 : ;;
1260 : ;; (fie 2)
1261 : ;; 8
1262 : ;;
1263 : ;; If you put a preactivating `defadvice' into a Lisp file that gets byte-
1264 : ;; compiled then the constructed advised definition will get compiled by
1265 : ;; the byte-compiler. For that to occur in a v18 Emacs you had to put the
1266 : ;; `defadvice' inside a `defun' because the v18 compiler did not compile
1267 : ;; top-level forms other than `defun' or `defmacro', for example,
1268 : ;;
1269 : ;; (defun fg-defadvice-fum ()
1270 : ;; (defadvice fum (before fg-times-4 preact act)
1271 : ;; "Multiply X by 4."
1272 : ;; (setq x (* x 2))))
1273 : ;; fg-defadvice-fum
1274 : ;;
1275 : ;; So far, no `defadvice' for `fum' got executed, but when we compile
1276 : ;; `fg-defadvice-fum' the `defadvice' will be expanded by the byte compiler.
1277 : ;; In order for preactivation to be effective we have to have a proper
1278 : ;; definition of `fum' around at preactivation time, hence, we define it now:
1279 : ;;
1280 : ;; (defun fum (x)
1281 : ;; "Multiply X by 2."
1282 : ;; (* x 2))
1283 : ;; fum
1284 : ;;
1285 : ;; Now we compile the defining function which will construct an advised
1286 : ;; definition during expansion of the `defadvice', compile it and store it
1287 : ;; as part of the compiled `fg-defadvice-fum':
1288 : ;;
1289 : ;; (ad-compile-function 'fg-defadvice-fum)
1290 : ;; (lambda nil (byte-code ...))
1291 : ;;
1292 : ;; `fum' is still completely unaffected:
1293 : ;;
1294 : ;; (fum 2)
1295 : ;; 4
1296 : ;;
1297 : ;; (ad-get-advice-info 'fum)
1298 : ;; nil
1299 : ;;
1300 : ;; (fg-defadvice-fum)
1301 : ;; fum
1302 : ;;
1303 : ;; Now the advised version of `fum' is compiled because the compiled definition
1304 : ;; constructed during preactivation was used, even though we did not specify
1305 : ;; the `compile' flag:
1306 : ;;
1307 : ;; (byte-code-function-p 'ad-Advice-fum)
1308 : ;; t
1309 : ;;
1310 : ;; (fum 2)
1311 : ;; 8
1312 : ;;
1313 : ;; A preactivated definition will only be used if it matches the current
1314 : ;; function definition and advice information. If it does not match it
1315 : ;; will simply be discarded and a new advised definition will be constructed
1316 : ;; from scratch. For example, let's first remove all advice-info for `fum':
1317 : ;;
1318 : ;; (ad-unadvise 'fum)
1319 : ;; (("fie") ("bar") ("foo") ...)
1320 : ;;
1321 : ;; And now define a new piece of advice:
1322 : ;;
1323 : ;; (defadvice fum (before fg-interactive act)
1324 : ;; "Make fum interactive."
1325 : ;; (interactive "nEnter x: "))
1326 : ;; fum
1327 : ;;
1328 : ;; When we now try to use a preactivation it will not be used because the
1329 : ;; current advice state is different from the one at preactivation time. This
1330 : ;; is no tragedy, everything will work as expected just not as efficient,
1331 : ;; because a new advised definition has to be constructed from scratch:
1332 : ;;
1333 : ;; (fg-defadvice-fum)
1334 : ;; fum
1335 : ;;
1336 : ;; A new uncompiled advised definition got constructed:
1337 : ;;
1338 : ;; (byte-code-function-p 'ad-Advice-fum)
1339 : ;; nil
1340 : ;;
1341 : ;; (fum 2)
1342 : ;; 8
1343 : ;;
1344 : ;; MORAL: To get all the efficiency out of preactivation the function
1345 : ;; definition and advice state at preactivation time must be the same as the
1346 : ;; state at activation time. Preactivation does work with forward advice, all
1347 : ;; that's necessary is that the definition of the forward advised function is
1348 : ;; available when the `defadvice' with the preactivation gets compiled.
1349 : ;;
1350 : ;; @@ Portable argument access:
1351 : ;; ============================
1352 : ;; So far, we always used the actual argument variable names to access an
1353 : ;; argument in a piece of advice. For many advice applications this is
1354 : ;; perfectly ok and keeps advices simple. However, it decreases portability
1355 : ;; of advices because it assumes specific argument variable names. For example,
1356 : ;; if one advises a subr such as `eval-region' which then gets redefined by
1357 : ;; some package (e.g., edebug) into a function with different argument names,
1358 : ;; then a piece of advice written for `eval-region' that was written with
1359 : ;; the subr arguments in mind will break.
1360 : ;;
1361 : ;; Argument access text macros allow one to access arguments of an advised
1362 : ;; function in a portable way without having to worry about all these
1363 : ;; possibilities. These macros will be translated into the proper access forms
1364 : ;; at activation time, hence, argument access will be as efficient as if
1365 : ;; the arguments had been used directly in the definition of the advice.
1366 : ;;
1367 : ;; (defun fuu (x y z)
1368 : ;; "Add 3 numbers."
1369 : ;; (+ x y z))
1370 : ;; fuu
1371 : ;;
1372 : ;; (fuu 1 1 1)
1373 : ;; 3
1374 : ;;
1375 : ;; Argument access macros specify actual arguments at a certain position.
1376 : ;; Position 0 access the first actual argument, position 1 the second etc.
1377 : ;; For example, the following advice adds 1 to each of the 3 arguments:
1378 : ;;
1379 : ;; (defadvice fuu (before fg-add-1-to-all act)
1380 : ;; "Adds 1 to all arguments."
1381 : ;; (ad-set-arg 0 (1+ (ad-get-arg 0)))
1382 : ;; (ad-set-arg 1 (1+ (ad-get-arg 1)))
1383 : ;; (ad-set-arg 2 (1+ (ad-get-arg 2))))
1384 : ;; fuu
1385 : ;;
1386 : ;; (fuu 1 1 1)
1387 : ;; 6
1388 : ;;
1389 : ;; Now suppose somebody redefines `fuu' with a rest argument. Our advice
1390 : ;; will still work because we used access macros (note, that automatic
1391 : ;; advice activation is still in effect, hence, the redefinition of `fuu'
1392 : ;; will automatically activate all its advice):
1393 : ;;
1394 : ;; (defun fuu (&rest numbers)
1395 : ;; "Add NUMBERS."
1396 : ;; (apply '+ numbers))
1397 : ;; fuu
1398 : ;;
1399 : ;; (fuu 1 1 1)
1400 : ;; 6
1401 : ;;
1402 : ;; (fuu 1 1 1 1 1 1)
1403 : ;; 9
1404 : ;;
1405 : ;; What's important to notice is that argument access macros access actual
1406 : ;; arguments regardless of how they got distributed onto argument variables.
1407 : ;; In Emacs Lisp the semantics of an actual argument is determined purely
1408 : ;; by position, hence, as long as nobody changes the semantics of what a
1409 : ;; certain actual argument at a certain position means the access macros
1410 : ;; will do the right thing.
1411 : ;;
1412 : ;; Because of &rest arguments we need a second kind of access macro that
1413 : ;; can access all actual arguments starting from a certain position:
1414 : ;;
1415 : ;; (defadvice fuu (before fg-print-args act)
1416 : ;; "Print all arguments."
1417 : ;; (print (ad-get-args 0)))
1418 : ;; fuu
1419 : ;;
1420 : ;; (fuu 1 2 3 4 5)
1421 : ;; (1 2 3 4 5)
1422 : ;; 18
1423 : ;;
1424 : ;; (defadvice fuu (before fg-set-args act)
1425 : ;; "Swaps 2nd and 3rd arg and discards all the rest."
1426 : ;; (ad-set-args 1 (list (ad-get-arg 2) (ad-get-arg 1))))
1427 : ;; fuu
1428 : ;;
1429 : ;; (fuu 1 2 3 4 4 4 4 4 4)
1430 : ;; (1 3 2)
1431 : ;; 9
1432 : ;;
1433 : ;; (defun fuu (x y z)
1434 : ;; "Add 3 numbers."
1435 : ;; (+ x y z))
1436 : ;;
1437 : ;; (fuu 1 2 3)
1438 : ;; (1 3 2)
1439 : ;; 9
1440 : ;;
1441 : ;; @@ Defining the argument list of an advised function:
1442 : ;; =====================================================
1443 : ;; Once in a while it might be desirable to advise a function and additionally
1444 : ;; give it an extra argument that controls the advised code, for example, one
1445 : ;; might want to make an interactive function sensitive to a prefix argument.
1446 : ;; For such cases `defadvice' allows the specification of an argument list
1447 : ;; for the advised function. Similar to the redefinition of interactive
1448 : ;; behavior, the first argument list specification found in the list of before/
1449 : ;; around/after advices will be used. Of course, the specified argument list
1450 : ;; should be downward compatible with the original argument list, otherwise
1451 : ;; functions that call the advised function with the original argument list
1452 : ;; in mind will break.
1453 : ;;
1454 : ;; (defun fii (x)
1455 : ;; "Add 1 to X."
1456 : ;; (1+ x))
1457 : ;; fii
1458 : ;;
1459 : ;; Now we advise `fii' to use an optional second argument that controls the
1460 : ;; amount of incrementing. A list following the (optional) position
1461 : ;; argument of the advice will be interpreted as an argument list
1462 : ;; specification. This means you cannot specify an empty argument list, and
1463 : ;; why would you want to anyway?
1464 : ;;
1465 : ;; (defadvice fii (before fg-inc-x (x &optional incr) act)
1466 : ;; "Increment X by INCR (default is 1)."
1467 : ;; (setq x (+ x (1- (or incr 1)))))
1468 : ;; fii
1469 : ;;
1470 : ;; (fii 3)
1471 : ;; 4
1472 : ;;
1473 : ;; (fii 3 2)
1474 : ;; 5
1475 : ;;
1476 : ;; @@ Advising interactive subrs:
1477 : ;; ==============================
1478 : ;; For the most part there is no difference between advising functions and
1479 : ;; advising subrs. There is one situation though where one might have to write
1480 : ;; slightly different advice code for subrs than for functions. This case
1481 : ;; arises when one wants to access subr arguments in a before/around advice
1482 : ;; when the arguments were determined by an interactive call to the subr.
1483 : ;; Advice cannot determine what `interactive' form determines the interactive
1484 : ;; behavior of the subr, hence, when it calls the original definition in an
1485 : ;; interactive subr invocation it has to use `call-interactively' to generate
1486 : ;; the proper interactive behavior. Thus up to that call the arguments of the
1487 : ;; interactive subr will be nil. For example, the following advice for
1488 : ;; `kill-buffer' will not work in an interactive invocation...
1489 : ;;
1490 : ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp)
1491 : ;; (my-before-kill-buffer-hook (ad-get-arg 0)))
1492 : ;; kill-buffer
1493 : ;;
1494 : ;; ...because the buffer argument will be nil in that case. The way out of
1495 : ;; this dilemma is to provide an `interactive' specification that mirrors
1496 : ;; the interactive behavior of the unadvised subr, for example, the following
1497 : ;; will do the right thing even when `kill-buffer' is called interactively:
1498 : ;;
1499 : ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp)
1500 : ;; (interactive "bKill buffer: ")
1501 : ;; (my-before-kill-buffer-hook (ad-get-arg 0)))
1502 : ;; kill-buffer
1503 : ;;
1504 : ;; @@ Advising macros:
1505 : ;; ===================
1506 : ;; Advising macros is slightly different because there are two significant
1507 : ;; time points in the invocation of a macro: Expansion and evaluation time.
1508 : ;; For an advised macro instead of evaluating the original definition we
1509 : ;; use `macroexpand', that is, changing argument values and binding
1510 : ;; environments by pieces of advice has an affect during macro expansion
1511 : ;; but not necessarily during evaluation. In particular, any side effects
1512 : ;; of pieces of advice will occur during macro expansion. To also affect
1513 : ;; the behavior during evaluation time one has to change the value of
1514 : ;; `ad-return-value' in a piece of after advice. For example:
1515 : ;;
1516 : ;; (defmacro foom (x)
1517 : ;; (` (list (, x))))
1518 : ;; foom
1519 : ;;
1520 : ;; (foom '(a))
1521 : ;; ((a))
1522 : ;;
1523 : ;; (defadvice foom (before fg-print-x act)
1524 : ;; "Print the value of X."
1525 : ;; (print x))
1526 : ;; foom
1527 : ;;
1528 : ;; The following works as expected because evaluation immediately follows
1529 : ;; macro expansion:
1530 : ;;
1531 : ;; (foom '(a))
1532 : ;; (quote (a))
1533 : ;; ((a))
1534 : ;;
1535 : ;; However, the printing happens during expansion (or byte-compile) time:
1536 : ;;
1537 : ;; (macroexpand '(foom '(a)))
1538 : ;; (quote (a))
1539 : ;; (list (quote (a)))
1540 : ;;
1541 : ;; If we want it to happen during evaluation time we have to do the
1542 : ;; following (first remove the old advice):
1543 : ;;
1544 : ;; (ad-remove-advice 'foom 'before 'fg-print-x)
1545 : ;; nil
1546 : ;;
1547 : ;; (defadvice foom (after fg-print-x act)
1548 : ;; "Print the value of X."
1549 : ;; (setq ad-return-value
1550 : ;; (` (progn (print (, x))
1551 : ;; (, ad-return-value)))))
1552 : ;; foom
1553 : ;;
1554 : ;; (macroexpand '(foom '(a)))
1555 : ;; (progn (print (quote (a))) (list (quote (a))))
1556 : ;;
1557 : ;; (foom '(a))
1558 : ;; (a)
1559 : ;; ((a))
1560 : ;;
1561 : ;; While this method might seem somewhat cumbersome, it is very general
1562 : ;; because it allows one to influence macro expansion as well as evaluation.
1563 : ;; In general, advising macros should be a rather rare activity anyway, in
1564 : ;; particular, because compile-time macro expansion takes away a lot of the
1565 : ;; flexibility and effectiveness of the advice mechanism. Macros that were
1566 : ;; compile-time expanded before the advice was activated will of course never
1567 : ;; exhibit the advised behavior.
1568 :
1569 : ;;; Code:
1570 :
1571 : ;; @ Advice implementation:
1572 : ;; ========================
1573 :
1574 : ;; @@ Compilation idiosyncrasies:
1575 : ;; ==============================
1576 :
1577 : (require 'macroexp)
1578 : ;; At run-time also, since ad-do-advised-functions returns code that uses it.
1579 : (eval-when-compile (require 'cl-lib))
1580 :
1581 : ;; @@ Variable definitions:
1582 : ;; ========================
1583 :
1584 : (defgroup advice nil
1585 : "An overloading mechanism for Emacs Lisp functions."
1586 : :prefix "ad-"
1587 : :link '(custom-manual "(elisp)Advising Functions")
1588 : :group 'lisp)
1589 :
1590 : (defconst ad-version "2.14")
1591 :
1592 : ;;;###autoload
1593 : (defcustom ad-redefinition-action 'warn
1594 : "Defines what to do with redefinitions during Advice de/activation.
1595 : Redefinition occurs if a previously activated function that already has an
1596 : original definition associated with it gets redefined and then de/activated.
1597 : In such a case we can either accept the current definition as the new
1598 : original definition, discard the current definition and replace it with the
1599 : old original, or keep it and raise an error. The values `accept', `discard',
1600 : `error' or `warn' govern what will be done. `warn' is just like `accept' but
1601 : it additionally prints a warning message. All other values will be
1602 : interpreted as `error'."
1603 : :type '(choice (const accept) (const discard) (const warn)
1604 : (other :tag "error" error))
1605 : :group 'advice)
1606 :
1607 : ;;;###autoload
1608 : (defcustom ad-default-compilation-action 'maybe
1609 : "Defines whether to compile advised definitions during activation.
1610 : A value of `always' will result in unconditional compilation, `never' will
1611 : always avoid compilation, `maybe' will compile if the byte-compiler is already
1612 : loaded, and `like-original' will compile if the original definition of the
1613 : advised function is compiled or a built-in function. Every other value will
1614 : be interpreted as `maybe'. This variable will only be considered if the
1615 : COMPILE argument of `ad-activate' was supplied as nil."
1616 : :type '(choice (const always) (const never) (const like-original)
1617 : (other :tag "maybe" maybe))
1618 : :group 'advice)
1619 :
1620 :
1621 :
1622 : ;; @@ Some utilities:
1623 : ;; ==================
1624 :
1625 : ;; We don't want the local arguments to interfere with anything
1626 : ;; referenced in the supplied functions => the cryptic casing:
1627 : (defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE)
1628 : "Substitute qualifying subTREEs with result of FUNCTION(subTREE).
1629 : Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4)
1630 : then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are
1631 : allowed too. Once a qualifying subtree has been found its subtrees will
1632 : not be considered anymore. (ad-substitute-tree \\='atom \\='identity tree)
1633 : generates a copy of TREE."
1634 0 : (cond ((consp tReE)
1635 0 : (cons (if (funcall sUbTrEe-TeSt (car tReE))
1636 0 : (funcall fUnCtIoN (car tReE))
1637 0 : (if (consp (car tReE))
1638 0 : (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (car tReE))
1639 0 : (car tReE)))
1640 0 : (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (cdr tReE))))
1641 0 : ((funcall sUbTrEe-TeSt tReE)
1642 0 : (funcall fUnCtIoN tReE))
1643 0 : (t tReE)))
1644 :
1645 : ;; @@ Advice info access fns:
1646 : ;; ==========================
1647 :
1648 : ;; Advice information for a particular function is stored on the
1649 : ;; advice-info property of the function symbol. It is stored as an
1650 : ;; alist of the following format:
1651 : ;;
1652 : ;; ((active . t/nil)
1653 : ;; (before adv1 adv2 ...)
1654 : ;; (around adv1 adv2 ...)
1655 : ;; (after adv1 adv2 ...)
1656 : ;; (activation adv1 adv2 ...)
1657 : ;; (deactivation adv1 adv2 ...)
1658 : ;; (advicefunname . <symbol fbound to assembled advice function>)
1659 : ;; (cache . (<advised-definition> . <id>)))
1660 :
1661 : ;; List of currently advised though not necessarily activated functions
1662 : ;; (this list is maintained as a completion table):
1663 : (defvar ad-advised-functions nil)
1664 :
1665 : (defmacro ad-pushnew-advised-function (function)
1666 : "Add FUNCTION to `ad-advised-functions' unless its already there."
1667 1 : `(if (not (assoc (symbol-name ,function) ad-advised-functions))
1668 : (setq ad-advised-functions
1669 1 : (cons (list (symbol-name ,function))
1670 1 : ad-advised-functions))))
1671 :
1672 : (defmacro ad-pop-advised-function (function)
1673 : "Remove FUNCTION from `ad-advised-functions'."
1674 3 : `(setq ad-advised-functions
1675 3 : (delq (assoc (symbol-name ,function) ad-advised-functions)
1676 3 : ad-advised-functions)))
1677 :
1678 : (defmacro ad-do-advised-functions (varform &rest body)
1679 : "`dolist'-style iterator that maps over advised functions.
1680 : \(ad-do-advised-functions (VAR)
1681 : BODY-FORM...)
1682 : On each iteration VAR will be bound to the name of an advised function
1683 : \(a symbol)."
1684 : (declare (indent 1))
1685 11 : `(dolist (,(car varform) ad-advised-functions)
1686 11 : (setq ,(car varform) (intern (car ,(car varform))))
1687 11 : ,@body))
1688 :
1689 : (defun ad-get-advice-info (function)
1690 0 : (get function 'ad-advice-info))
1691 :
1692 : (defmacro ad-get-advice-info-macro (function)
1693 47 : `(get ,function 'ad-advice-info))
1694 :
1695 : (defsubst ad-set-advice-info (function advice-info)
1696 0 : (cond
1697 0 : (advice-info
1698 0 : (add-function :around (get function 'defalias-fset-function)
1699 0 : #'ad--defalias-fset))
1700 0 : ((get function 'defalias-fset-function)
1701 0 : (remove-function (get function 'defalias-fset-function)
1702 0 : #'ad--defalias-fset)))
1703 0 : (put function 'ad-advice-info advice-info))
1704 :
1705 : (defmacro ad-copy-advice-info (function)
1706 1 : `(copy-tree (get ,function 'ad-advice-info)))
1707 :
1708 : (defmacro ad-is-advised (function)
1709 : "Return non-nil if FUNCTION has any advice info associated with it.
1710 : This does not mean that the advice is also active."
1711 15 : `(ad-get-advice-info-macro ,function))
1712 :
1713 : (defun ad-initialize-advice-info (function)
1714 : "Initialize the advice info for FUNCTION.
1715 : Assumes that FUNCTION has not yet been advised."
1716 0 : (ad-pushnew-advised-function function)
1717 0 : (ad-set-advice-info function (list (cons 'active nil))))
1718 :
1719 : (defmacro ad-get-advice-info-field (function field)
1720 : "Retrieve the value of the advice info FIELD of FUNCTION."
1721 29 : `(cdr (assq ,field (ad-get-advice-info-macro ,function))))
1722 :
1723 : (defun ad-set-advice-info-field (function field value)
1724 : "Destructively modify VALUE of the advice info FIELD of FUNCTION."
1725 0 : (and (ad-is-advised function)
1726 0 : (cond ((assq field (ad-get-advice-info-macro function))
1727 : ;; A field with that name is already present:
1728 0 : (rplacd (assq field (ad-get-advice-info-macro function)) value))
1729 : (t;; otherwise, create a new field with that name:
1730 0 : (nconc (ad-get-advice-info-macro function)
1731 0 : (list (cons field value)))))))
1732 :
1733 : ;; Don't make this a macro so we can use it as a predicate:
1734 : (defun ad-is-active (function)
1735 : "Return non-nil if FUNCTION is advised and activated."
1736 0 : (ad-get-advice-info-field function 'active))
1737 :
1738 :
1739 : ;; @@ Access fns for single pieces of advice and related predicates:
1740 : ;; =================================================================
1741 :
1742 : (defun ad-make-advice (name protect enable definition)
1743 : "Constructs single piece of advice to be stored in some advice-info.
1744 : NAME should be a non-nil symbol, PROTECT and ENABLE should each be
1745 : either t or nil, and DEFINITION should be a list of the form
1746 : `(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'."
1747 1 : (list name protect enable definition))
1748 :
1749 : ;; ad-find-advice uses the alist structure directly ->
1750 : ;; change if this data structure changes!!
1751 0 : (defsubst ad-advice-name (advice) (car advice))
1752 0 : (defsubst ad-advice-protected (advice) (nth 1 advice))
1753 0 : (defsubst ad-advice-enabled (advice) (nth 2 advice))
1754 0 : (defsubst ad-advice-definition (advice) (nth 3 advice))
1755 :
1756 : (defun ad-advice-set-enabled (advice flag)
1757 0 : (rplaca (cdr (cdr advice)) flag))
1758 :
1759 : (defvar ad-advice-classes '(before around after activation deactivation)
1760 : "List of defined advice classes.")
1761 :
1762 : (defun ad-class-p (thing)
1763 1 : (memq thing ad-advice-classes))
1764 : (defun ad-name-p (thing)
1765 2 : (and thing (symbolp thing)))
1766 : (defun ad-position-p (thing)
1767 1 : (or (natnump thing)
1768 1 : (memq thing '(first last))))
1769 :
1770 :
1771 : ;; @@ Advice access functions:
1772 : ;; ===========================
1773 :
1774 : (defun ad-has-enabled-advice (function class)
1775 : "True if at least one of FUNCTION's advices in CLASS is enabled."
1776 0 : (cl-dolist (advice (ad-get-advice-info-field function class))
1777 0 : (if (ad-advice-enabled advice) (cl-return t))))
1778 :
1779 : (defun ad-has-redefining-advice (function)
1780 : "True if FUNCTION's advice info defines at least 1 redefining advice.
1781 : Redefining advices affect the construction of an advised definition."
1782 0 : (and (ad-is-advised function)
1783 0 : (or (ad-has-enabled-advice function 'before)
1784 0 : (ad-has-enabled-advice function 'around)
1785 0 : (ad-has-enabled-advice function 'after))))
1786 :
1787 : (defun ad-has-any-advice (function)
1788 : "True if the advice info of FUNCTION defines at least one advice."
1789 0 : (and (ad-is-advised function)
1790 0 : (cl-dolist (class ad-advice-classes)
1791 0 : (if (ad-get-advice-info-field function class)
1792 0 : (cl-return t)))))
1793 :
1794 : (defun ad-get-enabled-advices (function class)
1795 : "Return the list of enabled advices of FUNCTION in CLASS."
1796 0 : (let (enabled-advices)
1797 0 : (dolist (advice (ad-get-advice-info-field function class))
1798 0 : (if (ad-advice-enabled advice)
1799 0 : (push advice enabled-advices)))
1800 0 : (reverse enabled-advices)))
1801 :
1802 :
1803 : ;; @@ Dealing with automatic advice activation via `fset/defalias':
1804 : ;; ================================================================
1805 :
1806 : ;; Automatic activation happens when a function gets defined via `defalias',
1807 : ;; which calls the `defalias-fset-function' (which we set to
1808 : ;; `ad--defalias-fset') instead of `fset', if non-nil.
1809 :
1810 : ;; Whether advised definitions created by automatic activations will be
1811 : ;; compiled depends on the value of `ad-default-compilation-action'.
1812 :
1813 : (defalias 'ad-activate-internal 'ad-activate)
1814 :
1815 : (defun ad-make-advicefunname (function)
1816 : "Make name to be used to call the assembled advice function."
1817 0 : (intern (format "ad-Advice-%s" function)))
1818 :
1819 : (defun ad-get-orig-definition (function) ;FIXME: Rename to "-unadvised-".
1820 0 : (if (symbolp function)
1821 0 : (setq function (if (fboundp function)
1822 0 : (advice--strip-macro (symbol-function function)))))
1823 0 : (while (advice--p function) (setq function (advice--cdr function)))
1824 0 : function)
1825 :
1826 : (defun ad-clear-advicefunname-definition (function)
1827 0 : (let ((advicefunname (ad-get-advice-info-field function 'advicefunname)))
1828 0 : (advice-remove function advicefunname)
1829 0 : (fmakunbound advicefunname)))
1830 :
1831 :
1832 : ;; @@ Interactive input functions:
1833 : ;; ===============================
1834 :
1835 : (declare-function function-called-at-point "help")
1836 :
1837 : (defun ad-read-advised-function (&optional prompt predicate default)
1838 : "Read name of advised function with completion from the minibuffer.
1839 : An optional PROMPT will be used to prompt for the function. PREDICATE
1840 : plays the same role as for `try-completion' (which see). DEFAULT will
1841 : be returned on empty input (defaults to the first advised function or
1842 : function at point for which PREDICATE returns non-nil)."
1843 0 : (if (null ad-advised-functions)
1844 0 : (error "ad-read-advised-function: There are no advised functions"))
1845 0 : (setq default
1846 0 : (or default
1847 : ;; Prefer func name at point, if it's an advised function etc.
1848 0 : (let ((function (progn
1849 0 : (require 'help)
1850 0 : (function-called-at-point))))
1851 0 : (and function
1852 0 : (assoc (symbol-name function) ad-advised-functions)
1853 0 : (or (null predicate)
1854 0 : (funcall predicate function))
1855 0 : function))
1856 0 : (cl-block nil
1857 0 : (ad-do-advised-functions (function)
1858 : (if (or (null predicate)
1859 : (funcall predicate function))
1860 0 : (cl-return function))))
1861 0 : (error "ad-read-advised-function: %s"
1862 0 : "There are no qualifying advised functions")))
1863 0 : (let* ((function
1864 0 : (completing-read
1865 0 : (format "%s (default %s): " (or prompt "Function") default)
1866 0 : ad-advised-functions
1867 0 : (if predicate
1868 : (lambda (function)
1869 0 : (funcall predicate (intern (car function)))))
1870 0 : t)))
1871 0 : (if (equal function "")
1872 0 : (if (ad-is-advised default)
1873 0 : default
1874 0 : (error "ad-read-advised-function: `%s' is not advised" default))
1875 0 : (intern function))))
1876 :
1877 : (defvar ad-advice-class-completion-table
1878 : (mapcar (lambda (class) (list (symbol-name class)))
1879 : ad-advice-classes))
1880 :
1881 : (defun ad-read-advice-class (function &optional prompt default)
1882 : "Read a valid advice class with completion from the minibuffer.
1883 : An optional PROMPT will be used to prompt for the class. DEFAULT will
1884 : be returned on empty input (defaults to the first non-empty advice
1885 : class of FUNCTION)."
1886 0 : (setq default
1887 0 : (or default
1888 0 : (cl-dolist (class ad-advice-classes)
1889 0 : (if (ad-get-advice-info-field function class)
1890 0 : (cl-return class)))
1891 0 : (error "ad-read-advice-class: `%s' has no advices" function)))
1892 0 : (let ((class (completing-read
1893 0 : (format "%s (default %s): " (or prompt "Class") default)
1894 0 : ad-advice-class-completion-table nil t)))
1895 0 : (if (equal class "")
1896 0 : default
1897 0 : (intern class))))
1898 :
1899 : (defun ad-read-advice-name (function class &optional prompt)
1900 : "Read name of existing advice of CLASS for FUNCTION with completion.
1901 : An optional PROMPT is used to prompt for the name."
1902 0 : (let* ((name-completion-table
1903 0 : (mapcar (function (lambda (advice)
1904 0 : (list (symbol-name (ad-advice-name advice)))))
1905 0 : (ad-get-advice-info-field function class)))
1906 : (default
1907 0 : (if (null name-completion-table)
1908 0 : (error "ad-read-advice-name: `%s' has no %s advice"
1909 0 : function class)
1910 0 : (car (car name-completion-table))))
1911 0 : (prompt (format "%s (default %s): " (or prompt "Name") default))
1912 0 : (name (completing-read prompt name-completion-table nil t)))
1913 0 : (if (equal name "")
1914 0 : (intern default)
1915 0 : (intern name))))
1916 :
1917 : (defun ad-read-advice-specification (&optional prompt)
1918 : "Read a complete function/class/name specification from minibuffer.
1919 : The list of read symbols will be returned. The optional PROMPT will
1920 : be used to prompt for the function."
1921 0 : (let* ((function (ad-read-advised-function prompt))
1922 0 : (class (ad-read-advice-class function))
1923 0 : (name (ad-read-advice-name function class)))
1924 0 : (list function class name)))
1925 :
1926 : ;; Use previous regexp as a default:
1927 : (defvar ad-last-regexp "")
1928 :
1929 : (defun ad-read-regexp (&optional prompt)
1930 : "Read a regular expression from the minibuffer."
1931 0 : (let ((regexp (read-from-minibuffer
1932 0 : (concat (or prompt "Regular expression")
1933 0 : (if (equal ad-last-regexp "") ": "
1934 0 : (format " (default %s): " ad-last-regexp))))))
1935 0 : (setq ad-last-regexp
1936 0 : (if (equal regexp "") ad-last-regexp regexp))))
1937 :
1938 :
1939 : ;; @@ Finding, enabling, adding and removing pieces of advice:
1940 : ;; ===========================================================
1941 :
1942 : (defmacro ad-find-advice (function class name)
1943 : "Find the first advice of FUNCTION in CLASS with NAME."
1944 2 : `(assq ,name (ad-get-advice-info-field ,function ,class)))
1945 :
1946 : (defun ad-advice-position (function class name)
1947 : "Return position of first advice of FUNCTION in CLASS with NAME."
1948 0 : (let* ((found-advice (ad-find-advice function class name))
1949 0 : (advices (ad-get-advice-info-field function class)))
1950 0 : (if found-advice
1951 0 : (- (length advices) (length (memq found-advice advices))))))
1952 :
1953 : (defun ad-find-some-advice (function class name)
1954 : "Find the first of FUNCTION's advices in CLASS matching NAME.
1955 : NAME can be a symbol or a regular expression matching part of an advice name.
1956 : If CLASS is `any' all valid advice classes will be checked."
1957 0 : (if (ad-is-advised function)
1958 0 : (let (found-advice)
1959 0 : (cl-dolist (advice-class ad-advice-classes)
1960 0 : (if (or (eq class 'any) (eq advice-class class))
1961 0 : (setq found-advice
1962 0 : (cl-dolist (advice (ad-get-advice-info-field
1963 0 : function advice-class))
1964 0 : (if (or (and (stringp name)
1965 0 : (string-match
1966 0 : name (symbol-name
1967 0 : (ad-advice-name advice))))
1968 0 : (eq name (ad-advice-name advice)))
1969 0 : (cl-return advice)))))
1970 0 : (if found-advice (cl-return found-advice))))))
1971 :
1972 : (defun ad-enable-advice-internal (function class name flag)
1973 : "Set enable FLAG of FUNCTION's advices in CLASS matching NAME.
1974 : If NAME is a string rather than a symbol then it's interpreted as a regular
1975 : expression and all advices whose name contain a match for it will be
1976 : affected. If CLASS is `any' advices in all valid advice classes will be
1977 : considered. The number of changed advices will be returned (or nil if
1978 : FUNCTION was not advised)."
1979 0 : (if (ad-is-advised function)
1980 0 : (let ((matched-advices 0))
1981 0 : (dolist (advice-class ad-advice-classes)
1982 0 : (if (or (eq class 'any) (eq advice-class class))
1983 0 : (dolist (advice (ad-get-advice-info-field
1984 0 : function advice-class))
1985 0 : (cond ((or (and (stringp name)
1986 0 : (string-match
1987 0 : name (symbol-name (ad-advice-name advice))))
1988 0 : (eq name (ad-advice-name advice)))
1989 0 : (setq matched-advices (1+ matched-advices))
1990 0 : (ad-advice-set-enabled advice flag))))))
1991 0 : matched-advices)))
1992 :
1993 : ;;;###autoload
1994 : (defun ad-enable-advice (function class name)
1995 : "Enables the advice of FUNCTION with CLASS and NAME."
1996 0 : (interactive (ad-read-advice-specification "Enable advice of"))
1997 0 : (if (ad-is-advised function)
1998 0 : (if (eq (ad-enable-advice-internal function class name t) 0)
1999 0 : (error "ad-enable-advice: `%s' has no %s advice matching `%s'"
2000 0 : function class name))
2001 0 : (error "ad-enable-advice: `%s' is not advised" function)))
2002 :
2003 : ;;;###autoload
2004 : (defun ad-disable-advice (function class name)
2005 : "Disable the advice of FUNCTION with CLASS and NAME."
2006 0 : (interactive (ad-read-advice-specification "Disable advice of"))
2007 0 : (if (ad-is-advised function)
2008 0 : (if (eq (ad-enable-advice-internal function class name nil) 0)
2009 0 : (error "ad-disable-advice: `%s' has no %s advice matching `%s'"
2010 0 : function class name))
2011 0 : (error "ad-disable-advice: `%s' is not advised" function)))
2012 :
2013 : (defun ad-enable-regexp-internal (regexp class flag)
2014 : "Set enable FLAGs of all CLASS advices whose name contains a REGEXP match.
2015 : If CLASS is `any' all valid advice classes are considered. The number of
2016 : affected advices will be returned."
2017 0 : (let ((matched-advices 0))
2018 0 : (ad-do-advised-functions (advised-function)
2019 : (setq matched-advices
2020 : (+ matched-advices
2021 : (or (ad-enable-advice-internal
2022 : advised-function class regexp flag)
2023 0 : 0))))
2024 0 : matched-advices))
2025 :
2026 : (defun ad-enable-regexp (regexp)
2027 : "Enables all advices with names that contain a match for REGEXP.
2028 : All currently advised functions will be considered."
2029 : (interactive
2030 0 : (list (ad-read-regexp "Enable advices via regexp")))
2031 0 : (let ((matched-advices (ad-enable-regexp-internal regexp 'any t)))
2032 0 : (if (called-interactively-p 'interactive)
2033 0 : (message "%d matching advices enabled" matched-advices))
2034 0 : matched-advices))
2035 :
2036 : (defun ad-disable-regexp (regexp)
2037 : "Disable all advices with names that contain a match for REGEXP.
2038 : All currently advised functions will be considered."
2039 : (interactive
2040 0 : (list (ad-read-regexp "Disable advices via regexp")))
2041 0 : (let ((matched-advices (ad-enable-regexp-internal regexp 'any nil)))
2042 0 : (if (called-interactively-p 'interactive)
2043 0 : (message "%d matching advices disabled" matched-advices))
2044 0 : matched-advices))
2045 :
2046 : (defun ad-remove-advice (function class name)
2047 : "Remove FUNCTION's advice with NAME from its advices in CLASS.
2048 : If such an advice was found it will be removed from the list of advices
2049 : in that CLASS."
2050 0 : (interactive (ad-read-advice-specification "Remove advice of"))
2051 0 : (if (ad-is-advised function)
2052 0 : (let ((advice-to-remove (ad-find-advice function class name)))
2053 0 : (if advice-to-remove
2054 0 : (ad-set-advice-info-field
2055 0 : function class
2056 0 : (delq advice-to-remove (ad-get-advice-info-field function class)))
2057 0 : (error "ad-remove-advice: `%s' has no %s advice `%s'"
2058 0 : function class name)))
2059 0 : (error "ad-remove-advice: `%s' is not advised" function)))
2060 :
2061 : ;;;###autoload
2062 : (defun ad-add-advice (function advice class position)
2063 : "Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
2064 :
2065 : ADVICE has the form (NAME PROTECTED ENABLED DEFINITION), where
2066 : NAME is the advice name; PROTECTED is a flag specifying whether
2067 : to protect against non-local exits; ENABLED is a flag specifying
2068 : whether to initially enable the advice; and DEFINITION has the
2069 : form (advice . LAMBDA), where LAMBDA is a lambda expression.
2070 :
2071 : If FUNCTION already has a piece of advice with the same name,
2072 : then POSITION is ignored, and the old advice is overwritten with
2073 : the new one.
2074 :
2075 : If FUNCTION already has one or more pieces of advice of the
2076 : specified CLASS, then POSITION determines where the new piece
2077 : goes. POSITION can either be `first', `last' or a number (where
2078 : 0 corresponds to `first', and numbers outside the valid range are
2079 : mapped to the closest extremal position).
2080 :
2081 : If FUNCTION was not advised already, its advice info will be
2082 : initialized. Redefining a piece of advice whose name is part of
2083 : the cache-id will clear the cache."
2084 0 : (cond ((not (ad-is-advised function))
2085 0 : (ad-initialize-advice-info function)
2086 0 : (ad-set-advice-info-field
2087 0 : function 'advicefunname (ad-make-advicefunname function))))
2088 0 : (let* ((previous-position
2089 0 : (ad-advice-position function class (ad-advice-name advice)))
2090 0 : (advices (ad-get-advice-info-field function class))
2091 : ;; Determine a numerical position for the new advice:
2092 0 : (position (cond (previous-position)
2093 0 : ((eq position 'first) 0)
2094 0 : ((eq position 'last) (length advices))
2095 0 : ((numberp position)
2096 0 : (max 0 (min position (length advices))))
2097 0 : (t 0))))
2098 : ;; Check whether we have to clear the cache:
2099 0 : (if (memq (ad-advice-name advice) (ad-get-cache-class-id function class))
2100 0 : (ad-clear-cache function))
2101 0 : (if previous-position
2102 0 : (setcar (nthcdr position advices) advice)
2103 0 : (if (= position 0)
2104 0 : (ad-set-advice-info-field function class (cons advice advices))
2105 0 : (setcdr (nthcdr (1- position) advices)
2106 0 : (cons advice (nthcdr position advices)))))))
2107 :
2108 :
2109 : ;; @@ Accessing and manipulating function definitions:
2110 : ;; ===================================================
2111 :
2112 : (defmacro ad-macrofy (definition)
2113 : "Take a lambda function DEFINITION and make a macro out of it."
2114 0 : `(cons 'macro ,definition))
2115 :
2116 : (defmacro ad-lambdafy (definition)
2117 : "Take a macro function DEFINITION and make a lambda out of it."
2118 7 : `(cdr ,definition))
2119 :
2120 : (defmacro ad-lambda-p (definition)
2121 : ;;"non-nil if DEFINITION is a lambda expression."
2122 3 : `(eq (car-safe ,definition) 'lambda))
2123 :
2124 : ;; see ad-make-advice for the format of advice definitions:
2125 : (defmacro ad-advice-p (definition)
2126 : ;;"non-nil if DEFINITION is a piece of advice."
2127 4 : `(eq (car-safe ,definition) 'advice))
2128 :
2129 : (defmacro ad-compiled-p (definition)
2130 : "Return non-nil if DEFINITION is a compiled byte-code object."
2131 5 : `(or (byte-code-function-p ,definition)
2132 5 : (and (macrop ,definition)
2133 5 : (byte-code-function-p (ad-lambdafy ,definition)))))
2134 :
2135 : (defmacro ad-compiled-code (compiled-definition)
2136 : "Return the byte-code object of a COMPILED-DEFINITION."
2137 0 : `(if (macrop ,compiled-definition)
2138 0 : (ad-lambdafy ,compiled-definition)
2139 0 : ,compiled-definition))
2140 :
2141 : (defun ad-lambda-expression (definition)
2142 : "Return the lambda expression of a function/macro/advice DEFINITION."
2143 0 : (cond ((ad-lambda-p definition)
2144 0 : definition)
2145 0 : ((macrop definition)
2146 0 : (ad-lambdafy definition))
2147 0 : ((ad-advice-p definition)
2148 0 : (cdr definition))
2149 0 : (t nil)))
2150 :
2151 : (defun ad-arglist (definition)
2152 : "Return the argument list of DEFINITION."
2153 0 : (help-function-arglist
2154 0 : (if (or (macrop definition) (ad-advice-p definition))
2155 0 : (cdr definition)
2156 0 : definition)
2157 0 : 'preserve-names))
2158 :
2159 : (defun ad-docstring (definition)
2160 : "Return the unexpanded docstring of DEFINITION."
2161 0 : (let ((docstring
2162 0 : (if (ad-compiled-p definition)
2163 0 : (documentation definition t)
2164 0 : (car (cdr (cdr (ad-lambda-expression definition)))))))
2165 0 : (if (or (stringp docstring)
2166 0 : (natnump docstring))
2167 0 : docstring)))
2168 :
2169 : (defun ad-interactive-form (definition)
2170 : "Return the interactive form of DEFINITION.
2171 : Like `interactive-form', but also works on pieces of advice."
2172 0 : (interactive-form
2173 0 : (if (ad-advice-p definition)
2174 0 : (ad-lambda-expression definition)
2175 0 : definition)))
2176 :
2177 : (defun ad-body-forms (definition)
2178 : "Return the list of body forms of DEFINITION."
2179 0 : (cond ((ad-compiled-p definition)
2180 : nil)
2181 0 : ((consp definition)
2182 0 : (nthcdr (+ (if (ad-docstring definition) 1 0)
2183 0 : (if (ad-interactive-form definition) 1 0))
2184 0 : (cdr (cdr (ad-lambda-expression definition)))))))
2185 :
2186 : (defun ad-definition-type (definition)
2187 : "Return symbol that describes the type of DEFINITION."
2188 : ;; These symbols are only ever used to check a cache entry's validity.
2189 : ;; The suffix `2' reflects the fact that we're using version 2 of advice
2190 : ;; representations, so cache entries preactivated with version
2191 : ;; 1 can't be used.
2192 0 : (cond
2193 0 : ((macrop definition) 'macro2)
2194 0 : ((subrp definition) 'subr2)
2195 0 : ((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2)
2196 0 : ((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen?
2197 :
2198 : (defun ad-has-proper-definition (function)
2199 : "True if FUNCTION is a symbol with a proper definition.
2200 : For that it has to be fbound with a non-autoload definition."
2201 0 : (and (symbolp function)
2202 0 : (fboundp function)
2203 0 : (not (autoloadp (symbol-function function)))))
2204 :
2205 : ;; The following two are necessary for the sake of packages such as
2206 : ;; ange-ftp which redefine functions via fcell indirection:
2207 : (defun ad-real-definition (function)
2208 : "Find FUNCTION's definition at the end of function cell indirection."
2209 0 : (if (ad-has-proper-definition function)
2210 0 : (let ((definition (symbol-function function)))
2211 0 : (if (symbolp definition)
2212 0 : (ad-real-definition definition)
2213 0 : definition))))
2214 :
2215 : (defun ad-real-orig-definition (function)
2216 0 : (let* ((fun1 (ad-get-orig-definition function))
2217 0 : (fun2 (indirect-function fun1)))
2218 0 : (unless (autoloadp fun2) fun2)))
2219 :
2220 : (defun ad-is-compilable (function)
2221 : "True if FUNCTION has an interpreted definition that can be compiled."
2222 0 : (and (ad-has-proper-definition function)
2223 0 : (or (ad-lambda-p (symbol-function function))
2224 0 : (macrop (symbol-function function)))
2225 0 : (not (ad-compiled-p (symbol-function function)))))
2226 :
2227 : (defvar warning-suppress-types) ;From warnings.el.
2228 : (defun ad-compile-function (function)
2229 : "Byte-compile the assembled advice function."
2230 0 : (require 'bytecomp)
2231 0 : (let ((byte-compile-warnings byte-compile-warnings)
2232 : ;; Don't pop up windows showing byte-compiler warnings.
2233 : (warning-suppress-types '((bytecomp))))
2234 0 : (if (featurep 'cl)
2235 0 : (byte-compile-disable-warning 'cl-functions))
2236 0 : (byte-compile (ad-get-advice-info-field function 'advicefunname))))
2237 :
2238 : ;; @@@ Accessing argument lists:
2239 : ;; =============================
2240 :
2241 : (defun ad-parse-arglist (arglist)
2242 : "Parse ARGLIST into its required, optional and rest parameters.
2243 : A three-element list is returned, where the 1st element is the list of
2244 : required arguments, the 2nd is the list of optional arguments, and the 3rd
2245 : is the name of an optional rest parameter (or nil)."
2246 0 : (let (required optional rest)
2247 0 : (setq rest (car (cdr (memq '&rest arglist))))
2248 0 : (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist))))))
2249 0 : (setq optional (cdr (memq '&optional arglist)))
2250 0 : (if optional
2251 0 : (setq required (reverse (cdr (memq '&optional (reverse arglist)))))
2252 0 : (setq required arglist))
2253 0 : (list required optional rest)))
2254 :
2255 : (defun ad-retrieve-args-form (arglist)
2256 : "Generate a form which evaluates into names/values/types of ARGLIST.
2257 : When the form gets evaluated within a function with that argument list
2258 : it will result in a list with one entry for each argument, where the
2259 : first element of each entry is the name of the argument, the second
2260 : element is its actual current value, and the third element is either
2261 : `required', `optional' or `rest' depending on the type of the argument."
2262 0 : (let* ((parsed-arglist (ad-parse-arglist arglist))
2263 0 : (rest (nth 2 parsed-arglist)))
2264 0 : `(list
2265 0 : ,@(mapcar (function
2266 : (lambda (req)
2267 0 : `(list ',req ,req 'required)))
2268 0 : (nth 0 parsed-arglist))
2269 0 : ,@(mapcar (function
2270 : (lambda (opt)
2271 0 : `(list ',opt ,opt 'optional)))
2272 0 : (nth 1 parsed-arglist))
2273 0 : ,@(if rest (list `(list ',rest ,rest 'rest))))))
2274 :
2275 : (defun ad-arg-binding-field (binding field)
2276 0 : (cond ((eq field 'name) (car binding))
2277 0 : ((eq field 'value) (car (cdr binding)))
2278 0 : ((eq field 'type) (car (cdr (cdr binding))))))
2279 :
2280 : (defun ad-list-access (position list)
2281 0 : (cond ((= position 0) list)
2282 0 : ((= position 1) (list 'cdr list))
2283 0 : (t (list 'nthcdr position list))))
2284 :
2285 : (defun ad-element-access (position list)
2286 0 : (cond ((= position 0) (list 'car list))
2287 0 : ((= position 1) `(car (cdr ,list)))
2288 0 : (t (list 'nth position list))))
2289 :
2290 : (defun ad-access-argument (arglist index)
2291 : "Tell how to access ARGLIST's actual argument at position INDEX.
2292 : For a required/optional arg it simply returns it, if a rest argument has
2293 : to be accessed, it returns a list with the index and name."
2294 0 : (let* ((parsed-arglist (ad-parse-arglist arglist))
2295 0 : (reqopt-args (append (nth 0 parsed-arglist)
2296 0 : (nth 1 parsed-arglist)))
2297 0 : (rest-arg (nth 2 parsed-arglist)))
2298 0 : (cond ((< index (length reqopt-args))
2299 0 : (nth index reqopt-args))
2300 0 : (rest-arg
2301 0 : (list (- index (length reqopt-args)) rest-arg)))))
2302 :
2303 : (defun ad-get-argument (arglist index)
2304 : "Return form to access ARGLIST's actual argument at position INDEX.
2305 : INDEX counts from zero."
2306 0 : (let ((argument-access (ad-access-argument arglist index)))
2307 0 : (cond ((consp argument-access)
2308 0 : (ad-element-access
2309 0 : (car argument-access) (car (cdr argument-access))))
2310 0 : (argument-access))))
2311 :
2312 : (defun ad-set-argument (arglist index value-form)
2313 : "Return form to set ARGLIST's actual arg at INDEX to VALUE-FORM.
2314 : INDEX counts from zero."
2315 0 : (let ((argument-access (ad-access-argument arglist index)))
2316 0 : (cond ((consp argument-access)
2317 : ;; should this check whether there actually is something to set?
2318 0 : `(setcar ,(ad-list-access
2319 0 : (car argument-access) (car (cdr argument-access)))
2320 0 : ,value-form))
2321 0 : (argument-access
2322 0 : `(setq ,argument-access ,value-form))
2323 0 : (t (error "ad-set-argument: No argument at position %d of `%s'"
2324 0 : index arglist)))))
2325 :
2326 : (defun ad-get-arguments (arglist index)
2327 : "Return form to access all actual arguments starting at position INDEX."
2328 0 : (let* ((parsed-arglist (ad-parse-arglist arglist))
2329 0 : (reqopt-args (append (nth 0 parsed-arglist)
2330 0 : (nth 1 parsed-arglist)))
2331 0 : (rest-arg (nth 2 parsed-arglist))
2332 : args-form)
2333 0 : (if (< index (length reqopt-args))
2334 0 : (setq args-form `(list ,@(nthcdr index reqopt-args))))
2335 0 : (if rest-arg
2336 0 : (if args-form
2337 0 : (setq args-form `(nconc ,args-form ,rest-arg))
2338 0 : (setq args-form (ad-list-access (- index (length reqopt-args))
2339 0 : rest-arg))))
2340 0 : args-form))
2341 :
2342 : (defun ad-set-arguments (arglist index values-form)
2343 : "Make form to assign elements of VALUES-FORM as actual ARGLIST args.
2344 : The assignment starts at position INDEX."
2345 0 : (let ((values-index 0)
2346 : argument-access set-forms)
2347 0 : (while (setq argument-access (ad-access-argument arglist index))
2348 0 : (push (if (symbolp argument-access)
2349 0 : (ad-set-argument
2350 0 : arglist index
2351 0 : (ad-element-access values-index 'ad-vAlUeS))
2352 0 : (setq arglist nil) ;; Terminate loop.
2353 0 : (if (= (car argument-access) 0)
2354 0 : `(setq
2355 0 : ,(car (cdr argument-access))
2356 0 : ,(ad-list-access values-index 'ad-vAlUeS))
2357 0 : `(setcdr
2358 0 : ,(ad-list-access (1- (car argument-access))
2359 0 : (car (cdr argument-access)))
2360 0 : ,(ad-list-access values-index 'ad-vAlUeS))))
2361 0 : set-forms)
2362 0 : (setq index (1+ index))
2363 0 : (setq values-index (1+ values-index)))
2364 0 : (if (null set-forms)
2365 0 : (error "ad-set-arguments: No argument at position %d of `%s'"
2366 0 : index arglist)
2367 0 : (if (= (length set-forms) 1)
2368 : ;; For exactly one set-form we can use values-form directly,...
2369 0 : (ad-substitute-tree
2370 0 : (lambda (form) (eq form 'ad-vAlUeS))
2371 0 : (lambda (_form) values-form)
2372 0 : (car set-forms))
2373 : ;; ...if we have more we have to bind it to a variable:
2374 0 : `(let ((ad-vAlUeS ,values-form))
2375 0 : ,@(reverse set-forms)
2376 : ;; work around the old backquote bug:
2377 0 : ,'ad-vAlUeS)))))
2378 :
2379 : (defun ad-insert-argument-access-forms (definition arglist)
2380 : "Expands arg-access text macros in DEFINITION according to ARGLIST."
2381 0 : (ad-substitute-tree
2382 0 : (function
2383 : (lambda (form)
2384 0 : (or (eq form 'ad-arg-bindings)
2385 0 : (and (memq (car-safe form)
2386 0 : '(ad-get-arg ad-get-args ad-set-arg ad-set-args))
2387 0 : (integerp (car-safe (cdr form)))))))
2388 0 : (function
2389 : (lambda (form)
2390 0 : (if (eq form 'ad-arg-bindings)
2391 0 : (ad-retrieve-args-form arglist)
2392 0 : (let ((accessor (car form))
2393 0 : (index (car (cdr form)))
2394 0 : (val (car (cdr (ad-insert-argument-access-forms
2395 0 : (cdr form) arglist)))))
2396 0 : (cond ((eq accessor 'ad-get-arg)
2397 0 : (ad-get-argument arglist index))
2398 0 : ((eq accessor 'ad-set-arg)
2399 0 : (ad-set-argument arglist index val))
2400 0 : ((eq accessor 'ad-get-args)
2401 0 : (ad-get-arguments arglist index))
2402 0 : ((eq accessor 'ad-set-args)
2403 0 : (ad-set-arguments arglist index val)))))))
2404 0 : definition))
2405 :
2406 : ;; @@@ Mapping argument lists:
2407 : ;; ===========================
2408 : ;; Here is the problem:
2409 : ;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the
2410 : ;; argument list (x y &rest z), and we want to call the function bar which
2411 : ;; has argument list (a &rest b) with a combination of x, y and z so that
2412 : ;; the effect is just as if we had called (bar 1 2 3 4 5) directly.
2413 : ;; The mapping should work for any two argument lists.
2414 :
2415 : (defun ad-map-arglists (source-arglist target-arglist)
2416 : "Make `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST.
2417 : The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just
2418 : as if they had been supplied to a function with TARGET-ARGLIST directly.
2419 : Excess source arguments will be neglected, missing source arguments will be
2420 : supplied as nil. Returns a `funcall' or `apply' form with the second element
2421 : being `function' which has to be replaced by an actual function argument.
2422 : Example: (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return
2423 : (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))."
2424 0 : (let* ((parsed-source-arglist (ad-parse-arglist source-arglist))
2425 0 : (source-reqopt-args (append (nth 0 parsed-source-arglist)
2426 0 : (nth 1 parsed-source-arglist)))
2427 0 : (source-rest-arg (nth 2 parsed-source-arglist))
2428 0 : (parsed-target-arglist (ad-parse-arglist target-arglist))
2429 0 : (target-reqopt-args (append (nth 0 parsed-target-arglist)
2430 0 : (nth 1 parsed-target-arglist)))
2431 0 : (target-rest-arg (nth 2 parsed-target-arglist))
2432 0 : (need-apply (and source-rest-arg target-rest-arg))
2433 : (target-arg-index -1))
2434 : ;; This produces ``error-proof'' target function calls with the exception
2435 : ;; of a case like (&rest a) mapped onto (x &rest y) where the actual args
2436 : ;; supplied to A might not be enough to supply the required target arg X
2437 0 : (append (list (if need-apply 'apply 'funcall) 'ad--addoit-function)
2438 0 : (cond (need-apply
2439 : ;; `apply' can take care of that directly:
2440 0 : (append source-reqopt-args (list source-rest-arg)))
2441 0 : (t (mapcar (lambda (_arg)
2442 0 : (setq target-arg-index (1+ target-arg-index))
2443 0 : (ad-get-argument
2444 0 : source-arglist target-arg-index))
2445 0 : (append target-reqopt-args
2446 0 : (and target-rest-arg
2447 : ;; If we have a rest arg gobble up
2448 : ;; remaining source args:
2449 0 : (nthcdr (length target-reqopt-args)
2450 0 : source-reqopt-args)))))))))
2451 :
2452 :
2453 : ;; @@@ Making an advised documentation string:
2454 : ;; ===========================================
2455 : ;; New policy: The documentation string for an advised function will be built
2456 : ;; at the time the advised `documentation' function is called. This has the
2457 : ;; following advantages:
2458 : ;; 1) command-key substitutions will automatically be correct
2459 : ;; 2) No wasted string space due to big advised docstrings in caches or
2460 : ;; compiled files that contain preactivations
2461 : ;; The overall overhead for this should be negligible because people normally
2462 : ;; don't lookup documentation for the same function over and over again.
2463 :
2464 : (defun ad-make-single-advice-docstring (advice class &optional style)
2465 0 : (let ((advice-docstring (ad-docstring (ad-advice-definition advice))))
2466 0 : (cond ((eq style 'plain)
2467 0 : advice-docstring)
2468 0 : (t (if advice-docstring
2469 0 : (format "%s-advice `%s':\n%s"
2470 0 : (capitalize (symbol-name class))
2471 0 : (ad-advice-name advice)
2472 0 : advice-docstring)
2473 0 : (format "%s-advice `%s'."
2474 0 : (capitalize (symbol-name class))
2475 0 : (ad-advice-name advice)))))))
2476 :
2477 : (defun ad--make-advised-docstring (function &optional style)
2478 : "Construct a documentation string for the advised FUNCTION.
2479 : Concatenate the original documentation with the documentation
2480 : strings of the individual pieces of advice. Optional argument
2481 : STYLE specifies how to format the pieces of advice; it can be
2482 : `plain', or any other value which means the default formatting.
2483 :
2484 : The advice documentation is shown in order of before/around/after
2485 : advice type, obeying the priority in each of these types."
2486 : ;; Retrieve the original function documentation
2487 0 : (let* ((fun (get function 'function-documentation))
2488 0 : (origdoc (unwind-protect
2489 0 : (progn (put function 'function-documentation nil)
2490 0 : (documentation function t))
2491 0 : (put function 'function-documentation fun))))
2492 0 : (if (and (symbolp function)
2493 0 : (string-match "\\`ad-+Advice-" (symbol-name function)))
2494 0 : (setq function
2495 0 : (intern (substring (symbol-name function) (match-end 0)))))
2496 0 : (let* ((usage (help-split-fundoc origdoc function))
2497 : paragraphs advice-docstring)
2498 0 : (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
2499 0 : (if origdoc (setq paragraphs (list origdoc)))
2500 0 : (dolist (class ad-advice-classes)
2501 0 : (dolist (advice (ad-get-enabled-advices function class))
2502 0 : (setq advice-docstring
2503 0 : (ad-make-single-advice-docstring advice class style))
2504 0 : (if advice-docstring
2505 0 : (push advice-docstring paragraphs))))
2506 0 : (setq origdoc (if paragraphs
2507 0 : (mapconcat 'identity (nreverse paragraphs)
2508 0 : "\n\n")))
2509 0 : (help-add-fundoc-usage origdoc usage))))
2510 :
2511 :
2512 : ;; @@@ Accessing overriding arglists and interactive forms:
2513 : ;; ========================================================
2514 :
2515 : (defun ad-advised-arglist (function)
2516 : "Find first defined arglist in FUNCTION's redefining advices."
2517 0 : (cl-dolist (advice (append (ad-get-enabled-advices function 'before)
2518 0 : (ad-get-enabled-advices function 'around)
2519 0 : (ad-get-enabled-advices function 'after)))
2520 0 : (let ((arglist (ad-arglist (ad-advice-definition advice))))
2521 0 : (if arglist
2522 : ;; We found the first one, use it:
2523 0 : (cl-return arglist)))))
2524 :
2525 : (defun ad-advised-interactive-form (function)
2526 : "Find first interactive form in FUNCTION's redefining advices."
2527 0 : (cl-dolist (advice (append (ad-get-enabled-advices function 'before)
2528 0 : (ad-get-enabled-advices function 'around)
2529 0 : (ad-get-enabled-advices function 'after)))
2530 0 : (let ((interactive-form
2531 0 : (ad-interactive-form (ad-advice-definition advice))))
2532 0 : (if interactive-form
2533 : ;; We found the first one, use it:
2534 0 : (cl-return interactive-form)))))
2535 :
2536 : ;; @@@ Putting it all together:
2537 : ;; ============================
2538 :
2539 : (defun ad-make-advised-definition (function)
2540 : "Generate an advised definition of FUNCTION from its advice info."
2541 0 : (if (and (ad-is-advised function)
2542 0 : (ad-has-redefining-advice function))
2543 0 : (let* ((origdef (ad-real-orig-definition function))
2544 : ;; Construct the individual pieces that we need for assembly:
2545 0 : (orig-arglist (let ((args (ad-arglist origdef)))
2546 : ;; The arglist may still be unknown.
2547 0 : (if (listp args) args '(&rest args))))
2548 0 : (advised-arglist (or (ad-advised-arglist function)
2549 0 : orig-arglist))
2550 0 : (interactive-form (ad-advised-interactive-form function))
2551 : (orig-form
2552 0 : (ad-map-arglists advised-arglist orig-arglist)))
2553 :
2554 : ;; Finally, build the sucker:
2555 0 : (ad-assemble-advised-definition
2556 0 : advised-arglist
2557 : nil
2558 0 : interactive-form
2559 0 : orig-form
2560 0 : (ad-get-enabled-advices function 'before)
2561 0 : (ad-get-enabled-advices function 'around)
2562 0 : (ad-get-enabled-advices function 'after)))))
2563 :
2564 : (defun ad-assemble-advised-definition
2565 : (args docstring interactive orig &optional befores arounds afters)
2566 : "Assemble the advices into an overall advice function.
2567 : ARGS is the argument list that has to be used,
2568 : DOCSTRING if non-nil defines the documentation of the definition,
2569 : INTERACTIVE if non-nil is the interactive form to be used,
2570 : ORIG is a form that calls the body of the original unadvised function,
2571 : and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
2572 : should be modified. The assembled function will be returned."
2573 : ;; The ad-do-it call should always have the right number of arguments,
2574 : ;; but the compiler might signal a bogus warning because it checks the call
2575 : ;; against the advertised calling convention.
2576 0 : (let ((around-form `(setq ad-return-value (with-no-warnings ,orig)))
2577 : before-forms around-form-protected after-forms definition)
2578 0 : (dolist (advice befores)
2579 0 : (cond ((and (ad-advice-protected advice)
2580 0 : before-forms)
2581 0 : (setq before-forms
2582 0 : `((unwind-protect
2583 0 : ,(macroexp-progn before-forms)
2584 0 : ,@(ad-body-forms
2585 0 : (ad-advice-definition advice))))))
2586 0 : (t (setq before-forms
2587 0 : (append before-forms
2588 0 : (ad-body-forms (ad-advice-definition advice)))))))
2589 :
2590 0 : (dolist (advice (reverse arounds))
2591 : ;; If any of the around advices is protected then we
2592 : ;; protect the complete around advice onion:
2593 0 : (if (ad-advice-protected advice)
2594 0 : (setq around-form-protected t))
2595 0 : (setq around-form
2596 0 : (ad-substitute-tree
2597 0 : (lambda (form) (eq form 'ad-do-it))
2598 0 : (lambda (_form) around-form)
2599 0 : (macroexp-progn (ad-body-forms (ad-advice-definition advice))))))
2600 :
2601 0 : (setq after-forms
2602 0 : (if (and around-form-protected before-forms)
2603 0 : `((unwind-protect
2604 0 : ,(macroexp-progn before-forms)
2605 0 : ,around-form))
2606 0 : (append before-forms (list around-form))))
2607 0 : (dolist (advice afters)
2608 0 : (cond ((and (ad-advice-protected advice)
2609 0 : after-forms)
2610 0 : (setq after-forms
2611 0 : `((unwind-protect
2612 0 : ,(macroexp-progn after-forms)
2613 0 : ,@(ad-body-forms
2614 0 : (ad-advice-definition advice))))))
2615 0 : (t (setq after-forms
2616 0 : (append after-forms
2617 0 : (ad-body-forms (ad-advice-definition advice)))))))
2618 :
2619 0 : (setq definition
2620 0 : `(lambda (ad--addoit-function ,@args)
2621 0 : ,@(if docstring (list docstring))
2622 0 : ,@(if interactive (list interactive))
2623 : (let (ad-return-value)
2624 0 : ,@after-forms
2625 0 : ad-return-value)))
2626 :
2627 0 : (ad-insert-argument-access-forms definition args)))
2628 :
2629 : ;; This is needed for activation/deactivation hooks:
2630 : (defun ad-make-hook-form (function hook-name)
2631 : "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME."
2632 0 : (let ((hook-forms
2633 0 : (mapcar (function (lambda (advice)
2634 0 : (ad-body-forms (ad-advice-definition advice))))
2635 0 : (ad-get-enabled-advices function hook-name))))
2636 0 : (if hook-forms
2637 0 : (macroexp-progn (apply 'append hook-forms)))))
2638 :
2639 :
2640 : ;; @@ Caching:
2641 : ;; ===========
2642 : ;; Generating an advised definition of a function is moderately expensive,
2643 : ;; hence, it makes sense to cache it so we can reuse it in appropriate
2644 : ;; circumstances. Of course, it only makes sense to reuse a cached
2645 : ;; definition if the current advice and function definition state is the
2646 : ;; same as it was at the time when the cached definition was generated.
2647 : ;; For that purpose we associate every cache with an id so we can verify
2648 : ;; if it is still valid at a certain point in time. This id mechanism
2649 : ;; makes it possible to preactivate advised functions, write the compiled
2650 : ;; advised definitions to a file and reuse them during the actual
2651 : ;; activation without having to risk that the resulting definition will be
2652 : ;; incorrect, well, almost.
2653 : ;;
2654 : ;; A cache id is a list with six elements:
2655 : ;; 1) the list of names of enabled before advices
2656 : ;; 2) the list of names of enabled around advices
2657 : ;; 3) the list of names of enabled after advices
2658 : ;; 4) the type of the original function (macro, subr, etc.)
2659 : ;; 5) the arglist of the original definition (or t if it was equal to the
2660 : ;; arglist of the cached definition)
2661 : ;; 6) t if the interactive form of the original definition was equal to the
2662 : ;; interactive form of the cached definition
2663 : ;;
2664 : ;; Here's how a cache can get invalidated or be incorrect:
2665 : ;; A) a piece of advice used in the cache gets redefined
2666 : ;; B) the current list of enabled advices is different from the ones used
2667 : ;; for the cache
2668 : ;; C) the type of the original function changed, e.g., a function became a
2669 : ;; macro, or a subr became a function
2670 : ;; D) the arglist of the original function changed
2671 : ;; E) the interactive form of the original function changed
2672 : ;; F) a piece of advice used in the cache got redefined before the
2673 : ;; defadvice with the cached definition got loaded: This is a PROBLEM!
2674 : ;;
2675 : ;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice'
2676 : ;; which clears the cache in such a case, B is easily checked during
2677 : ;; verification at activation time.
2678 : ;;
2679 : ;; Cases C, D and E have to be considered if one is slightly paranoid, i.e.,
2680 : ;; if one considers the case that the original function could be different
2681 : ;; from the one available at caching time (e.g., for forward advice of
2682 : ;; functions that get redefined by some packages - such as `eval-region' gets
2683 : ;; redefined by edebug). All these cases can be easily checked during
2684 : ;; verification. Element 4 of the id lets one check case C, element 5 takes
2685 : ;; care of case D (using t in the equality case saves some space, because the
2686 : ;; arglist can be recovered at validation time from the cached definition),
2687 : ;; and element 6 takes care of case E which is only a problem if the original
2688 : ;; was actually a function whose interactive form was not overridden by a
2689 : ;; piece of advice.
2690 : ;;
2691 : ;; Case F is the only one which will lead to an incorrect advised function.
2692 : ;; There is no way to avoid this without storing the complete advice definition
2693 : ;; in the cache-id which is not feasible.
2694 : ;;
2695 : ;; The cache-id of a typical advised function with one piece of advice and
2696 : ;; no arglist redefinition takes 7 conses which is a small price to pay for
2697 : ;; the added efficiency. The validation itself is also pretty cheap, certainly
2698 : ;; a lot cheaper than reconstructing an advised definition.
2699 :
2700 : (defmacro ad-get-cache-definition (function)
2701 5 : `(car (ad-get-advice-info-field ,function 'cache)))
2702 :
2703 : (defmacro ad-get-cache-id (function)
2704 4 : `(cdr (ad-get-advice-info-field ,function 'cache)))
2705 :
2706 : (defmacro ad-set-cache (function definition id)
2707 3 : `(ad-set-advice-info-field
2708 3 : ,function 'cache (cons ,definition ,id)))
2709 :
2710 : (defun ad-clear-cache (function)
2711 : "Clears a previously cached advised definition of FUNCTION.
2712 : Clear the cache if you want to force `ad-activate' to construct a new
2713 : advised definition from scratch."
2714 : (interactive
2715 0 : (list (ad-read-advised-function "Clear cached definition of")))
2716 0 : (ad-set-advice-info-field function 'cache nil))
2717 :
2718 : (defun ad-make-cache-id (function)
2719 : "Generate an identifying image of the current advices of FUNCTION."
2720 0 : (let ((original-definition (ad-real-orig-definition function))
2721 0 : (cached-definition (ad-get-cache-definition function)))
2722 0 : (list (mapcar #'ad-advice-name
2723 0 : (ad-get-enabled-advices function 'before))
2724 0 : (mapcar #'ad-advice-name
2725 0 : (ad-get-enabled-advices function 'around))
2726 0 : (mapcar #'ad-advice-name
2727 0 : (ad-get-enabled-advices function 'after))
2728 0 : (ad-definition-type original-definition)
2729 0 : (if (equal (ad-arglist original-definition)
2730 0 : (ad-arglist cached-definition))
2731 : t
2732 0 : (ad-arglist original-definition))
2733 0 : (if (eq (ad-definition-type original-definition) 'function)
2734 0 : (equal (interactive-form original-definition)
2735 0 : (interactive-form cached-definition))))))
2736 :
2737 : (defun ad-get-cache-class-id (function class)
2738 : "Return the part of FUNCTION's cache id that identifies CLASS."
2739 0 : (let ((cache-id (ad-get-cache-id function)))
2740 0 : (if (eq class 'before)
2741 0 : (car cache-id)
2742 0 : (if (eq class 'around)
2743 0 : (nth 1 cache-id)
2744 0 : (nth 2 cache-id)))))
2745 :
2746 : (defun ad-verify-cache-class-id (cache-class-id advices)
2747 0 : (cl-dolist (advice advices (null cache-class-id))
2748 0 : (if (ad-advice-enabled advice)
2749 0 : (if (eq (car cache-class-id) (ad-advice-name advice))
2750 0 : (setq cache-class-id (cdr cache-class-id))
2751 0 : (cl-return nil)))))
2752 :
2753 : ;; There should be a way to monitor if and why a cache verification failed
2754 : ;; in order to determine whether a certain preactivation could be used or
2755 : ;; not. Right now the only way to find out is to trace
2756 : ;; `ad-cache-id-verification-code'. The code it returns indicates where the
2757 : ;; verification failed. Tracing `ad-verify-cache-class-id' might provide
2758 : ;; some additional useful information.
2759 :
2760 : (defun ad-cache-id-verification-code (function)
2761 0 : (let ((cache-id (ad-get-cache-id function))
2762 : (code 'before-advice-mismatch))
2763 0 : (and (ad-verify-cache-class-id
2764 0 : (car cache-id) (ad-get-advice-info-field function 'before))
2765 0 : (setq code 'around-advice-mismatch)
2766 0 : (ad-verify-cache-class-id
2767 0 : (nth 1 cache-id) (ad-get-advice-info-field function 'around))
2768 0 : (setq code 'after-advice-mismatch)
2769 0 : (ad-verify-cache-class-id
2770 0 : (nth 2 cache-id) (ad-get-advice-info-field function 'after))
2771 0 : (setq code 'definition-type-mismatch)
2772 0 : (let ((original-definition (ad-real-orig-definition function))
2773 0 : (cached-definition (ad-get-cache-definition function)))
2774 0 : (and (eq (nth 3 cache-id) (ad-definition-type original-definition))
2775 0 : (setq code 'arglist-mismatch)
2776 0 : (equal (if (eq (nth 4 cache-id) t)
2777 0 : (ad-arglist original-definition)
2778 0 : (nth 4 cache-id) )
2779 0 : (ad-arglist cached-definition))
2780 0 : (setq code 'interactive-form-mismatch)
2781 0 : (or (null (nth 5 cache-id))
2782 0 : (equal (interactive-form original-definition)
2783 0 : (interactive-form cached-definition)))
2784 0 : (setq code 'verified))))
2785 0 : code))
2786 :
2787 : (defun ad-verify-cache-id (function)
2788 : "True if FUNCTION's cache-id is compatible with its current advices."
2789 0 : (eq (ad-cache-id-verification-code function) 'verified))
2790 :
2791 :
2792 : ;; @@ Preactivation:
2793 : ;; =================
2794 : ;; Preactivation can be used to generate compiled advised definitions
2795 : ;; at compile time without having to give up the dynamic runtime flexibility
2796 : ;; of the advice mechanism. Preactivation is a special feature of `defadvice',
2797 : ;; it involves the following steps:
2798 : ;; - remembering the function's current state (definition and advice-info)
2799 : ;; - advising it with the defined piece of advice
2800 : ;; - clearing its cache
2801 : ;; - generating an interpreted advised definition by activating it, this will
2802 : ;; make use of all its current active advice and its current definition
2803 : ;; - saving the so generated cached definition and id
2804 : ;; - resetting the function's advice and definition state to what it was
2805 : ;; before the preactivation
2806 : ;; - Returning the saved definition and its id to be used in the expansion of
2807 : ;; `defadvice' to assign it as an initial cache, hence it will be compiled
2808 : ;; at time the `defadvice' gets compiled.
2809 : ;; Naturally, for preactivation to be effective it has to be applied/compiled
2810 : ;; at the right time, i.e., when the current state of advices and function
2811 : ;; definition exactly reflects the state at activation time. Should that not
2812 : ;; be the case, the precompiled definition will just be discarded and a new
2813 : ;; advised definition will be generated.
2814 :
2815 : (defun ad-preactivate-advice (function advice class position)
2816 : "Preactivate FUNCTION and returns the constructed cache."
2817 0 : (let* ((advicefunname (ad-get-advice-info-field function 'advicefunname))
2818 0 : (old-advice (symbol-function advicefunname))
2819 0 : (old-advice-info (ad-copy-advice-info function))
2820 0 : (ad-advised-functions ad-advised-functions))
2821 0 : (unwind-protect
2822 0 : (progn
2823 0 : (ad-add-advice function advice class position)
2824 0 : (ad-enable-advice function class (ad-advice-name advice))
2825 0 : (ad-clear-cache function)
2826 0 : (ad-activate function -1)
2827 0 : (if (and (ad-is-active function)
2828 0 : (ad-get-cache-definition function))
2829 0 : (list (ad-get-cache-definition function)
2830 0 : (ad-get-cache-id function))))
2831 0 : (ad-set-advice-info function old-advice-info)
2832 0 : (advice-remove function advicefunname)
2833 0 : (if advicefunname (fset advicefunname old-advice))
2834 0 : (if old-advice (advice-add function :around advicefunname)))))
2835 :
2836 :
2837 : ;; @@ Activation and definition handling:
2838 : ;; ======================================
2839 :
2840 : (defun ad-should-compile (function compile)
2841 : "Return non-nil if the advised FUNCTION should be compiled.
2842 : If COMPILE is non-nil and not a negative number then it returns t.
2843 : If COMPILE is a negative number then it returns nil.
2844 : If COMPILE is nil then the result depends on the value of
2845 : `ad-default-compilation-action' (which see)."
2846 0 : (cond
2847 : ;; Don't compile until the real function definition is known (bug#12965).
2848 0 : ((not (ad-real-orig-definition function)) nil)
2849 0 : ((integerp compile) (>= compile 0))
2850 0 : (compile)
2851 0 : ((eq ad-default-compilation-action 'never) nil)
2852 0 : ((eq ad-default-compilation-action 'always) t)
2853 0 : ((eq ad-default-compilation-action 'like-original)
2854 0 : (or (subrp (ad-get-orig-definition function))
2855 0 : (ad-compiled-p (ad-get-orig-definition function))))
2856 : ;; everything else means `maybe':
2857 0 : (t (featurep 'byte-compile))))
2858 :
2859 : (defun ad-activate-advised-definition (function compile)
2860 : "Redefine FUNCTION with its advised definition from cache or scratch.
2861 : The resulting FUNCTION will be compiled if `ad-should-compile' returns t.
2862 : The current definition and its cache-id will be put into the cache."
2863 0 : (let* ((verified-cached-definition
2864 0 : (if (ad-verify-cache-id function)
2865 0 : (ad-get-cache-definition function)))
2866 0 : (advicefunname (ad-get-advice-info-field function 'advicefunname))
2867 0 : (old-ispec (interactive-form advicefunname)))
2868 0 : (fset advicefunname
2869 0 : (or verified-cached-definition
2870 0 : (ad-make-advised-definition function)))
2871 0 : (put advicefunname 'function-documentation
2872 0 : `(ad--make-advised-docstring ',advicefunname))
2873 0 : (unless (equal (interactive-form advicefunname) old-ispec)
2874 : ;; If the interactive-spec of advicefunname has changed, force nadvice to
2875 : ;; refresh its copy.
2876 0 : (advice-remove function advicefunname))
2877 0 : (advice-add function :around advicefunname)
2878 0 : (if (ad-should-compile function compile)
2879 0 : (ad-compile-function function))
2880 0 : (if verified-cached-definition
2881 0 : (if (not (eq verified-cached-definition
2882 0 : (symbol-function advicefunname)))
2883 : ;; we must have compiled, cache the compiled definition:
2884 0 : (ad-set-cache function (symbol-function advicefunname)
2885 0 : (ad-get-cache-id function)))
2886 : ;; We created a new advised definition, cache it with a proper id:
2887 0 : (ad-clear-cache function)
2888 : ;; ad-make-cache-id needs the new cached definition:
2889 0 : (ad-set-cache function (symbol-function advicefunname) nil)
2890 0 : (ad-set-cache
2891 0 : function (symbol-function advicefunname) (ad-make-cache-id function)))))
2892 :
2893 : (defun ad--defalias-fset (fsetfun function newdef)
2894 : ;; Besides ad-redefinition-action we use this defalias-fset-function hook
2895 : ;; for two other reasons:
2896 : ;; - for `activation/deactivation' advices.
2897 : ;; - to rebuild the ad-Advice-* function with the right argument names.
2898 : "Handle re/definition of an advised FUNCTION during de/activation.
2899 : If FUNCTION does not have an original definition associated with it and
2900 : the current definition is usable, then it will be stored as FUNCTION's
2901 : original definition. If no current definition is available (even in the
2902 : case of undefinition) nothing will be done. In the case of redefinition
2903 : the action taken depends on the value of `ad-redefinition-action' (which
2904 : see). Redefinition occurs when FUNCTION already has an original definition
2905 : associated with it but got redefined with a new definition and then
2906 : de/activated. If you do not like the current redefinition action change
2907 : the value of `ad-redefinition-action' and de/activate again."
2908 0 : (let ((original-definition (ad-get-orig-definition function))
2909 0 : (current-definition (ad-get-orig-definition newdef)))
2910 0 : (if original-definition
2911 0 : (if current-definition
2912 0 : (if (not (eq current-definition original-definition))
2913 : ;; We have a redefinition:
2914 0 : (if (not (memq ad-redefinition-action '(accept discard warn)))
2915 0 : (error "ad-redefinition-action: `%s' %s"
2916 0 : function "invalidly redefined")
2917 0 : (if (eq ad-redefinition-action 'discard)
2918 : nil ;; Just drop it!
2919 0 : (funcall (or fsetfun #'fset) function newdef)
2920 0 : (ad-activate-internal function)
2921 0 : (if (eq ad-redefinition-action 'warn)
2922 0 : (message "ad-handle-definition: `%s' got redefined"
2923 0 : function))))
2924 : ;; either advised def or correct original is in place:
2925 0 : nil)
2926 : ;; We have an undefinition, ignore it:
2927 0 : (funcall (or fsetfun #'fset) function newdef))
2928 0 : (funcall (or fsetfun #'fset) function newdef)
2929 0 : (when current-definition (ad-activate-internal function)))))
2930 :
2931 :
2932 : ;; @@ The top-level advice interface:
2933 : ;; ==================================
2934 :
2935 : ;;;###autoload
2936 : (defun ad-activate (function &optional compile)
2937 : "Activate all the advice information of an advised FUNCTION.
2938 : If FUNCTION has a proper original definition then an advised
2939 : definition will be generated from FUNCTION's advice info and the
2940 : definition of FUNCTION will be replaced with it. If a previously
2941 : cached advised definition was available, it will be used.
2942 : The optional COMPILE argument determines whether the resulting function
2943 : or a compilable cached definition will be compiled. If it is negative
2944 : no compilation will be performed, if it is positive or otherwise non-nil
2945 : the resulting function will be compiled, if it is nil the behavior depends
2946 : on the value of `ad-default-compilation-action' (which see).
2947 : Activation of an advised function that has an advice info but no actual
2948 : pieces of advice is equivalent to a call to `ad-unadvise'. Activation of
2949 : an advised function that has actual pieces of advice but none of them are
2950 : enabled is equivalent to a call to `ad-deactivate'. The current advised
2951 : definition will always be cached for later usage."
2952 : (interactive
2953 0 : (list (ad-read-advised-function "Activate advice of")
2954 0 : current-prefix-arg))
2955 0 : (cond
2956 0 : ((not (ad-is-advised function))
2957 0 : (error "ad-activate: `%s' is not advised" function))
2958 : ;; Just return for forward advised and not yet defined functions:
2959 0 : ((not (ad-get-orig-definition function)) nil)
2960 0 : ((not (ad-has-any-advice function)) (ad-unadvise function))
2961 : ;; Otherwise activate the advice:
2962 0 : ((ad-has-redefining-advice function)
2963 0 : (ad-activate-advised-definition function compile)
2964 0 : (ad-set-advice-info-field function 'active t)
2965 0 : (eval (ad-make-hook-form function 'activation))
2966 0 : function)
2967 : ;; Here we are if we have all disabled advices:
2968 0 : (t (ad-deactivate function))))
2969 :
2970 : (defalias 'ad-activate-on 'ad-activate)
2971 :
2972 : (defun ad-deactivate (function)
2973 : "Deactivate the advice of an actively advised FUNCTION.
2974 : If FUNCTION has a proper original definition, then the current
2975 : definition of FUNCTION will be replaced with it. All the advice
2976 : information will still be available so it can be activated again with
2977 : a call to `ad-activate'."
2978 : (interactive
2979 0 : (list (ad-read-advised-function "Deactivate advice of" 'ad-is-active)))
2980 0 : (if (not (ad-is-advised function))
2981 0 : (error "ad-deactivate: `%s' is not advised" function)
2982 0 : (cond ((ad-is-active function)
2983 0 : (if (not (ad-get-orig-definition function))
2984 0 : (error "ad-deactivate: `%s' has no original definition"
2985 0 : function)
2986 0 : (ad-clear-advicefunname-definition function)
2987 0 : (ad-set-advice-info-field function 'active nil)
2988 0 : (eval (ad-make-hook-form function 'deactivation))
2989 0 : function)))))
2990 :
2991 : (defun ad-update (function &optional compile)
2992 : "Update the advised definition of FUNCTION if its advice is active.
2993 : See `ad-activate' for documentation on the optional COMPILE argument."
2994 : (interactive
2995 0 : (list (ad-read-advised-function
2996 0 : "Update advised definition of" 'ad-is-active)))
2997 0 : (if (ad-is-active function)
2998 0 : (ad-activate function compile)))
2999 :
3000 : (defun ad-unadvise (function)
3001 : "Deactivate FUNCTION and then remove all its advice information.
3002 : If FUNCTION was not advised this will be a noop."
3003 : (interactive
3004 0 : (list (ad-read-advised-function "Unadvise function")))
3005 42 : (cond ((ad-is-advised function)
3006 0 : (if (ad-is-active function)
3007 0 : (ad-deactivate function))
3008 0 : (ad-clear-advicefunname-definition function)
3009 0 : (ad-set-advice-info function nil)
3010 42 : (ad-pop-advised-function function))))
3011 :
3012 : (defun ad-recover (function)
3013 : "Try to recover FUNCTION's original definition, and unadvise it.
3014 : This is more low-level than `ad-unadvise' in that it does not do
3015 : deactivation, which might run hooks and get into other trouble.
3016 : Use in emergencies."
3017 : ;; Use more primitive interactive behavior here: Accept any symbol that's
3018 : ;; currently defined in obarray, not necessarily with a function definition:
3019 : (interactive
3020 0 : (list (intern
3021 0 : (completing-read "Recover advised function: " obarray nil t))))
3022 0 : (cond ((ad-is-advised function)
3023 0 : (ad-clear-advicefunname-definition function)
3024 0 : (ad-set-advice-info function nil)
3025 0 : (ad-pop-advised-function function))))
3026 :
3027 : (defun ad-activate-regexp (regexp &optional compile)
3028 : "Activate functions with an advice name containing a REGEXP match.
3029 : This activates the advice for each function
3030 : that has at least one piece of advice whose name includes a match for REGEXP.
3031 : See `ad-activate' for documentation on the optional COMPILE argument."
3032 : (interactive
3033 0 : (list (ad-read-regexp "Activate via advice regexp")
3034 0 : current-prefix-arg))
3035 0 : (ad-do-advised-functions (function)
3036 : (if (ad-find-some-advice function 'any regexp)
3037 0 : (ad-activate function compile))))
3038 :
3039 : (defun ad-deactivate-regexp (regexp)
3040 : "Deactivate functions with an advice name containing REGEXP match.
3041 : This deactivates the advice for each function
3042 : that has at least one piece of advice whose name includes a match for REGEXP."
3043 : (interactive
3044 0 : (list (ad-read-regexp "Deactivate via advice regexp")))
3045 0 : (ad-do-advised-functions (function)
3046 : (if (ad-find-some-advice function 'any regexp)
3047 0 : (ad-deactivate function))))
3048 :
3049 : (defun ad-update-regexp (regexp &optional compile)
3050 : "Update functions with an advice name containing a REGEXP match.
3051 : This reactivates the advice for each function
3052 : that has at least one piece of advice whose name includes a match for REGEXP.
3053 : See `ad-activate' for documentation on the optional COMPILE argument."
3054 : (interactive
3055 0 : (list (ad-read-regexp "Update via advice regexp")
3056 0 : current-prefix-arg))
3057 0 : (ad-do-advised-functions (function)
3058 : (if (ad-find-some-advice function 'any regexp)
3059 0 : (ad-update function compile))))
3060 :
3061 : (defun ad-activate-all (&optional compile)
3062 : "Activate all currently advised functions.
3063 : See `ad-activate' for documentation on the optional COMPILE argument."
3064 : (interactive "P")
3065 0 : (ad-do-advised-functions (function)
3066 0 : (ad-activate function compile)))
3067 :
3068 : (defun ad-deactivate-all ()
3069 : "Deactivate all currently advised functions."
3070 : (interactive)
3071 0 : (ad-do-advised-functions (function)
3072 0 : (ad-deactivate function)))
3073 :
3074 : (defun ad-update-all (&optional compile)
3075 : "Update all currently advised functions.
3076 : With prefix argument, COMPILE resulting advised definitions."
3077 : (interactive "P")
3078 0 : (ad-do-advised-functions (function)
3079 0 : (ad-update function compile)))
3080 :
3081 : (defun ad-unadvise-all ()
3082 : "Unadvise all currently advised functions."
3083 : (interactive)
3084 0 : (ad-do-advised-functions (function)
3085 0 : (ad-unadvise function)))
3086 :
3087 : (defun ad-recover-all ()
3088 : "Recover all currently advised functions. Use in emergencies.
3089 : To recover a function means to try to find its original (pre-advice)
3090 : definition, and delete all advice.
3091 : This is more low-level than `ad-unadvise' in that it does not do
3092 : deactivation, which might run hooks and get into other trouble."
3093 : (interactive)
3094 0 : (ad-do-advised-functions (function)
3095 : (condition-case nil
3096 : (ad-recover function)
3097 0 : (error nil))))
3098 :
3099 :
3100 : ;; Completion alist of valid `defadvice' flags
3101 : (defvar ad-defadvice-flags
3102 : '(("protect") ("disable") ("activate")
3103 : ("compile") ("preactivate")))
3104 :
3105 : ;;;###autoload
3106 : (defmacro defadvice (function args &rest body)
3107 : "Define a piece of advice for FUNCTION (a symbol).
3108 : The syntax of `defadvice' is as follows:
3109 :
3110 : (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3111 : [DOCSTRING] [INTERACTIVE-FORM]
3112 : BODY...)
3113 :
3114 : FUNCTION ::= Name of the function to be advised.
3115 : CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.
3116 : NAME ::= Non-nil symbol that names this piece of advice.
3117 : POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first',
3118 : see also `ad-add-advice'.
3119 : ARGLIST ::= An optional argument list to be used for the advised function
3120 : instead of the argument list of the original. The first one found in
3121 : before/around/after-advices will be used.
3122 : FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'.
3123 : All flags can be specified with unambiguous initial substrings.
3124 : DOCSTRING ::= Optional documentation for this piece of advice.
3125 : INTERACTIVE-FORM ::= Optional interactive form to be used for the advised
3126 : function. The first one found in before/around/after-advices will be used.
3127 : BODY ::= Any s-expression.
3128 :
3129 : Semantics of the various flags:
3130 : `protect': The piece of advice will be protected against non-local exits in
3131 : any code that precedes it. If any around-advice of a function is protected
3132 : then automatically all around-advices will be protected (the complete onion).
3133 :
3134 : `activate': All advice of FUNCTION will be activated immediately if
3135 : FUNCTION has been properly defined prior to this application of `defadvice'.
3136 :
3137 : `compile': In conjunction with `activate' specifies that the resulting
3138 : advised function should be compiled.
3139 :
3140 : `disable': The defined advice will be disabled, hence, it will not be used
3141 : during activation until somebody enables it.
3142 :
3143 : `preactivate': Preactivates the advised FUNCTION at macro-expansion/compile
3144 : time. This generates a compiled advised definition according to the current
3145 : advice state that will be used during activation if appropriate. Only use
3146 : this if the `defadvice' gets actually compiled.
3147 :
3148 : usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3149 : [DOCSTRING] [INTERACTIVE-FORM]
3150 : BODY...)"
3151 : (declare (doc-string 3) (indent 2)
3152 : (debug (&define name ;; thing being advised.
3153 : (name ;; class is [&or "before" "around" "after"
3154 : ;; "activation" "deactivation"]
3155 : name ;; name of advice
3156 : &rest sexp ;; optional position and flags
3157 : )
3158 : [&optional stringp]
3159 : [&optional ("interactive" interactive)]
3160 : def-body)))
3161 1 : (if (not (ad-name-p function))
3162 1 : (error "defadvice: Invalid function name: %s" function))
3163 1 : (let* ((class (car args))
3164 1 : (name (if (not (ad-class-p class))
3165 0 : (error "defadvice: Invalid advice class: %s" class)
3166 1 : (nth 1 args)))
3167 1 : (position (if (not (ad-name-p name))
3168 0 : (error "defadvice: Invalid advice name: %s" name)
3169 1 : (setq args (nthcdr 2 args))
3170 1 : (if (ad-position-p (car args))
3171 0 : (prog1 (car args)
3172 1 : (setq args (cdr args))))))
3173 1 : (arglist (if (listp (car args))
3174 0 : (prog1 (car args)
3175 1 : (setq args (cdr args)))))
3176 : (flags
3177 1 : (mapcar
3178 1 : (function
3179 : (lambda (flag)
3180 1 : (let ((completion
3181 1 : (try-completion (symbol-name flag) ad-defadvice-flags)))
3182 1 : (cond ((eq completion t) flag)
3183 0 : ((assoc completion ad-defadvice-flags)
3184 0 : (intern completion))
3185 0 : (t (error "defadvice: Invalid or ambiguous flag: %s"
3186 2 : flag))))))
3187 1 : args))
3188 1 : (advice (ad-make-advice
3189 1 : name (memq 'protect flags)
3190 1 : (not (memq 'disable flags))
3191 1 : `(advice lambda ,arglist ,@body)))
3192 1 : (preactivation (if (memq 'preactivate flags)
3193 0 : (ad-preactivate-advice
3194 1 : function advice class position))))
3195 : ;; Now for the things to be done at evaluation time:
3196 1 : `(progn
3197 1 : (ad-add-advice ',function ',advice ',class ',position)
3198 1 : ,@(if preactivation
3199 0 : `((ad-set-cache
3200 0 : ',function
3201 : ;; the function will get compiled:
3202 0 : ,(cond ((macrop (car preactivation))
3203 0 : `(ad-macrofy
3204 : (function
3205 0 : ,(ad-lambdafy
3206 0 : (car preactivation)))))
3207 0 : (t `(function
3208 0 : ,(car preactivation))))
3209 1 : ',(car (cdr preactivation)))))
3210 1 : ,@(if (memq 'activate flags)
3211 1 : `((ad-activate ',function
3212 1 : ,(if (memq 'compile flags) t))))
3213 1 : ',function)))
3214 :
3215 :
3216 : ;; @@ Tools:
3217 : ;; =========
3218 :
3219 : (defmacro ad-with-originals (functions &rest body)
3220 : "Binds FUNCTIONS to their original definitions and execute BODY.
3221 : For any members of FUNCTIONS that are not currently advised the rebinding will
3222 : be a noop. Any modifications done to the definitions of FUNCTIONS will be
3223 : undone on exit of this macro."
3224 : (declare (indent 1))
3225 0 : (let* ((index -1)
3226 : ;; Make let-variables to store current definitions:
3227 : (current-bindings
3228 0 : (mapcar (function
3229 : (lambda (function)
3230 0 : (setq index (1+ index))
3231 0 : (list (intern (format "ad-oRiGdEf-%d" index))
3232 0 : `(symbol-function ',function))))
3233 0 : functions)))
3234 0 : `(let ,current-bindings
3235 : (unwind-protect
3236 : (progn
3237 0 : ,@(progn
3238 : ;; Make forms to redefine functions to their
3239 : ;; original definitions if they are advised:
3240 0 : (setq index -1)
3241 0 : (mapcar (lambda (function)
3242 0 : (setq index (1+ index))
3243 0 : `(fset ',function
3244 0 : (or (ad-get-orig-definition ',function)
3245 0 : ,(car (nth index current-bindings)))))
3246 0 : functions))
3247 0 : ,@body)
3248 0 : ,@(progn
3249 : ;; Make forms to back-define functions to the definitions
3250 : ;; they had outside this macro call:
3251 0 : (setq index -1)
3252 0 : (mapcar (lambda (function)
3253 0 : (setq index (1+ index))
3254 0 : `(fset ',function
3255 0 : ,(car (nth index current-bindings))))
3256 0 : functions))))))
3257 :
3258 :
3259 : ;; @@ Starting, stopping and recovering from the advice package magic:
3260 : ;; ===================================================================
3261 :
3262 : (defun ad-recover-normality ()
3263 : "Undo all advice related redefinitions and unadvises everything.
3264 : Use only in REAL emergencies."
3265 : (interactive)
3266 0 : (ad-recover-all)
3267 0 : (ad-do-advised-functions (function)
3268 : (message "Oops! Left over advised function %S" function)
3269 0 : (ad-pop-advised-function function)))
3270 :
3271 : (provide 'advice)
3272 :
3273 : ;;; advice.el ends here
|