1 ;;; advice.el --- an overloading mechanism for Emacs Lisp functions
3 ;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
8 ;; Created: 12 Dec 1992
9 ;; Keywords: extensions, lisp, tools
11 ;; This file is part of GNU Emacs.
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, or (at your option)
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.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
29 ;; advice|Hans Chalupsky|hans@cs.buffalo.edu|
30 ;; Overloading mechanism for Emacs Lisp functions|
31 ;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z|
36 ;; NOTE: This documentation is slightly out of date. In particular, all the
37 ;; references to Emacs-18 are obsolete now, because it is not any longer
38 ;; supported by this version of Advice.
40 ;; Advice is documented in the Emacs Lisp Manual.
44 ;; This package implements a full-fledged Lisp-style advice mechanism
45 ;; for Emacs Lisp. Advice is a clean and efficient way to modify the
46 ;; behavior of Emacs Lisp functions without having to keep personal
47 ;; modified copies of such functions around. A great number of such
48 ;; modifications can be achieved by treating the original function as a
49 ;; black box and specifying a different execution environment for it
50 ;; with a piece of advice. Think of a piece of advice as a kind of fancy
51 ;; hook that you can attach to any function/macro/subr.
55 ;; - Clean definition of multiple, named before/around/after advices
56 ;; for functions, macros, subrs and special forms
57 ;; - Full control over the arguments an advised function will receive,
58 ;; the binding environment in which it will be executed, as well as the
59 ;; value it will return.
60 ;; - Allows re/definition of interactive behavior for functions and subrs
61 ;; - Every piece of advice can have its documentation string which will be
62 ;; combined with the original documentation of the advised function at
63 ;; call-time of `documentation' for proper command-key substitution.
64 ;; - The execution of every piece of advice can be protected against error
65 ;; and non-local exits in preceding code or advices.
66 ;; - Simple argument access either by name, or, more portable but as
67 ;; efficient, via access macros
68 ;; - Allows the specification of a different argument list for the advised
69 ;; version of a function.
70 ;; - Advised functions can be byte-compiled either at file-compile time
71 ;; (see preactivation) or activation time.
72 ;; - Separation of advice definition and activation
73 ;; - Forward advice is possible, that is
74 ;; as yet undefined or autoload functions can be advised without having to
75 ;; preload the file in which they are defined.
76 ;; - Forward redefinition is possible because around advice can be used to
77 ;; completely redefine a function.
78 ;; - A caching mechanism for advised definition provides for cheap deactivation
79 ;; and reactivation of advised functions.
80 ;; - Preactivation allows efficient construction and compilation of advised
81 ;; definitions at file compile time without giving up the flexibility of
82 ;; the advice mechanism.
83 ;; - En/disablement mechanism allows the use of different "views" of advised
84 ;; functions depending on what pieces of advice are currently en/disabled
85 ;; - Provides manipulation mechanisms for sets of advised functions via
86 ;; regular expressions that match advice names
88 ;; @ How to get Advice for Emacs-18:
89 ;; =================================
90 ;; `advice18.el', a version of Advice that also works in Emacs-18 is available
91 ;; either via anonymous ftp from `ftp.cs.buffalo.edu (128.205.32.9)' with
92 ;; pathname `/pub/Emacs/advice18.el', or from one of the Emacs Lisp archive
93 ;; sites, or send email to <hans@cs.buffalo.edu> and I'll mail it to you.
95 ;; @ Overview, or how to read this file:
96 ;; =====================================
97 ;; NOTE: This documentation is slightly out of date. In particular, all the
98 ;; references to Emacs-18 are obsolete now, because it is not any longer
99 ;; supported by this version of Advice. An up-to-date version will soon be
100 ;; available as an info file (thanks to the kind help of Jack Vinson and
101 ;; David M. Smith). Until then you can use `outline-mode' to help you read
102 ;; this documentation (set `outline-regexp' to `";; @+"').
104 ;; The four major sections of this file are:
106 ;; @ This initial information ...installation, customization etc.
107 ;; @ Advice documentation: ...general documentation
108 ;; @ Foo games: An advice tutorial ...teaches about Advice by example
109 ;; @ Advice implementation: ...actual code, yeah!!
111 ;; The latter three are actual headings which you can search for
112 ;; directly in case `outline-mode' doesn't work for you.
116 ;; - This version of Advice only works for Emacs 19.26 and later. It uses
117 ;; new versions of the built-in functions `fset/defalias' which are not
118 ;; yet available in Lucid Emacs, hence, it won't work there.
119 ;; - Advised functions/macros/subrs will only exhibit their advised behavior
120 ;; when they are invoked via their function cell. This means that advice will
121 ;; not work for the following:
122 ;; + advised subrs that are called directly from other subrs or C-code
123 ;; + advised subrs that got replaced with their byte-code during
124 ;; byte-compilation (e.g., car)
125 ;; + advised macros which were expanded during byte-compilation before
126 ;; their advice was activated.
130 ;; This package is an extension and generalization of packages such as
131 ;; insert-hooks.el written by Noah S. Friedman, and advise.el written by
132 ;; Raul J. Acevedo. Some ideas used in here come from these packages,
133 ;; others come from the various Lisp advice mechanisms I've come across
134 ;; so far, and a few are simply mine.
136 ;; @ Comments, suggestions, bug reports:
137 ;; =====================================
138 ;; If you find any bugs, have suggestions for new advice features, find the
139 ;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory,
140 ;; have any questions about Advice, or have otherwise enlightening
141 ;; comments feel free to send me email at <hans@cs.buffalo.edu>.
143 ;; @ Safety Rules and Emergency Exits:
144 ;; ===================================
145 ;; Before we begin: CAUTION!!
146 ;; Advice provides you with a lot of rope to hang yourself on very
147 ;; easily accessible trees, so, here are a few important things you
148 ;; should know: Once Advice has been started with `ad-start-advice'
149 ;; (which happens automatically when you load this file), it
150 ;; generates an advised definition of the `documentation' function, and
151 ;; it will enable automatic advice activation when functions get defined.
152 ;; All of this can be undone at any time with `M-x ad-stop-advice'.
154 ;; If you experience any strange behavior/errors etc. that you attribute to
155 ;; Advice or to some ill-advised function do one of the following:
157 ;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what
158 ;; function gives you problems)
159 ;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong)
160 ;; - M-x ad-stop-advice (if you think the problem is related to the
161 ;; advised functions used by Advice itself)
162 ;; - M-x ad-recover-normality (for real emergencies)
163 ;; - If none of the above solves your Advice-related problem go to another
164 ;; terminal, kill your Emacs process and send me some hate mail.
166 ;; The first three measures have restarts, i.e., once you've figured out
167 ;; the problem you can reactivate advised functions with either `ad-activate',
168 ;; `ad-activate-all', or `ad-start-advice'. `ad-recover-normality' unadvises
169 ;; everything so you won't be able to reactivate any advised functions, you'll
170 ;; have to stick with their standard incarnations for the rest of the session.
172 ;; IMPORTANT: With Advice loaded always do `M-x ad-deactivate-all' before
173 ;; you byte-compile a file, because advised special forms and macros can lead
174 ;; to unwanted compilation results. When you are done compiling use
175 ;; `M-x ad-activate-all' to go back to the advised state of all your
176 ;; advised functions.
178 ;; RELAX: Advice is pretty safe even if you are oblivious to the above.
179 ;; I use it extensively and haven't run into any serious trouble in a long
180 ;; time. Just wanted you to be warned.
185 ;; Look at the documentation of `ad-redefinition-action' for possible values
186 ;; of this variable. Its default value is `warn' which will print a warning
187 ;; message when an already defined advised function gets redefined with a
188 ;; new original definition and de/activated.
190 ;; Look at the documentation of `ad-default-compilation-action' for possible
191 ;; values of this variable. Its default value is `maybe' which will compile
192 ;; advised definitions during activation in case the byte-compiler is already
193 ;; loaded. Otherwise, it will leave them uncompiled.
197 ;; Before I go on explaining how advice works, here are four simple examples
198 ;; how this package can be used. The first three are very useful, the last one
201 ;;(defadvice switch-to-buffer (before existing-buffers-only activate)
202 ;; "When called interactively switch to existing buffers only, unless
203 ;;when called with a prefix argument."
205 ;; (list (read-buffer "Switch to buffer: " (other-buffer)
206 ;; (null current-prefix-arg)))))
208 ;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate)
209 ;; "Switch to non-existing buffers only upon confirmation."
210 ;; (interactive "BSwitch to buffer: ")
211 ;; (if (or (get-buffer (ad-get-arg 0))
212 ;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0))))
215 ;;(defadvice find-file (before existing-files-only activate)
216 ;; "Find existing files only"
217 ;; (interactive "fFind file: "))
219 ;;(defadvice car (around interactive activate)
220 ;; "Make `car' an interactive function."
221 ;; (interactive "xCar of list: ")
223 ;; (if (interactive-p)
224 ;; (message "%s" ad-return-value)))
227 ;; @ Advice documentation:
228 ;; =======================
229 ;; Below is general documentation of the various features of advice. For more
230 ;; concrete examples check the corresponding sections in the tutorial part.
234 ;; - Emacs, Emacs-19: Emacs as released by the GNU Project
235 ;; - Lemacs: Lucid's version of Emacs with major version 19
236 ;; - v18: Any Emacs with major version 18 or built as an extension to that
238 ;; - v19: Any Emacs with major version 19
239 ;; - jwz: Jamie Zawinski - former keeper of Lemacs and creator of the optimizing
240 ;; byte-compiler used in v19s.
241 ;; - Advice: The name of this package.
242 ;; - advices: Short for "pieces of advice".
244 ;; @@ Defining a piece of advice with `defadvice':
245 ;; ===============================================
246 ;; The main means of defining a piece of advice is the macro `defadvice',
247 ;; there is no interactive way of specifying a piece of advice. A call to
248 ;; `defadvice' has the following syntax which is similar to the syntax of
251 ;; (defadvice <function> (<class> <name> [<position>] [<arglist>] {<flags>}*)
252 ;; [ [<documentation-string>] [<interactive-form>] ]
255 ;; <function> is the name of the function/macro/subr to be advised.
257 ;; <class> is the class of the advice which has to be one of `before',
258 ;; `around', `after', `activation' or `deactivation' (the last two allow
259 ;; definition of special act/deactivation hooks).
261 ;; <name> is the name of the advice which has to be a non-nil symbol.
262 ;; Names uniquely identify a piece of advice in a certain advice class,
263 ;; hence, advices can be redefined by defining an advice with the same class
264 ;; and name. Advice names are global symbols, hence, the same name space
265 ;; conventions used for function names should be applied.
267 ;; An optional <position> specifies where in the current list of advices of
268 ;; the specified <class> this new advice will be placed. <position> has to
269 ;; be either `first', `last' or a number that specifies a zero-based
270 ;; position (`first' is equivalent to 0). If no position is specified
271 ;; `first' will be used as a default. If this call to `defadvice' redefines
272 ;; an already existing advice (see above) then the position argument will
273 ;; be ignored and the position of the already existing advice will be used.
275 ;; An optional <arglist> which has to be a list can be used to define the
276 ;; argument list of the advised function. This argument list should of
277 ;; course be compatible with the argument list of the original function,
278 ;; otherwise functions that call the advised function with the original
279 ;; argument list in mind will break. If more than one advice specify an
280 ;; argument list then the first one (the one with the smallest position)
281 ;; found in the list of before/around/after advices will be used.
283 ;; <flags> is a list of symbols that specify further information about the
284 ;; advice. All flags can be specified with unambiguous initial substrings.
285 ;; `activate': Specifies that the advice information of the advised
286 ;; function should be activated right after this advice has been
287 ;; defined. In forward advices `activate' will be ignored.
288 ;; `protect': Specifies that this advice should be protected against
289 ;; non-local exits and errors in preceding code/advices.
290 ;; `compile': Specifies that the advised function should be byte-compiled.
291 ;; This flag will be ignored unless `activate' is also specified.
292 ;; `disable': Specifies that the defined advice should be disabled, hence,
293 ;; it will not be used in an activation until somebody enables it.
294 ;; `preactivate': Specifies that the advised function should get preactivated
295 ;; at macro-expansion/compile time of this `defadvice'. This
296 ;; generates a compiled advised definition according to the
297 ;; current advice state which will be used during activation
298 ;; if appropriate. Only use this if the `defadvice' gets
299 ;; actually compiled (with a v18 byte-compiler put the `defadvice'
300 ;; into the body of a `defun' to accomplish proper compilation).
302 ;; An optional <documentation-string> can be supplied to document the advice.
303 ;; On call of the `documentation' function it will be combined with the
304 ;; documentation strings of the original function and other advices.
306 ;; An optional <interactive-form> form can be supplied to change/add
307 ;; interactive behavior of the original function. If more than one advice
308 ;; has an `(interactive ...)' specification then the first one (the one
309 ;; with the smallest position) found in the list of before/around/after
310 ;; advices will be used.
312 ;; A possibly empty list of <body-forms> specifies the body of the advice in
313 ;; an implicit progn. The body of an advice can access/change arguments,
314 ;; the return value, the binding environment, and can have all sorts of
315 ;; other side effects.
317 ;; @@ Assembling advised definitions:
318 ;; ==================================
319 ;; Suppose a function/macro/subr/special-form has N pieces of before advice,
320 ;; M pieces of around advice and K pieces of after advice. Assuming none of
321 ;; the advices is protected, its advised definition will look like this
322 ;; (body-form indices correspond to the position of the respective advice in
323 ;; that advice class):
325 ;; ([macro] lambda <arglist>
326 ;; [ [<advised-docstring>] [(interactive ...)] ]
327 ;; (let (ad-return-value)
328 ;; {<before-0-body-form>}*
330 ;; {<before-N-1-body-form>}*
331 ;; {<around-0-body-form>}*
332 ;; {<around-1-body-form>}*
334 ;; {<around-M-1-body-form>}*
335 ;; (setq ad-return-value
336 ;; <apply original definition to <arglist>>)
337 ;; {<other-around-M-1-body-form>}*
339 ;; {<other-around-1-body-form>}*
340 ;; {<other-around-0-body-form>}*
341 ;; {<after-0-body-form>}*
343 ;; {<after-K-1-body-form>}*
346 ;; Macros and special forms will be redefined as macros, hence the optional
347 ;; [macro] in the beginning of the definition.
349 ;; <arglist> is either the argument list of the original function or the
350 ;; first argument list defined in the list of before/around/after advices.
351 ;; The values of <arglist> variables can be accessed/changed in the body of
352 ;; an advice by simply referring to them by their original name, however,
353 ;; more portable argument access macros are also provided (see below). For
354 ;; subrs/special-forms for which neither explicit argument list definitions
355 ;; are available, nor their documentation strings contain such definitions
356 ;; (as they do v19s), `(&rest ad-subr-args)' will be used.
358 ;; <advised-docstring> is an optional, special documentation string which will
359 ;; be expanded into a proper documentation string upon call of `documentation'.
361 ;; (interactive ...) is an optional interactive form either taken from the
362 ;; original function or from a before/around/after advice. For advised
363 ;; interactive subrs that do not have an interactive form specified in any
364 ;; advice we have to use (interactive) and then call the subr interactively
365 ;; if the advised function was called interactively, because the
366 ;; interactive specification of subrs is not accessible. This is the only
367 ;; case where changing the values of arguments will not have an affect
368 ;; because they will be reset by the interactive specification of the subr.
369 ;; If this is a problem one can always specify an interactive form in a
370 ;; before/around/after advice to gain control over argument values that
371 ;; were supplied interactively.
373 ;; Then the body forms of the various advices in the various classes of advice
374 ;; are assembled in order. The forms of around advice L are normally part of
375 ;; one of the forms of around advice L-1. An around advice can specify where
376 ;; the forms of the wrapped or surrounded forms should go with the special
377 ;; keyword `ad-do-it', which will be substituted with a `progn' containing the
378 ;; forms of the surrounded code.
380 ;; The innermost part of the around advice onion is
381 ;; <apply original definition to <arglist>>
382 ;; whose form depends on the type of the original function. The variable
383 ;; `ad-return-value' will be set to its result. This variable is visible to
384 ;; all pieces of advice which can access and modify it before it gets returned.
386 ;; The semantic structure of advised functions that contain protected pieces
387 ;; of advice is the same. The only difference is that `unwind-protect' forms
388 ;; make sure that the protected advice gets executed even if some previous
389 ;; piece of advice had an error or a non-local exit. If any around advice is
390 ;; protected then the whole around advice onion will be protected.
392 ;; @@ Argument access in advised functions:
393 ;; ========================================
394 ;; As already mentioned, the simplest way to access the arguments of an
395 ;; advised function in the body of an advice is to refer to them by name. To
396 ;; do that, the advice programmer needs to know either the names of the
397 ;; argument variables of the original function, or the names used in the
398 ;; argument list redefinition given in a piece of advice. While this simple
399 ;; method might be sufficient in many cases, it has the disadvantage that it
400 ;; is not very portable because it hardcodes the argument names into the
401 ;; advice. If the definition of the original function changes the advice
402 ;; might break even though the code might still be correct. Situations like
403 ;; that arise, for example, if one advises a subr like `eval-region' which
404 ;; gets redefined in a non-advice style into a function by the edebug
405 ;; package. If the advice assumes `eval-region' to be a subr it might break
406 ;; once edebug is loaded. Similar situations arise when one wants to use the
407 ;; same piece of advice across different versions of Emacs. Some subrs in a
408 ;; v18 Emacs are functions in v19 and vice versa, but for the most part the
409 ;; semantics remain the same, hence, the same piece of advice might be usable
410 ;; in both Emacs versions.
412 ;; As a solution to that advice provides argument list access macros that get
413 ;; translated into the proper access forms at activation time, i.e., when the
414 ;; advised definition gets constructed. Access macros access actual arguments
415 ;; by position regardless of how these actual argument get distributed onto
416 ;; the argument variables of a function. The rational behind this is that in
417 ;; Emacs Lisp the semantics of an argument is strictly determined by its
418 ;; position (there are no keyword arguments).
420 ;; Suppose the function `foo' is defined as
422 ;; (defun foo (x y &optional z &rest r) ....)
424 ;; and is then called with
426 ;; (foo 0 1 2 3 4 5 6)
428 ;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that
429 ;; the semantics of an actual argument is determined by its position. It is
430 ;; this semantics that has to be known by the advice programmer. Then s/he
431 ;; can access these arguments in a piece of advice with some of the
432 ;; following macros (the arrows indicate what value they will return):
434 ;; (ad-get-arg 0) -> 0
435 ;; (ad-get-arg 1) -> 1
436 ;; (ad-get-arg 2) -> 2
437 ;; (ad-get-arg 3) -> 3
438 ;; (ad-get-args 2) -> (2 3 4 5 6)
439 ;; (ad-get-args 4) -> (4 5 6)
441 ;; `(ad-get-arg <position>)' will return the actual argument that was supplied
442 ;; at <position>, `(ad-get-args <position>)' will return the list of actual
443 ;; arguments supplied starting at <position>. Note that these macros can be
444 ;; used without any knowledge about the form of the actual argument list of
445 ;; the original function.
447 ;; Similarly, `(ad-set-arg <position> <value-form>)' can be used to set the
448 ;; value of the actual argument at <position> to <value-form>. For example,
450 ;; (ad-set-arg 5 "five")
452 ;; will have the effect that R=(3 4 "five" 6) once the original function is
453 ;; called. `(ad-set-args <position> <value-list-form>)' can be used to set
454 ;; the list of actual arguments starting at <position> to <value-list-form>.
457 ;; (ad-set-args 0 '(5 4 3 2 1 0))
459 ;; will have the effect that X=5, Y=4, Z=3 and R=(2 1 0) once the original
460 ;; function is called.
462 ;; All these access macros are text macros rather than real Lisp macros. When
463 ;; the advised definition gets constructed they get replaced with actual access
464 ;; forms depending on the argument list of the advised function, i.e., after
465 ;; that argument access is in most cases as efficient as using the argument
466 ;; variable names directly.
468 ;; @@@ Accessing argument bindings of arbitrary functions:
469 ;; =======================================================
470 ;; Some functions (such as `trace-function' defined in trace.el) need a
471 ;; method of accessing the names and bindings of the arguments of an
472 ;; arbitrary advised function. To do that within an advice one can use the
473 ;; special keyword `ad-arg-bindings' which is a text macro that will be
474 ;; substituted with a form that will evaluate to a list of binding
475 ;; specifications, one for every argument variable. These binding
476 ;; specifications can then be examined in the body of the advice. For
477 ;; example, somewhere in an advice we could do this:
479 ;; (let* ((bindings ad-arg-bindings)
480 ;; (firstarg (car bindings))
481 ;; (secondarg (car (cdr bindings))))
482 ;; ;; Print info about first argument
483 ;; (print (format "%s=%s (%s)"
484 ;; (ad-arg-binding-field firstarg 'name)
485 ;; (ad-arg-binding-field firstarg 'value)
486 ;; (ad-arg-binding-field firstarg 'type)))
489 ;; The `type' of an argument is either `required', `optional' or `rest'.
490 ;; Wherever `ad-arg-bindings' appears a form will be inserted that evaluates
491 ;; to the list of bindings, hence, in order to avoid multiple unnecessary
492 ;; evaluations one should always bind it to some variable.
494 ;; @@@ Argument list mapping:
495 ;; ==========================
496 ;; Because `defadvice' allows the specification of the argument list of the
497 ;; advised function we need a mapping mechanism that maps this argument list
498 ;; onto that of the original function. For example, somebody might specify
499 ;; `(sym newdef)' as the argument list of `fset', while advice might use
500 ;; `(&rest ad-subr-args)' as the argument list of the original function
501 ;; (depending on what Emacs version is used). Hence SYM and NEWDEF have to
502 ;; be properly mapped onto the &rest variable when the original definition is
503 ;; called. Advice automatically takes care of that mapping, hence, the advice
504 ;; programmer can specify an argument list without having to know about the
505 ;; exact structure of the original argument list as long as the new argument
506 ;; list takes a compatible number/magnitude of actual arguments.
508 ;; @@@ Definition of subr argument lists:
509 ;; ======================================
510 ;; When advice constructs the advised definition of a function it has to
511 ;; know the argument list of the original function. For functions and macros
512 ;; the argument list can be determined from the actual definition, however,
513 ;; for subrs there is no such direct access available. In Lemacs and for some
514 ;; subrs in Emacs-19 the argument list of a subr can be determined from
515 ;; its documentation string, in a v18 Emacs even that is not possible. If
516 ;; advice cannot at all determine the argument list of a subr it uses
517 ;; `(&rest ad-subr-args)' which will always work but is inefficient because
518 ;; it conses up arguments. The macro `ad-define-subr-args' can be used by
519 ;; the advice programmer to explicitly tell advice about the argument list
520 ;; of a certain subr, for example,
522 ;; (ad-define-subr-args 'fset '(sym newdef))
524 ;; is used by advice itself to tell a v18 Emacs about the arguments of `fset'.
525 ;; The following can be used to undo such a definition:
527 ;; (ad-undefine-subr-args 'fset)
529 ;; The argument list definition is stored on the property list of the subr
530 ;; name symbol. When an argument list could be determined from the
531 ;; documentation string it will be cached under that property. The general
532 ;; mechanism for looking up the argument list of a subr is the following:
533 ;; 1) look for a definition stored on the property list
534 ;; 2) if that failed try to infer it from the documentation string and
535 ;; if successful cache it on the property list
536 ;; 3) otherwise use `(&rest ad-subr-args)'
538 ;; @@ Activation and deactivation:
539 ;; ===============================
540 ;; The definition of an advised function does not change until all its advice
541 ;; gets actually activated. Activation can either happen with the `activate'
542 ;; flag specified in the `defadvice', with an explicit call or interactive
543 ;; invocation of `ad-activate', or if forward advice is enabled (i.e., the
544 ;; value of `ad-activate-on-definition' is t) at the time an already advised
545 ;; function gets defined.
547 ;; When a function gets first activated its original definition gets saved,
548 ;; all defined and enabled pieces of advice will get combined with the
549 ;; original definition, the resulting definition might get compiled depending
550 ;; on some conditions described below, and then the function will get
551 ;; redefined with the advised definition. This also means that undefined
552 ;; functions cannot get activated even though they might be already advised.
554 ;; The advised definition will get compiled either if `ad-activate' was called
555 ;; interactively with a prefix argument, or called explicitly with its second
556 ;; argument as t, or, if `ad-default-compilation-action' justifies it according
557 ;; to the current system state. If the advised definition was
558 ;; constructed during "preactivation" (see below) then that definition will
559 ;; be already compiled because it was constructed during byte-compilation of
560 ;; the file that contained the `defadvice' with the `preactivate' flag.
562 ;; `ad-deactivate' can be used to back-define an advised function to its
563 ;; original definition. It can be called interactively or directly. Because
564 ;; `ad-activate' caches the advised definition the function can be
565 ;; reactivated via `ad-activate' with only minor overhead (it is checked
566 ;; whether the current advice state is consistent with the cached
567 ;; definition, see the section on caching below).
569 ;; `ad-activate-regexp' and `ad-deactivate-regexp' can be used to de/activate
570 ;; all currently advised function that have a piece of advice with a name that
571 ;; contains a match for a regular expression. These functions can be used to
572 ;; de/activate sets of functions depending on certain advice naming
575 ;; Finally, `ad-activate-all' and `ad-deactivate-all' can be used to
576 ;; de/activate all currently advised functions. These are useful to
577 ;; (temporarily) return to an un/advised state.
579 ;; @@@ Reasons for the separation of advice definition and activation:
580 ;; ===================================================================
581 ;; As already mentioned, advising happens in two stages:
583 ;; 1) definition of various pieces of advice
584 ;; 2) activation of all advice currently defined and enabled
586 ;; The advantage of this is that various pieces of advice can be defined
587 ;; before they get combined into an advised definition which avoids
588 ;; unnecessary constructions of intermediate advised definitions. The more
589 ;; important advantage is that it allows the implementation of forward advice.
590 ;; Advice information for a certain function accumulates as the value of the
591 ;; `advice-info' property of the function symbol. This accumulation is
592 ;; completely independent of the fact that that function might not yet be
593 ;; defined. The special forms `defun' and `defmacro' have been advised to
594 ;; check whether the function/macro they defined had advice information
595 ;; associated with it. If so and forward advice is enabled, the original
596 ;; definition will be saved, and then the advice will be activated. When a
597 ;; file is loaded in a v18 Emacs the functions/macros it defines are also
598 ;; defined with calls to `defun/defmacro'. Hence, we can forward advise
599 ;; functions/macros which will be defined later during a load/autoload of some
600 ;; file (for compiled files generated by jwz's byte-compiler in a v19 Emacs
601 ;; this is slightly more complicated but the basic idea is the same).
603 ;; @@ Enabling/disabling pieces or sets of advice:
604 ;; ===============================================
605 ;; A major motivation for the development of this advice package was to bring
606 ;; a little bit more structure into the function overloading chaos in Emacs
607 ;; Lisp. Many packages achieve some of their functionality by adding a little
608 ;; bit (or a lot) to the standard functionality of some Emacs Lisp function.
609 ;; ange-ftp is a very popular package that achieves its magic by overloading
610 ;; most Emacs Lisp functions that deal with files. A popular function that's
611 ;; overloaded by many packages is `expand-file-name'. The situation that one
612 ;; function is multiply overloaded can arise easily.
614 ;; Once in a while it would be desirable to be able to disable some/all
615 ;; overloads of a particular package while keeping all the rest. Ideally -
616 ;; at least in my opinion - these overloads would all be done with advice,
617 ;; I know I am dreaming right now... In that ideal case the enable/disable
618 ;; mechanism of advice could be used to achieve just that.
620 ;; Every piece of advice is associated with an enablement flag. When the
621 ;; advised definition of a particular function gets constructed (e.g., during
622 ;; activation) only the currently enabled pieces of advice will be considered.
623 ;; This mechanism allows one to have different "views" of an advised function
624 ;; dependent on what pieces of advice are currently enabled.
626 ;; Another motivation for this mechanism is that it allows one to define a
627 ;; piece of advice for some function yet keep it dormant until a certain
628 ;; condition is met. Until then activation of the function will not make use
629 ;; of that piece of advice. Once the condition is met the advice can be
630 ;; enabled and a reactivation of the function will add its functionality as
631 ;; part of the new advised definition. For example, the advices of `defun'
632 ;; etc. used by advice itself will stay disabled until `ad-start-advice' is
633 ;; called and some variables have the proper values. Hence, if somebody
634 ;; else advised these functions too and activates them the advices defined
635 ;; by advice will get used only if they are intended to be used.
637 ;; The main interface to this mechanism are the interactive functions
638 ;; `ad-enable-advice' and `ad-disable-advice'. For example, the following
639 ;; would disable a particular advice of the function `foo':
641 ;; (ad-disable-advice 'foo 'before 'my-advice)
643 ;; This call by itself only changes the flag, to get the proper effect in
644 ;; the advised definition too one has to activate `foo' with
646 ;; (ad-activate 'foo)
648 ;; or interactively. To disable whole sets of advices one can use a regular
649 ;; expression mechanism. For example, let us assume that ange-ftp actually
650 ;; used advice to overload all its functions, and that it used the
651 ;; "ange-ftp-" prefix for all its advice names, then we could temporarily
652 ;; disable all its advices with
654 ;; (ad-disable-regexp "^ange-ftp-")
656 ;; and the following call would put that actually into effect:
658 ;; (ad-activate-regexp "^ange-ftp-")
660 ;; A saver way would have been to use
662 ;; (ad-update-regexp "^ange-ftp-")
664 ;; instead which would have only reactivated currently actively advised
665 ;; functions, but not functions that were currently deactivated. All these
666 ;; functions can also be called interactively.
668 ;; A certain piece of advice is considered a match if its name contains a
669 ;; match for the regular expression. To enable ange-ftp again we would use
670 ;; `ad-enable-regexp' and then activate or update again.
672 ;; @@ Forward advice, automatic advice activation:
673 ;; ===============================================
674 ;; Because most Emacs Lisp packages are loaded on demand via an autoload
675 ;; mechanism it is essential to be able to "forward advise" functions.
676 ;; Otherwise, proper advice definition and activation would make it necessary
677 ;; to preload every file that defines a certain function before it can be
678 ;; advised, which would partly defeat the purpose of the advice mechanism.
680 ;; In the following, "forward advice" always implies its automatic activation
681 ;; once a function gets defined, and not just the accumulation of advice
682 ;; information for a possibly undefined function.
684 ;; Advice implements forward advice mainly via the following: 1) Separation
685 ;; of advice definition and activation that makes it possible to accumulate
686 ;; advice information without having the original function already defined,
687 ;; 2) special versions of the built-in functions `fset/defalias' which check
688 ;; for advice information whenever they define a function. If advice
689 ;; information was found then the advice will immediately get activated when
690 ;; the function gets defined.
692 ;; Automatic advice activation means, that whenever a function gets defined
693 ;; with either `defun', `defmacro', `fset' or by loading a byte-compiled
694 ;; file, and the function has some advice-info stored with it then that
695 ;; advice will get activated right away.
697 ;; @@@ Enabling automatic advice activation:
698 ;; =========================================
699 ;; Automatic advice activation is enabled by default. It can be disabled by
700 ;; doint `M-x ad-stop-advice' and enabled again with `M-x ad-start-advice'.
702 ;; @@ Caching of advised definitions:
703 ;; ==================================
704 ;; After an advised definition got constructed it gets cached as part of the
705 ;; advised function's advice-info so it can be reused, for example, after an
706 ;; intermediate deactivation. Because the advice-info of a function might
707 ;; change between the time of caching and reuse a cached definition gets
708 ;; a cache-id associated with it so it can be verified whether the cached
709 ;; definition is still valid (the main application of this is preactivation
712 ;; When an advised function gets activated and a verifiable cached definition
713 ;; is available, then that definition will be used instead of creating a new
714 ;; advised definition from scratch. If you want to make sure that a new
715 ;; definition gets constructed then you should use `ad-clear-cache' before you
716 ;; activate the advised function.
720 ;; Constructing an advised definition is moderately expensive. In a situation
721 ;; where one package defines a lot of advised functions it might be
722 ;; prohibitively expensive to do all the advised definition construction at
723 ;; runtime. Preactivation is a mechanism that allows compile-time construction
724 ;; of compiled advised definitions that can be activated cheaply during
725 ;; runtime. Preactivation uses the caching mechanism to do that. Here's how it
728 ;; When the byte-compiler compiles a `defadvice' that has the `preactivate'
729 ;; flag specified, it uses the current original definition of the advised
730 ;; function plus the advice specified in this `defadvice' (even if it is
731 ;; specified as disabled) and all other currently enabled pieces of advice to
732 ;; construct an advised definition and an identifying cache-id and makes them
733 ;; part of the `defadvice' expansion which will then be compiled by the
734 ;; byte-compiler (to ensure that in a v18 emacs you have to put the
735 ;; `defadvice' inside a `defun' to get it compiled and then you have to call
736 ;; that compiled `defun' in order to actually execute the `defadvice'). When
737 ;; the file with the compiled, preactivating `defadvice' gets loaded the
738 ;; precompiled advised definition will be cached on the advised function's
739 ;; advice-info. When it gets activated (can be immediately on execution of the
740 ;; `defadvice' or any time later) the cache-id gets checked against the
741 ;; current state of advice and if it is verified the precompiled definition
742 ;; will be used directly (the verification is pretty cheap). If it couldn't get
743 ;; verified a new advised definition for that function will be built from
744 ;; scratch, hence, the efficiency added by the preactivation mechanism does
745 ;; not at all impair the flexibility of the advice mechanism.
747 ;; MORAL: In order get all the efficiency out of preactivation the advice
748 ;; state of an advised function at the time the file with the
749 ;; preactivating `defadvice' gets byte-compiled should be exactly
750 ;; the same as it will be when the advice of that function gets
751 ;; actually activated. If it is not there is a high chance that the
752 ;; cache-id will not match and hence a new advised definition will
753 ;; have to be constructed at runtime.
755 ;; Preactivation and forward advice do not contradict each other. It is
756 ;; perfectly ok to load a file with a preactivating `defadvice' before the
757 ;; original definition of the advised function is available. The constructed
758 ;; advised definition will be used once the original function gets defined and
759 ;; its advice gets activated. The only constraint is that at the time the
760 ;; file with the preactivating `defadvice' got compiled the original function
761 ;; definition was available.
763 ;; TIPS: Here are some indications that a preactivation did not work the way
764 ;; you intended it to work:
765 ;; - Activation of the advised function takes longer than usual/expected
766 ;; - The byte-compiler gets loaded while an advised function gets
768 ;; - `byte-compile' is part of the `features' variable even though you
769 ;; did not use the byte-compiler
770 ;; Right now advice does not provide an elegant way to find out whether
771 ;; and why a preactivation failed. What you can do is to trace the
772 ;; function `ad-cache-id-verification-code' (with the function
773 ;; `trace-function-background' defined in my trace.el package) before
774 ;; any of your advised functions get activated. After they got
775 ;; activated check whether all calls to `ad-cache-id-verification-code'
776 ;; returned `verified' as a result. Other values indicate why the
777 ;; verification failed which should give you enough information to
778 ;; fix your preactivation/compile/load/activation sequence.
780 ;; IMPORTANT: There is one case (that I am aware of) that can make
781 ;; preactivation fail, i.e., a preconstructed advised definition that does
782 ;; NOT match the current state of advice gets used nevertheless. That case
783 ;; arises if one package defines a certain piece of advice which gets used
784 ;; during preactivation, and another package incompatibly redefines that
785 ;; very advice (i.e., same function/class/name), and it is the second advice
786 ;; that is available when the preconstructed definition gets activated, and
787 ;; that was the only definition of that advice so far (`ad-add-advice'
788 ;; catches advice redefinitions and clears the cache in such a case).
789 ;; Catching that would make the cache verification too expensive.
791 ;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with
792 ;; George Walker Bush), and why would you redefine your own advice anyway?
793 ;; Advice is a mechanism to facilitate function redefinition, not advice
794 ;; redefinition (wait until I write Meta-Advice :-). If you really have
795 ;; to undo somebody else's advice try to write a "neutralizing" advice.
797 ;; @@ Advising macros and special forms and other dangerous things:
798 ;; ================================================================
799 ;; Look at the corresponding tutorial sections for more information on
800 ;; these topics. Here it suffices to point out that the special treatment
801 ;; of macros and special forms by the byte-compiler can lead to problems
802 ;; when they get advised. Macros can create problems because they get
803 ;; expanded at compile time, hence, they might not have all the necessary
804 ;; runtime support and such advice cannot be de/activated or changed as
805 ;; it is possible for functions. Special forms create problems because they
806 ;; have to be advised "into" macros, i.e., an advised special form is a
807 ;; implemented as a macro, hence, in most cases the byte-compiler will
808 ;; not recognize it as a special form anymore which can lead to very strange
811 ;; MORAL: - Only advise macros or special forms when you are absolutely sure
812 ;; what you are doing.
813 ;; - As a safety measure, always do `ad-deactivate-all' before you
814 ;; byte-compile a file to make sure that even if some inconsiderate
815 ;; person advised some special forms you'll get proper compilation
816 ;; results. After compilation do `ad-activate-all' to get back to
817 ;; the previous state.
819 ;; @@ Adding a piece of advice with `ad-add-advice':
820 ;; =================================================
821 ;; The non-interactive function `ad-add-advice' can be used to add a piece of
822 ;; advice to some function without using `defadvice'. This is useful if advice
823 ;; has to be added somewhere by a function (also look at `ad-make-advice').
825 ;; @@ Activation/deactivation advices, file load hooks:
826 ;; ====================================================
827 ;; There are two special classes of advice called `activation' and
828 ;; `deactivation'. The body forms of these advices are not included into the
829 ;; advised definition of a function, rather they are assembled into a hook
830 ;; form which will be evaluated whenever the advice-info of the advised
831 ;; function gets activated or deactivated. One application of this mechanism
832 ;; is to define file load hooks for files that do not provide such hooks
833 ;; (v19s already come with a general file-load-hook mechanism, v18s don't).
834 ;; For example, suppose you want to print a message whenever `file-x' gets
835 ;; loaded, and suppose the last function defined in `file-x' is
836 ;; `file-x-last-fn'. Then we can define the following advice:
838 ;; (defadvice file-x-last-fn (activation file-x-load-hook)
839 ;; "Executed whenever file-x is loaded"
840 ;; (if load-in-progress (message "Loaded file-x")))
842 ;; This will constitute a forward advice for function `file-x-last-fn' which
843 ;; will get activated when `file-x' is loaded (only if forward advice is
844 ;; enabled of course). Because there are no "real" pieces of advice
845 ;; available for it, its definition will not be changed, but the activation
846 ;; advice will be run during its activation which is equivalent to having a
847 ;; file load hook for `file-x'.
849 ;; @@ Summary of main advice concepts:
850 ;; ===================================
852 ;; A piece of advice gets defined with `defadvice' and added to the
853 ;; `advice-info' property of a function.
855 ;; Every piece of advice has an enablement flag associated with it. Only
856 ;; enabled advices are considered during construction of an advised
859 ;; Redefine an advised function with its advised definition. Constructs
860 ;; an advised definition from scratch if no verifiable cached advised
861 ;; definition is available and caches it.
863 ;; Back-define an advised function to its original definition.
865 ;; Reactivate an advised function but only if its advice is currently
866 ;; active. This can be used to bring all currently advised function up
867 ;; to date with the current state of advice without also activating
868 ;; currently deactivated functions.
870 ;; Is the saving of an advised definition and an identifying cache-id so
871 ;; it can be reused, for example, for activation after deactivation.
873 ;; Is the construction of an advised definition according to the current
874 ;; state of advice during byte-compilation of a file with a preactivating
875 ;; `defadvice'. That advised definition can then rather cheaply be used
876 ;; during activation without having to construct an advised definition
877 ;; from scratch at runtime.
879 ;; @@ Summary of interactive advice manipulation functions:
880 ;; ========================================================
881 ;; The following interactive functions can be used to manipulate the state
882 ;; of advised functions (all of them support completion on function names,
883 ;; advice classes and advice names):
885 ;; - ad-activate to activate the advice of a FUNCTION
886 ;; - ad-deactivate to deactivate the advice of a FUNCTION
887 ;; - ad-update to activate the advice of a FUNCTION unless it was not
888 ;; yet activated or is currently deactivated.
889 ;; - ad-unadvise deactivates a FUNCTION and removes all of its advice
890 ;; information, hence, it cannot be activated again
891 ;; - ad-recover tries to redefine a FUNCTION to its original definition and
892 ;; discards all advice information (a low-level `ad-unadvise').
893 ;; Use only in emergencies.
895 ;; - ad-remove-advice removes a particular piece of advice of a FUNCTION.
896 ;; You still have to do call `ad-activate' or `ad-update' to
897 ;; activate the new state of advice.
898 ;; - ad-enable-advice enables a particular piece of advice of a FUNCTION.
899 ;; - ad-disable-advice disables a particular piece of advice of a FUNCTION.
900 ;; - ad-enable-regexp maps over all currently advised functions and enables
901 ;; every advice whose name contains a match for a regular
903 ;; - ad-disable-regexp disables matching advices.
905 ;; - ad-activate-regexp activates all advised function with a matching advice
906 ;; - ad-deactivate-regexp deactivates all advised function with matching advice
907 ;; - ad-update-regexp updates all advised function with a matching advice
908 ;; - ad-activate-all activates all advised functions
909 ;; - ad-deactivate-all deactivates all advised functions
910 ;; - ad-update-all updates all advised functions
911 ;; - ad-unadvise-all unadvises all advised functions
912 ;; - ad-recover-all recovers all advised functions
914 ;; - ad-compile byte-compiles a function/macro if it is compilable.
916 ;; @@ Summary of forms with special meanings when used within an advice:
917 ;; =====================================================================
918 ;; ad-return-value name of the return value variable (get/settable)
919 ;; ad-subr-args name of &rest argument variable used for advised
920 ;; subrs whose actual argument list cannot be
921 ;; determined (get/settable)
922 ;; (ad-get-arg <pos>), (ad-get-args <pos>),
923 ;; (ad-set-arg <pos> <value>), (ad-set-args <pos> <value-list>)
924 ;; argument access text macros to get/set the values of
925 ;; actual arguments at a certain position
926 ;; ad-arg-bindings text macro that returns the actual names, values
927 ;; and types of the arguments as a list of bindings. The
928 ;; order of the bindings corresponds to the order of the
929 ;; arguments. The individual fields of every binding (name,
930 ;; value and type) can be accessed with the function
931 ;; `ad-arg-binding-field' (see example above).
932 ;; ad-do-it text macro that identifies the place where the original
933 ;; or wrapped definition should go in an around advice
936 ;; @ Foo games: An advice tutorial
937 ;; ===============================
938 ;; The following tutorial was created in Emacs 18.59. Left-justified
939 ;; s-expressions are input forms followed by one or more result forms.
940 ;; First we have to start the advice magic:
945 ;; We start by defining an innocent looking function `foo' that simply
946 ;; adds 1 to its argument X:
956 ;; @@ Defining a simple piece of advice:
957 ;; =====================================
958 ;; Now let's define the first piece of advice for `foo'. To do that we
959 ;; use the macro `defadvice' which takes a function name, a list of advice
960 ;; specifiers and a list of body forms as arguments. The first element of
961 ;; the advice specifiers is the class of the advice, the second is its name,
962 ;; the third its position and the rest are some flags. The class of our
963 ;; first advice is `before', its name is `fg-add2', its position among the
964 ;; currently defined before advices (none so far) is `first', and the advice
965 ;; will be `activate'ed immediately. Advice names are global symbols, hence,
966 ;; the name space conventions used for function names should be applied. All
967 ;; advice names in this tutorial will be prefixed with `fg' for `Foo Games'
968 ;; (because everybody has the right to be inconsistent all the function names
969 ;; used in this tutorial do NOT follow this convention).
971 ;; In the body of an advice we can refer to the argument variables of the
972 ;; original function by name. Here we add 1 to X so the effect of calling
973 ;; `foo' will be to actually add 2. All of the advice definitions below only
974 ;; have one body form for simplicity, but there is no restriction to that
975 ;; extent. Every piece of advice can have a documentation string which will
976 ;; be combined with the documentation of the original function.
978 ;; (defadvice foo (before fg-add2 first activate)
986 ;; @@ Specifying the position of an advice:
987 ;; ========================================
988 ;; Now we define the second before advice which will cancel the effect of
989 ;; the previous advice. This time we specify the position as 0 which is
990 ;; equivalent to `first'. A number can be used to specify the zero-based
991 ;; position of an advice among the list of advices in the same class. This
992 ;; time we already have one before advice hence the position specification
993 ;; actually has an effect. So, after the following definition the position
994 ;; of the previous advice will be 1 even though we specified it with `first'
995 ;; above, the reason for this is that the position argument is relative to
996 ;; the currently defined pieces of advice which by now has changed.
998 ;; (defadvice foo (before fg-cancel-add2 0 activate)
999 ;; "Again only add 1 to X."
1006 ;; @@ Redefining a piece of advice:
1007 ;; ================================
1008 ;; Now we define an advice with the same class and same name but with a
1009 ;; different position. Defining an advice in a class in which an advice with
1010 ;; that name already exists is interpreted as a redefinition of that
1011 ;; particular advice, in which case the position argument will be ignored
1012 ;; and the previous position of the redefined piece of advice is used.
1013 ;; Advice flags can be specified with non-ambiguous initial substrings, hence,
1014 ;; from now on we'll use `act' instead of the verbose `activate'.
1016 ;; (defadvice foo (before fg-cancel-add2 last act)
1017 ;; "Again only add 1 to X."
1021 ;; @@ Assembly of advised documentation:
1022 ;; =====================================
1023 ;; The documentation strings of the various pieces of advice are assembled
1024 ;; in order which shows that advice `fg-cancel-add2' is still the first
1025 ;; `before' advice even though we specified position `last' above:
1027 ;; (documentation 'foo)
1030 ;; This function is advised with the following advice(s):
1032 ;; fg-cancel-add2 (before):
1033 ;; Again only add 1 to X.
1035 ;; fg-add2 (before):
1038 ;; @@ Advising interactive behavior:
1039 ;; =================================
1040 ;; We can make a function interactive (or change its interactive behavior)
1041 ;; by specifying an interactive form in one of the before or around
1042 ;; advices (there could also be body forms in this advice). The particular
1043 ;; definition always assigns 5 as an argument to X which gives us 6 as a
1044 ;; result when we call foo interactively:
1046 ;; (defadvice foo (before fg-inter last act)
1047 ;; "Use 5 as argument when called interactively."
1048 ;; (interactive (list 5)))
1051 ;; (call-interactively 'foo)
1054 ;; If more than one advice have an interactive declaration, then the one of
1055 ;; the advice with the smallest position will be used (before advices go
1056 ;; before around and after advices), hence, the declaration below does
1057 ;; not have any effect:
1059 ;; (defadvice foo (before fg-inter2 last act)
1060 ;; (interactive (list 6)))
1063 ;; (call-interactively 'foo)
1066 ;; Let's have a look at what the definition of `foo' looks like now
1067 ;; (indentation added by hand for legibility):
1069 ;; (symbol-function 'foo)
1072 ;; (interactive (list 5))
1073 ;; (let (ad-return-value)
1076 ;; (setq ad-return-value (ad-Orig-foo x))
1077 ;; ad-return-value))
1079 ;; @@ Around advices:
1080 ;; ==================
1081 ;; Now we'll try some `around' advices. An around advice is a wrapper around
1082 ;; the original definition. It can shadow or establish bindings for the
1083 ;; original definition, and it can look at and manipulate the value returned
1084 ;; by the original function. The position of the special keyword `ad-do-it'
1085 ;; specifies where the code of the original function will be executed. The
1086 ;; keyword can appear multiple times which will result in multiple calls of
1087 ;; the original function in the resulting advised code. Note, that if we don't
1088 ;; specify a position argument (i.e., `first', `last' or a number), then
1089 ;; `first' (or 0) is the default):
1091 ;; (defadvice foo (around fg-times-2 act)
1092 ;; "First double X."
1093 ;; (let ((x (* x 2)))
1100 ;; Around advices are assembled like onion skins where the around advice
1101 ;; with position 0 is the outermost skin and the advice at the last position
1102 ;; is the innermost skin which is directly wrapped around the call of the
1103 ;; original definition of the function. Hence, after the next `defadvice' we
1104 ;; will first multiply X by 2 then add 1 and then call the original
1105 ;; definition (i.e., add 1 again):
1107 ;; (defadvice foo (around fg-add-1 last act)
1109 ;; (let ((x (1+ x)))
1116 ;; Again, let's see what the definition of `foo' looks like so far:
1118 ;; (symbol-function 'foo)
1121 ;; (interactive (list 5))
1122 ;; (let (ad-return-value)
1125 ;; (let ((x (* x 2)))
1126 ;; (let ((x (1+ x)))
1127 ;; (setq ad-return-value (ad-Orig-foo x))))
1128 ;; ad-return-value))
1130 ;; @@ Controlling advice activation:
1131 ;; =================================
1132 ;; In every `defadvice' so far we have used the flag `activate' to activate
1133 ;; the advice immediately after its definition, and that's what we want in
1134 ;; most cases. However, if we define multiple pieces of advice for a single
1135 ;; function then activating every advice immediately is inefficient. A
1136 ;; better way to do this is to only activate the last defined advice.
1139 ;; (defadvice foo (after fg-times-x)
1140 ;; "Multiply the result with X."
1141 ;; (setq ad-return-value (* ad-return-value x)))
1144 ;; This still yields the same result as before:
1148 ;; Now we define another advice and activate which will also activate the
1149 ;; previous advice `fg-times-x'. Note the use of the special variable
1150 ;; `ad-return-value' in the body of the advice which is set to the result of
1151 ;; the original function. If we change its value then the value returned by
1152 ;; the advised function will be changed accordingly:
1154 ;; (defadvice foo (after fg-times-x-again act)
1155 ;; "Again multiply the result with X."
1156 ;; (setq ad-return-value (* ad-return-value x)))
1159 ;; Now the advices have an effect:
1164 ;; @@ Protecting advice execution:
1165 ;; ===============================
1166 ;; Once in a while we define an advice to perform some cleanup action,
1169 ;; (defadvice foo (after fg-cleanup last act)
1170 ;; "Do some cleanup."
1171 ;; (print "Let's clean up now!"))
1174 ;; However, in case of an error the cleanup won't be performed:
1176 ;; (condition-case error
1178 ;; (error 'error-in-foo))
1181 ;; To make sure a certain piece of advice gets executed even if some error or
1182 ;; non-local exit occurred in any preceding code, we can protect it by using
1183 ;; the `protect' keyword. (if any of the around advices is protected then the
1184 ;; whole around advice onion will be protected):
1186 ;; (defadvice foo (after fg-cleanup prot act)
1187 ;; "Do some protected cleanup."
1188 ;; (print "Let's clean up now!"))
1191 ;; Now the cleanup form will be executed even in case of an error:
1193 ;; (condition-case error
1195 ;; (error 'error-in-foo))
1196 ;; "Let's clean up now!"
1199 ;; Again, let's see what `foo' looks like:
1201 ;; (symbol-function 'foo)
1204 ;; (interactive (list 5))
1205 ;; (let (ad-return-value)
1207 ;; (progn (setq x (1- x))
1209 ;; (let ((x (* x 2)))
1210 ;; (let ((x (1+ x)))
1211 ;; (setq ad-return-value (ad-Orig-foo x))))
1212 ;; (setq ad-return-value (* ad-return-value x))
1213 ;; (setq ad-return-value (* ad-return-value x)))
1214 ;; (print "Let's clean up now!"))
1215 ;; ad-return-value))
1217 ;; @@ Compilation of advised definitions:
1218 ;; ======================================
1219 ;; Finally, we can specify the `compile' keyword in a `defadvice' to say
1220 ;; that we want the resulting advised function to be byte-compiled
1221 ;; (`compile' will be ignored unless we also specified `activate'):
1223 ;; (defadvice foo (after fg-cleanup prot act comp)
1224 ;; "Do some protected cleanup."
1225 ;; (print "Let's clean up now!"))
1228 ;; Now `foo' is byte-compiled:
1230 ;; (symbol-function 'foo)
1233 ;; (interactive (byte-code "....." [5] 1))
1234 ;; (byte-code "....." [ad-return-value x nil ((byte-code "....." [print "Let's clean up now!"] 2)) * 2 ad-Orig-foo] 6))
1237 ;; "Let's clean up now!"
1240 ;; @@ Enabling and disabling pieces of advice:
1241 ;; ===========================================
1242 ;; Once in a while it is desirable to temporarily disable a piece of advice
1243 ;; so that it won't be considered during activation, for example, if two
1244 ;; different packages advise the same function and one wants to temporarily
1245 ;; neutralize the effect of the advice of one of the packages.
1247 ;; The following disables the after advice `fg-times-x' in the function `foo'.
1248 ;; All that does is to change a flag for this particular advice. All the
1249 ;; other information defining it will be left unchanged (e.g., its relative
1250 ;; position in this advice class, etc.).
1252 ;; (ad-disable-advice 'foo 'after 'fg-times-x)
1255 ;; For this to have an effect we have to activate `foo':
1257 ;; (ad-activate 'foo)
1261 ;; "Let's clean up now!"
1264 ;; If we want to disable all multiplication advices in `foo' we can use a
1265 ;; regular expression that matches the names of such advices. Actually, any
1266 ;; advice name that contains a match for the regular expression will be
1267 ;; called a match. A special advice class `any' can be used to consider
1268 ;; all advice classes:
1270 ;; (ad-disable-advice 'foo 'any "^fg-.*times")
1273 ;; (ad-activate 'foo)
1277 ;; "Let's clean up now!"
1280 ;; To enable the disabled advice we could use either `ad-enable-advice'
1281 ;; similar to `ad-disable-advice', or as an alternative `ad-enable-regexp'
1282 ;; which will enable matching advices in ALL currently advised functions.
1283 ;; Hence, this can be used to dis/enable advices made by a particular
1284 ;; package to a set of functions as long as that package obeys standard
1285 ;; advice name conventions. We prefixed all advice names with `fg-', hence
1286 ;; the following will do the trick (`ad-enable-regexp' returns the number
1287 ;; of matched advices):
1289 ;; (ad-enable-regexp "^fg-")
1292 ;; The following will activate all currently active advised functions that
1293 ;; contain some advice matched by the regular expression. This is a save
1294 ;; way to update the activation of advised functions whose advice changed
1295 ;; in some way or other without accidentally also activating currently
1296 ;; deactivated functions:
1298 ;; (ad-update-regexp "^fg-")
1302 ;; "Let's clean up now!"
1305 ;; Another use for the dis/enablement mechanism is to define a piece of advice
1306 ;; and keep it "dormant" until a particular condition is satisfied, i.e., until
1307 ;; then the advice will not be used during activation. The `disable' flag lets
1308 ;; one do that with `defadvice':
1310 ;; (defadvice foo (before fg-1-more dis)
1311 ;; "Add yet 1 more."
1315 ;; (ad-activate 'foo)
1319 ;; "Let's clean up now!"
1322 ;; (ad-enable-advice 'foo 'before 'fg-1-more)
1325 ;; (ad-activate 'foo)
1329 ;; "Let's clean up now!"
1334 ;; Advised definitions get cached to allow efficient activation/deactivation
1335 ;; without having to reconstruct them if nothing in the advice-info of a
1336 ;; function has changed. The following idiom can be used to temporarily
1337 ;; deactivate functions that have a piece of advice defined by a certain
1338 ;; package (we save the old definition to check out caching):
1340 ;; (setq old-definition (symbol-function 'foo))
1341 ;; (lambda (x) ....)
1343 ;; (ad-deactivate-regexp "^fg-")
1349 ;; (ad-activate-regexp "^fg-")
1352 ;; (eq old-definition (symbol-function 'foo))
1356 ;; "Let's clean up now!"
1359 ;; @@ Forward advice:
1360 ;; ==================
1361 ;; To enable automatic activation of forward advice we first have to set
1362 ;; `ad-activate-on-definition' to t and restart advice:
1364 ;; (setq ad-activate-on-definition t)
1367 ;; (ad-start-advice)
1368 ;; (ad-activate-defined-function)
1370 ;; Let's define a piece of advice for an undefined function:
1372 ;; (defadvice bar (before fg-sub-1-more act)
1373 ;; "Subtract one more from X."
1377 ;; `bar' is not yet defined:
1381 ;; Now we define it and the forward advice will get activated (only because
1382 ;; `ad-activate-on-definition' was t when we started advice above with
1383 ;; `ad-start-advice'):
1386 ;; "Subtract 1 from X."
1393 ;; Redefinition will activate any available advice if the value of
1394 ;; `ad-redefinition-action' is either `warn', `accept' or `discard':
1397 ;; "Subtract 2 from X."
1404 ;; @@ Preactivation:
1405 ;; =================
1406 ;; Constructing advised definitions is moderately expensive, hence, it is
1407 ;; desirable to have a way to construct them at byte-compile time.
1408 ;; Preactivation is a mechanism that allows one to do that.
1411 ;; "Multiply X by 2."
1415 ;; (defadvice fie (before fg-times-4 preact)
1416 ;; "Multiply X by 4."
1417 ;; (setq x (* x 2)))
1420 ;; This advice did not affect `fie'...
1425 ;; ...but it constructed a cached definition that will be used once `fie' gets
1426 ;; activated as long as its current advice state is the same as it was during
1429 ;; (setq cached-definition (ad-get-cache-definition 'fie))
1430 ;; (lambda (x) ....)
1432 ;; (ad-activate 'fie)
1435 ;; (eq cached-definition (symbol-function 'fie))
1441 ;; If you put a preactivating `defadvice' into a Lisp file that gets byte-
1442 ;; compiled then the constructed advised definition will get compiled by
1443 ;; the byte-compiler. For that to occur in a v18 emacs you have to put the
1444 ;; `defadvice' inside a `defun' because the v18 compiler does not compile
1445 ;; top-level forms other than `defun' or `defmacro', for example,
1447 ;; (defun fg-defadvice-fum ()
1448 ;; (defadvice fum (before fg-times-4 preact act)
1449 ;; "Multiply X by 4."
1450 ;; (setq x (* x 2))))
1453 ;; So far, no `defadvice' for `fum' got executed, but when we compile
1454 ;; `fg-defadvice-fum' the `defadvice' will be expanded by the byte compiler.
1455 ;; In order for preactivation to be effective we have to have a proper
1456 ;; definition of `fum' around at preactivation time, hence, we define it now:
1459 ;; "Multiply X by 2."
1463 ;; Now we compile the defining function which will construct an advised
1464 ;; definition during expansion of the `defadvice', compile it and store it
1465 ;; as part of the compiled `fg-defadvice-fum':
1467 ;; (ad-compile-function 'fg-defadvice-fum)
1468 ;; (lambda nil (byte-code ...))
1470 ;; `fum' is still completely unaffected:
1475 ;; (ad-get-advice-info 'fum)
1478 ;; (fg-defadvice-fum)
1481 ;; Now the advised version of `fum' is compiled because the compiled definition
1482 ;; constructed during preactivation was used, even though we did not specify
1483 ;; the `compile' flag:
1485 ;; (symbol-function 'fum)
1488 ;; (byte-code "....." [ad-return-value x nil * 2 ad-Orig-fum] 4))
1493 ;; A preactivated definition will only be used if it matches the current
1494 ;; function definition and advice information. If it does not match it
1495 ;; will simply be discarded and a new advised definition will be constructed
1496 ;; from scratch. For example, let's first remove all advice-info for `fum':
1498 ;; (ad-unadvise 'fum)
1499 ;; (("fie") ("bar") ("foo") ...)
1501 ;; And now define a new piece of advice:
1503 ;; (defadvice fum (before fg-interactive act)
1504 ;; "Make fum interactive."
1505 ;; (interactive "nEnter x: "))
1508 ;; When we now try to use a preactivation it will not be used because the
1509 ;; current advice state is different from the one at preactivation time. This
1510 ;; is no tragedy, everything will work as expected just not as efficient,
1511 ;; because a new advised definition has to be constructed from scratch:
1513 ;; (fg-defadvice-fum)
1516 ;; A new uncompiled advised definition got constructed:
1518 ;; (ad-compiled-p (symbol-function 'fum))
1524 ;; MORAL: To get all the efficiency out of preactivation the function
1525 ;; definition and advice state at preactivation time must be the same as the
1526 ;; state at activation time. Preactivation does work with forward advice, all
1527 ;; that's necessary is that the definition of the forward advised function is
1528 ;; available when the `defadvice' with the preactivation gets compiled.
1530 ;; @@ Portable argument access:
1531 ;; ============================
1532 ;; So far, we always used the actual argument variable names to access an
1533 ;; argument in a piece of advice. For many advice applications this is
1534 ;; perfectly ok and keeps advices simple. However, it decreases portability
1535 ;; of advices because it assumes specific argument variable names. For example,
1536 ;; if one advises a subr such as `eval-region' which then gets redefined by
1537 ;; some package (e.g., edebug) into a function with different argument names,
1538 ;; then a piece of advice written for `eval-region' that was written with
1539 ;; the subr arguments in mind will break. Similar situations arise when one
1540 ;; switches between major Emacs versions, e.g., certain subrs in v18 are
1541 ;; functions in v19 and vice versa. Also, in v19s subr argument lists
1542 ;; are available and will be used, while they are not available in v18.
1544 ;; Argument access text macros allow one to access arguments of an advised
1545 ;; function in a portable way without having to worry about all these
1546 ;; possibilities. These macros will be translated into the proper access forms
1547 ;; at activation time, hence, argument access will be as efficient as if
1548 ;; the arguments had been used directly in the definition of the advice.
1550 ;; (defun fuu (x y z)
1558 ;; Argument access macros specify actual arguments at a certain position.
1559 ;; Position 0 access the first actual argument, position 1 the second etc.
1560 ;; For example, the following advice adds 1 to each of the 3 arguments:
1562 ;; (defadvice fuu (before fg-add-1-to-all act)
1563 ;; "Adds 1 to all arguments."
1564 ;; (ad-set-arg 0 (1+ (ad-get-arg 0)))
1565 ;; (ad-set-arg 1 (1+ (ad-get-arg 1)))
1566 ;; (ad-set-arg 2 (1+ (ad-get-arg 2))))
1572 ;; Now suppose somebody redefines `fuu' with a rest argument. Our advice
1573 ;; will still work because we used access macros (note, that automatic
1574 ;; advice activation is still in effect, hence, the redefinition of `fuu'
1575 ;; will automatically activate all its advice):
1577 ;; (defun fuu (&rest numbers)
1579 ;; (apply '+ numbers))
1585 ;; (fuu 1 1 1 1 1 1)
1588 ;; What's important to notice is that argument access macros access actual
1589 ;; arguments regardless of how they got distributed onto argument variables.
1590 ;; In Emacs Lisp the semantics of an actual argument is determined purely
1591 ;; by position, hence, as long as nobody changes the semantics of what a
1592 ;; certain actual argument at a certain position means the access macros
1593 ;; will do the right thing.
1595 ;; Because of &rest arguments we need a second kind of access macro that
1596 ;; can access all actual arguments starting from a certain position:
1598 ;; (defadvice fuu (before fg-print-args act)
1599 ;; "Print all arguments."
1600 ;; (print (ad-get-args 0)))
1607 ;; (defadvice fuu (before fg-set-args act)
1608 ;; "Swaps 2nd and 3rd arg and discards all the rest."
1609 ;; (ad-set-args 1 (list (ad-get-arg 2) (ad-get-arg 1))))
1612 ;; (fuu 1 2 3 4 4 4 4 4 4)
1616 ;; (defun fuu (x y z)
1624 ;; @@ Defining the argument list of an advised function:
1625 ;; =====================================================
1626 ;; Once in a while it might be desirable to advise a function and additionally
1627 ;; give it an extra argument that controls the advised code, for example, one
1628 ;; might want to make an interactive function sensitive to a prefix argument.
1629 ;; For such cases `defadvice' allows the specification of an argument list
1630 ;; for the advised function. Similar to the redefinition of interactive
1631 ;; behavior, the first argument list specification found in the list of before/
1632 ;; around/after advices will be used. Of course, the specified argument list
1633 ;; should be downward compatible with the original argument list, otherwise
1634 ;; functions that call the advised function with the original argument list
1635 ;; in mind will break.
1642 ;; Now we advise `fii' to use an optional second argument that controls the
1643 ;; amount of incrementation. A list following the (optional) position
1644 ;; argument of the advice will be interpreted as an argument list
1645 ;; specification. This means you cannot specify an empty argument list, and
1646 ;; why would you want to anyway?
1648 ;; (defadvice fii (before fg-inc-x (x &optional incr) act)
1649 ;; "Increment X by INCR (default is 1)."
1650 ;; (setq x (+ x (1- (or incr 1)))))
1659 ;; @@ Specifying argument lists of subrs:
1660 ;; ======================================
1661 ;; The argument lists of subrs cannot be determined directly from Lisp.
1662 ;; This means that Advice has to use `(&rest ad-subr-args)' as the
1663 ;; argument list of the advised subr which is not very efficient. In Lemacs
1664 ;; subr argument lists can be determined from their documentation string, in
1665 ;; Emacs-19 this is the case for some but not all subrs. To accommodate
1666 ;; for the cases where the argument lists cannot be determined (e.g., in a
1667 ;; v18 Emacs) Advice comes with a specification mechanism that allows the
1668 ;; advice programmer to tell advice what the argument list of a certain subr
1671 ;; In a v18 Emacs the following will return the &rest idiom:
1673 ;; (ad-arglist (symbol-function 'car))
1674 ;; (&rest ad-subr-args)
1676 ;; To tell advice what the argument list of `car' really is we
1677 ;; can do the following:
1679 ;; (ad-define-subr-args 'car '(list))
1682 ;; Now `ad-arglist' will return the proper argument list (this method is
1683 ;; actually used by advice itself for the advised definition of `fset'):
1685 ;; (ad-arglist (symbol-function 'car))
1688 ;; The defined argument list will be stored on the property list of the
1689 ;; subr name symbol. When advice looks for a subr argument list it first
1690 ;; checks for a definition on the property list, if that fails it tries
1691 ;; to infer it from the documentation string and caches it on the property
1692 ;; list if it was successful, otherwise `(&rest ad-subr-args)' will be used.
1694 ;; @@ Advising interactive subrs:
1695 ;; ==============================
1696 ;; For the most part there is no difference between advising functions and
1697 ;; advising subrs. There is one situation though where one might have to write
1698 ;; slightly different advice code for subrs than for functions. This case
1699 ;; arises when one wants to access subr arguments in a before/around advice
1700 ;; when the arguments were determined by an interactive call to the subr.
1701 ;; Advice cannot determine what `interactive' form determines the interactive
1702 ;; behavior of the subr, hence, when it calls the original definition in an
1703 ;; interactive subr invocation it has to use `call-interactively' to generate
1704 ;; the proper interactive behavior. Thus up to that call the arguments of the
1705 ;; interactive subr will be nil. For example, the following advice for
1706 ;; `kill-buffer' will not work in an interactive invocation...
1708 ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp)
1709 ;; (my-before-kill-buffer-hook (ad-get-arg 0)))
1712 ;; ...because the buffer argument will be nil in that case. The way out of
1713 ;; this dilemma is to provide an `interactive' specification that mirrors
1714 ;; the interactive behavior of the unadvised subr, for example, the following
1715 ;; will do the right thing even when `kill-buffer' is called interactively:
1717 ;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp)
1718 ;; (interactive "bKill buffer: ")
1719 ;; (my-before-kill-buffer-hook (ad-get-arg 0)))
1722 ;; @@ Advising macros:
1723 ;; ===================
1724 ;; Advising macros is slightly different because there are two significant
1725 ;; time points in the invocation of a macro: Expansion and evaluation time.
1726 ;; For an advised macro instead of evaluating the original definition we
1727 ;; use `macroexpand', that is, changing argument values and binding
1728 ;; environments by pieces of advice has an affect during macro expansion
1729 ;; but not necessarily during evaluation. In particular, any side effects
1730 ;; of pieces of advice will occur during macro expansion. To also affect
1731 ;; the behavior during evaluation time one has to change the value of
1732 ;; `ad-return-value' in a piece of after advice. For example:
1734 ;; (defmacro foom (x)
1735 ;; (` (list (, x))))
1741 ;; (defadvice foom (before fg-print-x act)
1742 ;; "Print the value of X."
1746 ;; The following works as expected because evaluation immediately follows
1753 ;; However, the printing happens during expansion (or byte-compile) time:
1755 ;; (macroexpand '(foom '(a)))
1757 ;; (list (quote (a)))
1759 ;; If we want it to happen during evaluation time we have to do the
1760 ;; following (first remove the old advice):
1762 ;; (ad-remove-advice 'foom 'before 'fg-print-x)
1765 ;; (defadvice foom (after fg-print-x act)
1766 ;; "Print the value of X."
1767 ;; (setq ad-return-value
1768 ;; (` (progn (print (, x))
1769 ;; (, ad-return-value)))))
1772 ;; (macroexpand '(foom '(a)))
1773 ;; (progn (print (quote (a))) (list (quote (a))))
1779 ;; While this method might seem somewhat cumbersome, it is very general
1780 ;; because it allows one to influence macro expansion as well as evaluation.
1781 ;; In general, advising macros should be a rather rare activity anyway, in
1782 ;; particular, because compile-time macro expansion takes away a lot of the
1783 ;; flexibility and effectiveness of the advice mechanism. Macros that were
1784 ;; compile-time expanded before the advice was activated will of course never
1785 ;; exhibit the advised behavior.
1787 ;; @@ Advising special forms:
1788 ;; ==========================
1789 ;; Now for something that should be even more rare than advising macros:
1790 ;; Advising special forms. Because special forms are irregular in their
1791 ;; argument evaluation behavior (e.g., `setq' evaluates the second but not
1792 ;; the first argument) they have to be advised into macros. A dangerous
1793 ;; consequence of this is that the byte-compiler will not recognize them
1794 ;; as special forms anymore (well, in most cases) and use their expansion
1795 ;; rather than the proper byte-code. Also, because the original definition
1796 ;; of a special form cannot be `funcall'ed, `eval' has to be used instead
1797 ;; which is less efficient.
1799 ;; MORAL: Do not advise special forms unless you are completely sure about
1800 ;; what you are doing (some of the forward advice behavior is
1801 ;; implemented via advice of the special forms `defun' and `defmacro').
1802 ;; As a safety measure one should always do `ad-deactivate-all' before
1803 ;; one byte-compiles a file to avoid any interference of advised
1806 ;; Apart from the safety concerns advising special forms is not any different
1807 ;; from advising plain functions or subrs.
1812 ;; @ Advice implementation:
1813 ;; ========================
1815 ;; @@ Compilation idiosyncrasies:
1816 ;; ==============================
1818 ;; `defadvice' expansion needs quite a few advice functions and variables,
1819 ;; hence, I need to preload the file before it can be compiled. To avoid
1820 ;; interference of bogus compiled files I always preload the source file:
1821 (provide 'advice-preload
)
1822 ;; During a normal load this is a noop:
1823 (require 'advice-preload
"advice.el")
1826 ;; @@ Variable definitions:
1827 ;; ========================
1829 (defgroup advice nil
1830 "An overloading mechanism for Emacs Lisp functions."
1832 :link
'(custom-manual "(elisp)Advising Functions")
1835 (defconst ad-version
"2.14")
1838 (defcustom ad-redefinition-action
'warn
1839 "*Defines what to do with redefinitions during Advice de/activation.
1840 Redefinition occurs if a previously activated function that already has an
1841 original definition associated with it gets redefined and then de/activated.
1842 In such a case we can either accept the current definition as the new
1843 original definition, discard the current definition and replace it with the
1844 old original, or keep it and raise an error. The values `accept', `discard',
1845 `error' or `warn' govern what will be done. `warn' is just like `accept' but
1846 it additionally prints a warning message. All other values will be
1847 interpreted as `error'."
1848 :type
'(choice (const accept
) (const discard
) (const warn
)
1849 (other :tag
"error" error
))
1853 (defcustom ad-default-compilation-action
'maybe
1854 "*Defines whether to compile advised definitions during activation.
1855 A value of `always' will result in unconditional compilation, `never' will
1856 always avoid compilation, `maybe' will compile if the byte-compiler is already
1857 loaded, and `like-original' will compile if the original definition of the
1858 advised function is compiled or a built-in function. Every other value will
1859 be interpreted as `maybe'. This variable will only be considered if the
1860 COMPILE argument of `ad-activate' was supplied as nil."
1861 :type
'(choice (const always
) (const never
) (const like-original
)
1862 (other :tag
"maybe" maybe
))
1867 ;; @@ Some utilities:
1868 ;; ==================
1870 ;; We don't want the local arguments to interfere with anything
1871 ;; referenced in the supplied functions => the cryptic casing:
1872 (defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE
)
1873 "Substitute qualifying subTREEs with result of FUNCTION(subTREE).
1874 Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4)
1875 then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are
1876 allowed too. Once a qualifying subtree has been found its subtrees will
1877 not be considered anymore. (ad-substitute-tree 'atom 'identity tree)
1878 generates a copy of TREE."
1880 (cons (if (funcall sUbTrEe-TeSt
(car tReE
))
1881 (funcall fUnCtIoN
(car tReE
))
1882 (if (consp (car tReE
))
1883 (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN
(car tReE
))
1885 (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN
(cdr tReE
))))
1886 ((funcall sUbTrEe-TeSt tReE
)
1887 (funcall fUnCtIoN tReE
))
1890 ;; this is just faster than `ad-substitute-tree':
1891 (defun ad-copy-tree (tree)
1892 "Return a copy of the list structure of TREE."
1894 (cons (ad-copy-tree (car tree
))
1895 (ad-copy-tree (cdr tree
))))
1898 (defmacro ad-dolist
(varform &rest body
)
1899 "A Common-Lisp-style dolist iterator with the following syntax:
1901 (ad-dolist (VAR INIT-FORM [RESULT-FORM])
1904 which will iterate over the list yielded by INIT-FORM binding VAR to the
1905 current head at every iteration. If RESULT-FORM is supplied its value will
1906 be returned at the end of the iteration, nil otherwise. The iteration can be
1907 exited prematurely with `(ad-do-return [VALUE])'."
1909 `(let ((ad-dO-vAr ,(car (cdr varform
)))
1912 (setq ,(car varform
) (car ad-dO-vAr
))
1914 ;;work around a backquote bug:
1915 ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
1916 ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
1917 ,'(setq ad-dO-vAr
(cdr ad-dO-vAr
)))
1918 ,(car (cdr (cdr varform
))))))
1919 ;;ok, this wastes some cons cells but only during compilation:
1920 (if (catch 'contains-return
1922 (function (lambda (subtree)
1923 (cond ((eq (car-safe subtree
) 'ad-dolist
))
1924 ((eq (car-safe subtree
) 'ad-do-return
)
1925 (throw 'contains-return t
)))))
1928 `(catch 'ad-dO-eXiT
,expansion
)
1931 (defmacro ad-do-return
(value)
1932 `(throw 'ad-dO-eXiT
,value
))
1934 (if (not (get 'ad-dolist
'lisp-indent-hook
))
1935 (put 'ad-dolist
'lisp-indent-hook
1))
1938 ;; @@ Save real definitions of subrs used by Advice:
1939 ;; =================================================
1940 ;; Advice depends on the real, unmodified functionality of various subrs,
1941 ;; we save them here so advised versions will not interfere (eventually,
1942 ;; we will save all subrs used in code generated by Advice):
1944 (defmacro ad-save-real-definition
(function)
1945 (let ((saved-function (intern (format "ad-real-%s" function
))))
1946 ;; Make sure the compiler is loaded during macro expansion:
1947 (require 'byte-compile
"bytecomp")
1948 `(if (not (fboundp ',saved-function
))
1949 (progn (fset ',saved-function
(symbol-function ',function
))
1950 ;; Copy byte-compiler properties:
1951 ,@(if (get function
'byte-compile
)
1952 `((put ',saved-function
'byte-compile
1953 ',(get function
'byte-compile
))))
1954 ,@(if (get function
'byte-opcode
)
1955 `((put ',saved-function
'byte-opcode
1956 ',(get function
'byte-opcode
))))))))
1958 (defun ad-save-real-definitions ()
1959 ;; Macro expansion will hardcode the values of the various byte-compiler
1960 ;; properties into the compiled version of this function such that the
1961 ;; proper values will be available at runtime without loading the compiler:
1962 (ad-save-real-definition fset
)
1963 (ad-save-real-definition documentation
))
1965 (ad-save-real-definitions)
1968 ;; @@ Advice info access fns:
1969 ;; ==========================
1971 ;; Advice information for a particular function is stored on the
1972 ;; advice-info property of the function symbol. It is stored as an
1973 ;; alist of the following format:
1975 ;; ((active . t/nil)
1976 ;; (before adv1 adv2 ...)
1977 ;; (around adv1 adv2 ...)
1978 ;; (after adv1 adv2 ...)
1979 ;; (activation adv1 adv2 ...)
1980 ;; (deactivation adv1 adv2 ...)
1981 ;; (origname . <symbol fbound to origdef>)
1982 ;; (cache . (<advised-definition> . <id>)))
1984 ;; List of currently advised though not necessarily activated functions
1985 ;; (this list is maintained as a completion table):
1986 (defvar ad-advised-functions nil
)
1988 (defmacro ad-pushnew-advised-function
(function)
1989 "Add FUNCTION to `ad-advised-functions' unless its already there."
1990 `(if (not (assoc (symbol-name ,function
) ad-advised-functions
))
1991 (setq ad-advised-functions
1992 (cons (list (symbol-name ,function
))
1993 ad-advised-functions
))))
1995 (defmacro ad-pop-advised-function
(function)
1996 "Remove FUNCTION from `ad-advised-functions'."
1997 `(setq ad-advised-functions
1998 (delq (assoc (symbol-name ,function
) ad-advised-functions
)
1999 ad-advised-functions
)))
2001 (defmacro ad-do-advised-functions
(varform &rest body
)
2002 "`ad-dolist'-style iterator that maps over `ad-advised-functions'.
2003 \(ad-do-advised-functions (VAR [RESULT-FORM])
2005 On each iteration VAR will be bound to the name of an advised function
2007 `(ad-dolist (,(car varform
)
2008 ad-advised-functions
2009 ,(car (cdr varform
)))
2010 (setq ,(car varform
) (intern (car ,(car varform
))))
2013 (if (not (get 'ad-do-advised-functions
'lisp-indent-hook
))
2014 (put 'ad-do-advised-functions
'lisp-indent-hook
1))
2016 (defun ad-get-advice-info (function)
2017 (get function
'ad-advice-info
))
2019 (defmacro ad-get-advice-info-macro
(function)
2020 `(get ,function
'ad-advice-info
))
2022 (defmacro ad-set-advice-info
(function advice-info
)
2023 `(put ,function
'ad-advice-info
,advice-info
))
2025 (defmacro ad-copy-advice-info
(function)
2026 `(ad-copy-tree (get ,function
'ad-advice-info
)))
2028 (defmacro ad-is-advised
(function)
2029 "Return non-nil if FUNCTION has any advice info associated with it.
2030 This does not mean that the advice is also active."
2031 (list 'ad-get-advice-info-macro function
))
2033 (defun ad-initialize-advice-info (function)
2034 "Initialize the advice info for FUNCTION.
2035 Assumes that FUNCTION has not yet been advised."
2036 (ad-pushnew-advised-function function
)
2037 (ad-set-advice-info function
(list (cons 'active nil
))))
2039 (defmacro ad-get-advice-info-field
(function field
)
2040 "Retrieve the value of the advice info FIELD of FUNCTION."
2041 `(cdr (assq ,field
(ad-get-advice-info-macro ,function
))))
2043 (defun ad-set-advice-info-field (function field value
)
2044 "Destructively modify VALUE of the advice info FIELD of FUNCTION."
2045 (and (ad-is-advised function
)
2046 (cond ((assq field
(ad-get-advice-info-macro function
))
2047 ;; A field with that name is already present:
2048 (rplacd (assq field
(ad-get-advice-info-macro function
)) value
))
2049 (t;; otherwise, create a new field with that name:
2050 (nconc (ad-get-advice-info-macro function
)
2051 (list (cons field value
)))))))
2053 ;; Don't make this a macro so we can use it as a predicate:
2054 (defun ad-is-active (function)
2055 "Return non-nil if FUNCTION is advised and activated."
2056 (ad-get-advice-info-field function
'active
))
2059 ;; @@ Access fns for single pieces of advice and related predicates:
2060 ;; =================================================================
2062 (defun ad-make-advice (name protect enable definition
)
2063 "Constructs single piece of advice to be stored in some advice-info.
2064 NAME should be a non-nil symbol, PROTECT and ENABLE should each be
2065 either t or nil, and DEFINITION should be a list of the form
2066 `(advice lambda ARGLIST [DOCSTRING] [INTERACTIVE-FORM] BODY...)'."
2067 (list name protect enable definition
))
2069 ;; ad-find-advice uses the alist structure directly ->
2070 ;; change if this data structure changes!!
2071 (defmacro ad-advice-name
(advice)
2073 (defmacro ad-advice-protected
(advice)
2074 (list 'nth
1 advice
))
2075 (defmacro ad-advice-enabled
(advice)
2076 (list 'nth
2 advice
))
2077 (defmacro ad-advice-definition
(advice)
2078 (list 'nth
3 advice
))
2080 (defun ad-advice-set-enabled (advice flag
)
2081 (rplaca (cdr (cdr advice
)) flag
))
2083 (defun ad-class-p (thing)
2084 (memq thing ad-advice-classes
))
2085 (defun ad-name-p (thing)
2086 (and thing
(symbolp thing
)))
2087 (defun ad-position-p (thing)
2089 (memq thing
'(first last
))))
2092 ;; @@ Advice access functions:
2093 ;; ===========================
2095 ;; List of defined advice classes:
2096 (defvar ad-advice-classes
'(before around after activation deactivation
))
2098 (defun ad-has-enabled-advice (function class
)
2099 "True if at least one of FUNCTION's advices in CLASS is enabled."
2100 (ad-dolist (advice (ad-get-advice-info-field function class
))
2101 (if (ad-advice-enabled advice
) (ad-do-return t
))))
2103 (defun ad-has-redefining-advice (function)
2104 "True if FUNCTION's advice info defines at least 1 redefining advice.
2105 Redefining advices affect the construction of an advised definition."
2106 (and (ad-is-advised function
)
2107 (or (ad-has-enabled-advice function
'before
)
2108 (ad-has-enabled-advice function
'around
)
2109 (ad-has-enabled-advice function
'after
))))
2111 (defun ad-has-any-advice (function)
2112 "True if the advice info of FUNCTION defines at least one advice."
2113 (and (ad-is-advised function
)
2114 (ad-dolist (class ad-advice-classes nil
)
2115 (if (ad-get-advice-info-field function class
)
2116 (ad-do-return t
)))))
2118 (defun ad-get-enabled-advices (function class
)
2119 "Return the list of enabled advices of FUNCTION in CLASS."
2120 (let (enabled-advices)
2121 (ad-dolist (advice (ad-get-advice-info-field function class
))
2122 (if (ad-advice-enabled advice
)
2123 (push advice enabled-advices
)))
2124 (reverse enabled-advices
)))
2127 ;; @@ Dealing with automatic advice activation via `fset/defalias':
2128 ;; ================================================================
2130 ;; Since Emacs 19.26 the built-in versions of `fset' and `defalias'
2131 ;; take care of automatic advice activation, hence, we don't have to
2132 ;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'.
2134 ;; The functionality of the new `fset' is as follows:
2137 ;; assign NEWDEF to SYM
2138 ;; if (get SYM 'ad-advice-info)
2139 ;; ad-activate-internal(SYM, nil)
2140 ;; return (symbol-function SYM)
2142 ;; Whether advised definitions created by automatic activations will be
2143 ;; compiled depends on the value of `ad-default-compilation-action'.
2145 ;; Since calling `ad-activate-internal' in the built-in definition of `fset' can
2146 ;; create major disasters we have to be a bit careful. One precaution is
2147 ;; to provide a dummy definition for `ad-activate-internal' which can be used to
2148 ;; turn off automatic advice activation (e.g., when `ad-stop-advice' or
2149 ;; `ad-recover-normality' are called). Another is to avoid recursive calls
2150 ;; to `ad-activate' by using `ad-with-auto-activation-disabled' where
2151 ;; appropriate, especially in a safe version of `fset'.
2153 ;; For now define `ad-activate-internal' to the dummy definition:
2154 (defun ad-activate-internal (function &optional compile
)
2155 "Automatic advice activation is disabled. `ad-start-advice' enables it."
2158 ;; This is just a copy of the above:
2159 (defun ad-activate-internal-off (function &optional compile
)
2160 "Automatic advice activation is disabled. `ad-start-advice' enables it."
2163 ;; This will be t for top-level calls to `ad-activate-internal-on':
2164 (defvar ad-activate-on-top-level t
)
2166 (defmacro ad-with-auto-activation-disabled
(&rest body
)
2167 `(let ((ad-activate-on-top-level nil
))
2170 (defun ad-safe-fset (symbol definition
)
2171 "A safe `fset' which will never call `ad-activate-internal' recursively."
2172 (ad-with-auto-activation-disabled
2173 (ad-real-fset symbol definition
)))
2176 ;; @@ Access functions for original definitions:
2177 ;; ============================================
2178 ;; The advice-info of an advised function contains its `origname' which is
2179 ;; a symbol that is fbound to the original definition available at the first
2180 ;; proper activation of the function after a valid re/definition. If the
2181 ;; original was defined via fcell indirection then `origname' will be defined
2182 ;; just so. Hence, to get hold of the actual original definition of a function
2183 ;; we need to use `ad-real-orig-definition'.
2185 (defun ad-make-origname (function)
2186 "Make name to be used to call the original FUNCTION."
2187 (intern (format "ad-Orig-%s" function
)))
2189 (defmacro ad-get-orig-definition
(function)
2190 `(let ((origname (ad-get-advice-info-field ,function
'origname
)))
2191 (if (fboundp origname
)
2192 (symbol-function origname
))))
2194 (defmacro ad-set-orig-definition
(function definition
)
2196 (ad-get-advice-info-field function
'origname
) ,definition
))
2198 (defmacro ad-clear-orig-definition
(function)
2199 `(fmakunbound (ad-get-advice-info-field ,function
'origname
)))
2202 ;; @@ Interactive input functions:
2203 ;; ===============================
2205 (defun ad-read-advised-function (&optional prompt predicate default
)
2206 "Read name of advised function with completion from the minibuffer.
2207 An optional PROMPT will be used to prompt for the function. PREDICATE
2208 plays the same role as for `try-completion' (which see). DEFAULT will
2209 be returned on empty input (defaults to the first advised function for
2210 which PREDICATE returns non-nil)."
2211 (if (null ad-advised-functions
)
2212 (error "ad-read-advised-function: There are no advised functions"))
2215 (ad-do-advised-functions (function)
2216 (if (or (null predicate
)
2217 (funcall predicate function
))
2218 (ad-do-return function
)))
2219 (error "ad-read-advised-function: %s"
2220 "There are no qualifying advised functions")))
2221 (let* ((ad-pReDiCaTe predicate
)
2224 (format "%s (default %s): " (or prompt
"Function") default
)
2225 ad-advised-functions
2229 ;; Oops, no closures - the joys of dynamic scoping:
2230 ;; `predicate' clashed with the `predicate' argument
2231 ;; of Lemacs' `completing-read'.....
2232 (funcall ad-pReDiCaTe
(intern (car function
))))))
2234 (if (equal function
"")
2235 (if (ad-is-advised default
)
2237 (error "ad-read-advised-function: `%s' is not advised" default
))
2238 (intern function
))))
2240 (defvar ad-advice-class-completion-table
2241 (mapcar (lambda (class) (list (symbol-name class
)))
2244 (defun ad-read-advice-class (function &optional prompt default
)
2245 "Read a valid advice class with completion from the minibuffer.
2246 An optional PROMPT will be used to prompt for the class. DEFAULT will
2247 be returned on empty input (defaults to the first non-empty advice
2248 class of FUNCTION)."
2251 (ad-dolist (class ad-advice-classes
)
2252 (if (ad-get-advice-info-field function class
)
2253 (ad-do-return class
)))
2254 (error "ad-read-advice-class: `%s' has no advices" function
)))
2255 (let ((class (completing-read
2256 (format "%s (default %s): " (or prompt
"Class") default
)
2257 ad-advice-class-completion-table nil t
)))
2258 (if (equal class
"")
2262 (defun ad-read-advice-name (function class
&optional prompt
)
2263 "Read name of existing advice of CLASS for FUNCTION with completion.
2264 An optional PROMPT is used to prompt for the name."
2265 (let* ((name-completion-table
2266 (mapcar (function (lambda (advice)
2267 (list (symbol-name (ad-advice-name advice
)))))
2268 (ad-get-advice-info-field function class
)))
2270 (if (null name-completion-table
)
2271 (error "ad-read-advice-name: `%s' has no %s advice"
2273 (car (car name-completion-table
))))
2274 (prompt (format "%s (default %s): " (or prompt
"Name") default
))
2275 (name (completing-read prompt name-completion-table nil t
)))
2280 (defun ad-read-advice-specification (&optional prompt
)
2281 "Read a complete function/class/name specification from minibuffer.
2282 The list of read symbols will be returned. The optional PROMPT will
2283 be used to prompt for the function."
2284 (let* ((function (ad-read-advised-function prompt
))
2285 (class (ad-read-advice-class function
))
2286 (name (ad-read-advice-name function class
)))
2287 (list function class name
)))
2289 ;; Use previous regexp as a default:
2290 (defvar ad-last-regexp
"")
2292 (defun ad-read-regexp (&optional prompt
)
2293 "Read a regular expression from the minibuffer."
2294 (let ((regexp (read-from-minibuffer
2295 (concat (or prompt
"Regular expression")
2296 (if (equal ad-last-regexp
"") ": "
2297 (format " (default %s): " ad-last-regexp
))))))
2298 (setq ad-last-regexp
2299 (if (equal regexp
"") ad-last-regexp regexp
))))
2302 ;; @@ Finding, enabling, adding and removing pieces of advice:
2303 ;; ===========================================================
2305 (defmacro ad-find-advice
(function class name
)
2306 "Find the first advice of FUNCTION in CLASS with NAME."
2307 `(assq ,name
(ad-get-advice-info-field ,function
,class
)))
2309 (defun ad-advice-position (function class name
)
2310 "Return position of first advice of FUNCTION in CLASS with NAME."
2311 (let* ((found-advice (ad-find-advice function class name
))
2312 (advices (ad-get-advice-info-field function class
)))
2314 (- (length advices
) (length (memq found-advice advices
))))))
2316 (defun ad-find-some-advice (function class name
)
2317 "Find the first of FUNCTION's advices in CLASS matching NAME.
2318 NAME can be a symbol or a regular expression matching part of an advice name.
2319 If CLASS is `any' all valid advice classes will be checked."
2320 (if (ad-is-advised function
)
2322 (ad-dolist (advice-class ad-advice-classes
)
2323 (if (or (eq class
'any
) (eq advice-class class
))
2325 (ad-dolist (advice (ad-get-advice-info-field
2326 function advice-class
))
2327 (if (or (and (stringp name
)
2330 (ad-advice-name advice
))))
2331 (eq name
(ad-advice-name advice
)))
2332 (ad-do-return advice
)))))
2333 (if found-advice
(ad-do-return found-advice
))))))
2335 (defun ad-enable-advice-internal (function class name flag
)
2336 "Set enable FLAG of FUNCTION's advices in CLASS matching NAME.
2337 If NAME is a string rather than a symbol then it's interpreted as a regular
2338 expression and all advices whose name contain a match for it will be
2339 affected. If CLASS is `any' advices in all valid advice classes will be
2340 considered. The number of changed advices will be returned (or nil if
2341 FUNCTION was not advised)."
2342 (if (ad-is-advised function
)
2343 (let ((matched-advices 0))
2344 (ad-dolist (advice-class ad-advice-classes
)
2345 (if (or (eq class
'any
) (eq advice-class class
))
2346 (ad-dolist (advice (ad-get-advice-info-field
2347 function advice-class
))
2348 (cond ((or (and (stringp name
)
2350 name
(symbol-name (ad-advice-name advice
))))
2351 (eq name
(ad-advice-name advice
)))
2352 (setq matched-advices
(1+ matched-advices
))
2353 (ad-advice-set-enabled advice flag
))))))
2357 (defun ad-enable-advice (function class name
)
2358 "Enables the advice of FUNCTION with CLASS and NAME."
2359 (interactive (ad-read-advice-specification "Enable advice of"))
2360 (if (ad-is-advised function
)
2361 (if (eq (ad-enable-advice-internal function class name t
) 0)
2362 (error "ad-enable-advice: `%s' has no %s advice matching `%s'"
2363 function class name
))
2364 (error "ad-enable-advice: `%s' is not advised" function
)))
2367 (defun ad-disable-advice (function class name
)
2368 "Disable the advice of FUNCTION with CLASS and NAME."
2369 (interactive (ad-read-advice-specification "Disable advice of"))
2370 (if (ad-is-advised function
)
2371 (if (eq (ad-enable-advice-internal function class name nil
) 0)
2372 (error "ad-disable-advice: `%s' has no %s advice matching `%s'"
2373 function class name
))
2374 (error "ad-disable-advice: `%s' is not advised" function
)))
2376 (defun ad-enable-regexp-internal (regexp class flag
)
2377 "Set enable FLAGs of all CLASS advices whose name contains a REGEXP match.
2378 If CLASS is `any' all valid advice classes are considered. The number of
2379 affected advices will be returned."
2380 (let ((matched-advices 0))
2381 (ad-do-advised-functions (advised-function)
2382 (setq matched-advices
2384 (or (ad-enable-advice-internal
2385 advised-function class regexp flag
)
2389 (defun ad-enable-regexp (regexp)
2390 "Enables all advices with names that contain a match for REGEXP.
2391 All currently advised functions will be considered."
2393 (list (ad-read-regexp "Enable advices via regexp")))
2394 (let ((matched-advices (ad-enable-regexp-internal regexp
'any t
)))
2396 (message "%d matching advices enabled" matched-advices
))
2399 (defun ad-disable-regexp (regexp)
2400 "Disable all advices with names that contain a match for REGEXP.
2401 All currently advised functions will be considered."
2403 (list (ad-read-regexp "Disable advices via regexp")))
2404 (let ((matched-advices (ad-enable-regexp-internal regexp
'any nil
)))
2406 (message "%d matching advices disabled" matched-advices
))
2409 (defun ad-remove-advice (function class name
)
2410 "Remove FUNCTION's advice with NAME from its advices in CLASS.
2411 If such an advice was found it will be removed from the list of advices
2413 (interactive (ad-read-advice-specification "Remove advice of"))
2414 (if (ad-is-advised function
)
2415 (let ((advice-to-remove (ad-find-advice function class name
)))
2416 (if advice-to-remove
2417 (ad-set-advice-info-field
2419 (delq advice-to-remove
(ad-get-advice-info-field function class
)))
2420 (error "ad-remove-advice: `%s' has no %s advice `%s'"
2421 function class name
)))
2422 (error "ad-remove-advice: `%s' is not advised" function
)))
2425 (defun ad-add-advice (function advice class position
)
2426 "Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
2427 If FUNCTION already has one or more pieces of advice of the specified
2428 CLASS then POSITION determines where the new piece will go. The value
2429 of POSITION can either be `first', `last' or a number where 0 corresponds
2430 to `first'. Numbers outside the range will be mapped to the closest
2431 extreme position. If there was already a piece of ADVICE with the same
2432 name, then the position argument will be ignored and the old advice
2433 will be overwritten with the new one.
2434 If the FUNCTION was not advised already, then its advice info will be
2435 initialized. Redefining a piece of advice whose name is part of the cache-id
2436 will clear the cache."
2437 (cond ((not (ad-is-advised function
))
2438 (ad-initialize-advice-info function
)
2439 (ad-set-advice-info-field
2440 function
'origname
(ad-make-origname function
))))
2441 (let* ((previous-position
2442 (ad-advice-position function class
(ad-advice-name advice
)))
2443 (advices (ad-get-advice-info-field function class
))
2444 ;; Determine a numerical position for the new advice:
2445 (position (cond (previous-position)
2446 ((eq position
'first
) 0)
2447 ((eq position
'last
) (length advices
))
2449 (max 0 (min position
(length advices
))))
2451 ;; Check whether we have to clear the cache:
2452 (if (memq (ad-advice-name advice
) (ad-get-cache-class-id function class
))
2453 (ad-clear-cache function
))
2454 (if previous-position
2455 (setcar (nthcdr position advices
) advice
)
2457 (ad-set-advice-info-field function class
(cons advice advices
))
2458 (setcdr (nthcdr (1- position
) advices
)
2459 (cons advice
(nthcdr position advices
)))))))
2462 ;; @@ Accessing and manipulating function definitions:
2463 ;; ===================================================
2465 (defmacro ad-macrofy
(definition)
2466 "Take a lambda function DEFINITION and make a macro out of it."
2467 `(cons 'macro
,definition
))
2469 (defmacro ad-lambdafy
(definition)
2470 "Take a macro function DEFINITION and make a lambda out of it."
2473 (defun ad-special-form-p (definition)
2474 "Non-nil iff DEFINITION is a special form."
2475 (if (and (symbolp definition
) (fboundp definition
))
2476 (setq definition
(indirect-function definition
)))
2477 (and (subrp definition
) (eq (cdr (subr-arity definition
)) 'unevalled
)))
2479 (defmacro ad-subr-p
(definition)
2480 ;;"non-nil if DEFINITION is a subr."
2481 (list 'subrp definition
))
2483 (defmacro ad-macro-p
(definition)
2484 ;;"non-nil if DEFINITION is a macro."
2485 `(eq (car-safe ,definition
) 'macro
))
2487 (defmacro ad-lambda-p
(definition)
2488 ;;"non-nil if DEFINITION is a lambda expression."
2489 `(eq (car-safe ,definition
) 'lambda
))
2491 ;; see ad-make-advice for the format of advice definitions:
2492 (defmacro ad-advice-p
(definition)
2493 ;;"non-nil if DEFINITION is a piece of advice."
2494 `(eq (car-safe ,definition
) 'advice
))
2496 ;; Emacs/Lemacs cross-compatibility
2497 ;; (compiled-function-p is an obsolete function in Emacs):
2498 (if (and (not (fboundp 'byte-code-function-p
))
2499 (fboundp 'compiled-function-p
))
2500 (ad-safe-fset 'byte-code-function-p
'compiled-function-p
))
2502 (defmacro ad-compiled-p
(definition)
2503 "Return non-nil if DEFINITION is a compiled byte-code object."
2504 `(or (byte-code-function-p ,definition
)
2505 (and (ad-macro-p ,definition
)
2506 (byte-code-function-p (ad-lambdafy ,definition
)))))
2508 (defmacro ad-compiled-code
(compiled-definition)
2509 "Return the byte-code object of a COMPILED-DEFINITION."
2510 `(if (ad-macro-p ,compiled-definition
)
2511 (ad-lambdafy ,compiled-definition
)
2512 ,compiled-definition
))
2514 (defun ad-lambda-expression (definition)
2515 "Return the lambda expression of a function/macro/advice DEFINITION."
2516 (cond ((ad-lambda-p definition
)
2518 ((ad-macro-p definition
)
2519 (ad-lambdafy definition
))
2520 ((ad-advice-p definition
)
2524 (defun ad-arglist (definition &optional name
)
2525 "Return the argument list of DEFINITION.
2526 If DEFINITION could be from a subr then its NAME should be
2527 supplied to make subr arglist lookup more efficient."
2528 (cond ((ad-compiled-p definition
)
2529 (aref (ad-compiled-code definition
) 0))
2531 (car (cdr (ad-lambda-expression definition
))))
2532 ((ad-subr-p definition
)
2534 (ad-subr-arglist name
)
2535 ;; otherwise get it from its printed representation:
2536 (setq name
(format "%s" definition
))
2537 (string-match "^#<subr \\([^>]+\\)>$" name
)
2538 (ad-subr-arglist (intern (match-string 1 name
)))))))
2540 ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
2541 ;; a defined empty arglist `(nil)' from an undefined arglist:
2542 (defmacro ad-define-subr-args
(subr arglist
)
2543 `(put ,subr
'ad-subr-arglist
(list ,arglist
)))
2544 (defmacro ad-undefine-subr-args
(subr)
2545 `(put ,subr
'ad-subr-arglist nil
))
2546 (defmacro ad-subr-args-defined-p
(subr)
2547 `(get ,subr
'ad-subr-arglist
))
2548 (defmacro ad-get-subr-args
(subr)
2549 `(car (get ,subr
'ad-subr-arglist
)))
2551 (defun ad-subr-arglist (subr-name)
2552 "Retrieve arglist of the subr with SUBR-NAME.
2553 Either use the one stored under the `ad-subr-arglist' property,
2554 or try to retrieve it from the docstring and cache it under
2555 that property, or otherwise use `(&rest ad-subr-args)'."
2556 (if (ad-subr-args-defined-p subr-name
)
2557 (ad-get-subr-args subr-name
)
2558 ;; says jwz: Should use this for Lemacs 19.8 and above:
2559 ;;((fboundp 'subr-min-args)
2561 ;; says hans: I guess what Jamie means is that I should use the values
2562 ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist
2563 ;; without having to look it up via parsing the docstring, e.g.,
2564 ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an
2565 ;; argument list. However, that won't work because there is no
2566 ;; way to distinguish a subr with args `(a &optional b &rest c)' from
2567 ;; one with args `(a &rest c)' using that mechanism. Also, the argument
2568 ;; names from the docstring are more meaningful. Hence, I'll stick with
2569 ;; the old way of doing things.
2570 (let ((doc (or (ad-real-documentation subr-name t
) "")))
2571 (if (not (string-match "\n\n\\((.+)\\)\\'" doc
))
2572 ;; Signalling an error leads to bugs during bootstrapping because
2573 ;; the DOC file is not yet built (which is an error, BTW).
2574 ;; (error "The usage info is missing from the subr %s" subr-name)
2575 '(&rest ad-subr-args
)
2576 (ad-define-subr-args
2578 (cdr (car (read-from-string
2579 (downcase (match-string 1 doc
))))))
2580 (ad-get-subr-args subr-name
)))))
2582 (defun ad-docstring (definition)
2583 "Return the unexpanded docstring of DEFINITION."
2585 (if (ad-compiled-p definition
)
2586 (ad-real-documentation definition t
)
2587 (car (cdr (cdr (ad-lambda-expression definition
)))))))
2588 (if (or (stringp docstring
)
2589 (natnump docstring
))
2592 (defun ad-interactive-form (definition)
2593 "Return the interactive form of DEFINITION.
2594 Like `interactive-form', but also works on pieces of advice."
2596 (if (ad-advice-p definition
)
2597 (ad-lambda-expression definition
)
2600 (defun ad-body-forms (definition)
2601 "Return the list of body forms of DEFINITION."
2602 (cond ((ad-compiled-p definition
)
2605 (nthcdr (+ (if (ad-docstring definition
) 1 0)
2606 (if (ad-interactive-form definition
) 1 0))
2607 (cdr (cdr (ad-lambda-expression definition
)))))))
2609 (defun ad-make-advised-definition-docstring (function)
2610 "Make an identifying docstring for the advised definition of FUNCTION.
2611 Put function name into the documentation string so we can infer
2612 the name of the advised function from the docstring. This is needed
2613 to generate a proper advised docstring even if we are just given a
2614 definition (see the code for `documentation')."
2615 (propertize "Advice doc string" 'ad-advice-info function
))
2617 (defun ad-advised-definition-p (definition)
2618 "Return non-nil if DEFINITION was generated from advice information."
2619 (if (or (ad-lambda-p definition
)
2620 (ad-macro-p definition
)
2621 (ad-compiled-p definition
))
2622 (let ((docstring (ad-docstring definition
)))
2623 (and (stringp docstring
)
2624 (get-text-property 0 'ad-advice-info docstring
)))))
2626 (defun ad-definition-type (definition)
2627 "Return symbol that describes the type of DEFINITION."
2628 (if (ad-macro-p definition
)
2630 (if (ad-subr-p definition
)
2631 (if (ad-special-form-p definition
)
2634 (if (or (ad-lambda-p definition
)
2635 (ad-compiled-p definition
))
2637 (if (ad-advice-p definition
)
2640 (defun ad-has-proper-definition (function)
2641 "True if FUNCTION is a symbol with a proper definition.
2642 For that it has to be fbound with a non-autoload definition."
2643 (and (symbolp function
)
2645 (not (eq (car-safe (symbol-function function
)) 'autoload
))))
2647 ;; The following two are necessary for the sake of packages such as
2648 ;; ange-ftp which redefine functions via fcell indirection:
2649 (defun ad-real-definition (function)
2650 "Find FUNCTION's definition at the end of function cell indirection."
2651 (if (ad-has-proper-definition function
)
2652 (let ((definition (symbol-function function
)))
2653 (if (symbolp definition
)
2654 (ad-real-definition definition
)
2657 (defun ad-real-orig-definition (function)
2658 "Find FUNCTION's real original definition starting from its `origname'."
2659 (if (ad-is-advised function
)
2660 (ad-real-definition (ad-get-advice-info-field function
'origname
))))
2662 (defun ad-is-compilable (function)
2663 "True if FUNCTION has an interpreted definition that can be compiled."
2664 (and (ad-has-proper-definition function
)
2665 (or (ad-lambda-p (symbol-function function
))
2666 (ad-macro-p (symbol-function function
)))
2667 (not (ad-compiled-p (symbol-function function
)))))
2669 (defun ad-compile-function (function)
2670 "Byte-compiles FUNCTION (or macro) if it is not yet compiled."
2671 (interactive "aByte-compile function: ")
2672 (if (ad-is-compilable function
)
2673 ;; Need to turn off auto-activation
2674 ;; because `byte-compile' uses `fset':
2675 (ad-with-auto-activation-disabled
2677 (let ((symbol (make-symbol "advice-compilation"))
2678 (byte-compile-warnings byte-compile-warnings
))
2680 (byte-compile-disable-warning 'cl-functions
))
2681 (fset symbol
(symbol-function function
))
2682 (byte-compile symbol
)
2683 (fset function
(symbol-function symbol
))))))
2686 ;; @@ Constructing advised definitions:
2687 ;; ====================================
2689 ;; Main design decisions about the form of advised definitions:
2691 ;; A) How will original definitions be called?
2692 ;; B) What will argument lists of advised functions look like?
2695 ;; I chose to use function indirection for all four types of original
2696 ;; definitions (functions, macros, subrs and special forms), i.e., create
2697 ;; a unique symbol `ad-Orig-<name>' which is fbound to the original
2698 ;; definition and call it according to type and arguments. Functions and
2699 ;; subrs that don't have any &rest arguments can be called directly in a
2700 ;; `(ad-Orig-<name> ....)' form. If they have a &rest argument we have to
2701 ;; use `apply'. Macros will be called with
2702 ;; `(macroexpand '(ad-Orig-<name> ....))', and special forms also need a
2703 ;; form like that with `eval' instead of `macroexpand'.
2706 ;; Use original arguments where possible and `(&rest ad-subr-args)'
2707 ;; otherwise, even though this seems to be more complicated and less
2708 ;; uniform than a general `(&rest args)' approach. My reason to still
2709 ;; do it that way is that in most cases my approach leads to the more
2710 ;; efficient form for the advised function, and portability (e.g., to
2711 ;; make the same advice work regardless of whether something is a
2712 ;; function or a subr) can still be achieved with argument access macros.
2715 (defun ad-prognify (forms)
2716 (cond ((<= (length forms
) 1)
2718 (t (cons 'progn forms
))))
2720 ;; @@@ Accessing argument lists:
2721 ;; =============================
2723 (defun ad-parse-arglist (arglist)
2724 "Parse ARGLIST into its required, optional and rest parameters.
2725 A three-element list is returned, where the 1st element is the list of
2726 required arguments, the 2nd is the list of optional arguments, and the 3rd
2727 is the name of an optional rest parameter (or nil)."
2728 (let (required optional rest
)
2729 (setq rest
(car (cdr (memq '&rest arglist
))))
2730 (if rest
(setq arglist
(reverse (cdr (memq '&rest
(reverse arglist
))))))
2731 (setq optional
(cdr (memq '&optional arglist
)))
2733 (setq required
(reverse (cdr (memq '&optional
(reverse arglist
)))))
2734 (setq required arglist
))
2735 (list required optional rest
)))
2737 (defun ad-retrieve-args-form (arglist)
2738 "Generate a form which evaluates into names/values/types of ARGLIST.
2739 When the form gets evaluated within a function with that argument list
2740 it will result in a list with one entry for each argument, where the
2741 first element of each entry is the name of the argument, the second
2742 element is its actual current value, and the third element is either
2743 `required', `optional' or `rest' depending on the type of the argument."
2744 (let* ((parsed-arglist (ad-parse-arglist arglist
))
2745 (rest (nth 2 parsed-arglist
)))
2749 `(list ',req
,req
'required
)))
2750 (nth 0 parsed-arglist
))
2753 `(list ',opt
,opt
'optional
)))
2754 (nth 1 parsed-arglist
))
2755 ,@(if rest
(list `(list ',rest
,rest
'rest
))))))
2757 (defun ad-arg-binding-field (binding field
)
2758 (cond ((eq field
'name
) (car binding
))
2759 ((eq field
'value
) (car (cdr binding
)))
2760 ((eq field
'type
) (car (cdr (cdr binding
))))))
2762 (defun ad-list-access (position list
)
2763 (cond ((= position
0) list
)
2764 ((= position
1) (list 'cdr list
))
2765 (t (list 'nthcdr position list
))))
2767 (defun ad-element-access (position list
)
2768 (cond ((= position
0) (list 'car list
))
2769 ((= position
1) `(car (cdr ,list
)))
2770 (t (list 'nth position list
))))
2772 (defun ad-access-argument (arglist index
)
2773 "Tell how to access ARGLIST's actual argument at position INDEX.
2774 For a required/optional arg it simply returns it, if a rest argument has
2775 to be accessed, it returns a list with the index and name."
2776 (let* ((parsed-arglist (ad-parse-arglist arglist
))
2777 (reqopt-args (append (nth 0 parsed-arglist
)
2778 (nth 1 parsed-arglist
)))
2779 (rest-arg (nth 2 parsed-arglist
)))
2780 (cond ((< index
(length reqopt-args
))
2781 (nth index reqopt-args
))
2783 (list (- index
(length reqopt-args
)) rest-arg
)))))
2785 (defun ad-get-argument (arglist index
)
2786 "Return form to access ARGLIST's actual argument at position INDEX."
2787 (let ((argument-access (ad-access-argument arglist index
)))
2788 (cond ((consp argument-access
)
2790 (car argument-access
) (car (cdr argument-access
))))
2791 (argument-access))))
2793 (defun ad-set-argument (arglist index value-form
)
2794 "Return form to set ARGLIST's actual arg at INDEX to VALUE-FORM."
2795 (let ((argument-access (ad-access-argument arglist index
)))
2796 (cond ((consp argument-access
)
2797 ;; should this check whether there actually is something to set?
2798 `(setcar ,(ad-list-access
2799 (car argument-access
) (car (cdr argument-access
)))
2802 `(setq ,argument-access
,value-form
))
2803 (t (error "ad-set-argument: No argument at position %d of `%s'"
2806 (defun ad-get-arguments (arglist index
)
2807 "Return form to access all actual arguments starting at position INDEX."
2808 (let* ((parsed-arglist (ad-parse-arglist arglist
))
2809 (reqopt-args (append (nth 0 parsed-arglist
)
2810 (nth 1 parsed-arglist
)))
2811 (rest-arg (nth 2 parsed-arglist
))
2813 (if (< index
(length reqopt-args
))
2814 (setq args-form
`(list ,@(nthcdr index reqopt-args
))))
2817 (setq args-form
`(nconc ,args-form
,rest-arg
))
2818 (setq args-form
(ad-list-access (- index
(length reqopt-args
))
2822 (defun ad-set-arguments (arglist index values-form
)
2823 "Make form to assign elements of VALUES-FORM as actual ARGLIST args.
2824 The assignment starts at position INDEX."
2825 (let ((values-index 0)
2826 argument-access set-forms
)
2827 (while (setq argument-access
(ad-access-argument arglist index
))
2828 (if (symbolp argument-access
)
2830 (cons (ad-set-argument
2832 (ad-element-access values-index
'ad-vAlUeS
))
2835 (cons (if (= (car argument-access
) 0)
2837 (car (cdr argument-access
))
2838 (ad-list-access values-index
'ad-vAlUeS
))
2840 (ad-list-access (1- (car argument-access
))
2841 (car (cdr argument-access
)))
2842 (ad-list-access values-index
'ad-vAlUeS
)))
2846 (setq index
(1+ index
))
2847 (setq values-index
(1+ values-index
)))
2848 (if (null set-forms
)
2849 (error "ad-set-arguments: No argument at position %d of `%s'"
2851 (if (= (length set-forms
) 1)
2852 ;; For exactly one set-form we can use values-form directly,...
2854 (function (lambda (form) (eq form
'ad-vAlUeS
)))
2855 (function (lambda (form) values-form
))
2857 ;; ...if we have more we have to bind it to a variable:
2858 `(let ((ad-vAlUeS ,values-form
))
2859 ,@(reverse set-forms
)
2860 ;; work around the old backquote bug:
2863 (defun ad-insert-argument-access-forms (definition arglist
)
2864 "Expands arg-access text macros in DEFINITION according to ARGLIST."
2868 (or (eq form
'ad-arg-bindings
)
2869 (and (memq (car-safe form
)
2870 '(ad-get-arg ad-get-args ad-set-arg ad-set-args
))
2871 (integerp (car-safe (cdr form
)))))))
2874 (if (eq form
'ad-arg-bindings
)
2875 (ad-retrieve-args-form arglist
)
2876 (let ((accessor (car form
))
2877 (index (car (cdr form
)))
2878 (val (car (cdr (ad-insert-argument-access-forms
2879 (cdr form
) arglist
)))))
2880 (cond ((eq accessor
'ad-get-arg
)
2881 (ad-get-argument arglist index
))
2882 ((eq accessor
'ad-set-arg
)
2883 (ad-set-argument arglist index val
))
2884 ((eq accessor
'ad-get-args
)
2885 (ad-get-arguments arglist index
))
2886 ((eq accessor
'ad-set-args
)
2887 (ad-set-arguments arglist index val
)))))))
2890 ;; @@@ Mapping argument lists:
2891 ;; ===========================
2892 ;; Here is the problem:
2893 ;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the
2894 ;; argument list (x y &rest z), and we want to call the function bar which
2895 ;; has argument list (a &rest b) with a combination of x, y and z so that
2896 ;; the effect is just as if we had called (bar 1 2 3 4 5) directly.
2897 ;; The mapping should work for any two argument lists.
2899 (defun ad-map-arglists (source-arglist target-arglist
)
2900 "Make `funcall/apply' form to map SOURCE-ARGLIST to TARGET-ARGLIST.
2901 The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just
2902 as if they had been supplied to a function with TARGET-ARGLIST directly.
2903 Excess source arguments will be neglected, missing source arguments will be
2904 supplied as nil. Returns a `funcall' or `apply' form with the second element
2905 being `function' which has to be replaced by an actual function argument.
2906 Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
2907 `(funcall function a (car args) (car (cdr args)) (nth 2 args))'."
2908 (let* ((parsed-source-arglist (ad-parse-arglist source-arglist
))
2909 (source-reqopt-args (append (nth 0 parsed-source-arglist
)
2910 (nth 1 parsed-source-arglist
)))
2911 (source-rest-arg (nth 2 parsed-source-arglist
))
2912 (parsed-target-arglist (ad-parse-arglist target-arglist
))
2913 (target-reqopt-args (append (nth 0 parsed-target-arglist
)
2914 (nth 1 parsed-target-arglist
)))
2915 (target-rest-arg (nth 2 parsed-target-arglist
))
2916 (need-apply (and source-rest-arg target-rest-arg
))
2917 (target-arg-index -
1))
2918 ;; This produces ``error-proof'' target function calls with the exception
2919 ;; of a case like (&rest a) mapped onto (x &rest y) where the actual args
2920 ;; supplied to A might not be enough to supply the required target arg X
2921 (append (list (if need-apply
'apply
'funcall
) 'function
)
2923 ;; `apply' can take care of that directly:
2924 (append source-reqopt-args
(list source-rest-arg
)))
2925 (t (mapcar (function
2927 (setq target-arg-index
(1+ target-arg-index
))
2929 source-arglist target-arg-index
)))
2930 (append target-reqopt-args
2931 (and target-rest-arg
2932 ;; If we have a rest arg gobble up
2933 ;; remaining source args:
2934 (nthcdr (length target-reqopt-args
)
2935 source-reqopt-args
)))))))))
2937 (defun ad-make-mapped-call (source-arglist target-arglist target-function
)
2938 "Make form to call TARGET-FUNCTION with args from SOURCE-ARGLIST."
2939 (let ((mapped-form (ad-map-arglists source-arglist target-arglist
)))
2940 (if (eq (car mapped-form
) 'funcall
)
2941 (cons target-function
(cdr (cdr mapped-form
)))
2943 (setcar (cdr mapped-form
) (list 'quote target-function
))))))
2945 ;; @@@ Making an advised documentation string:
2946 ;; ===========================================
2947 ;; New policy: The documentation string for an advised function will be built
2948 ;; at the time the advised `documentation' function is called. This has the
2949 ;; following advantages:
2950 ;; 1) command-key substitutions will automatically be correct
2951 ;; 2) No wasted string space due to big advised docstrings in caches or
2952 ;; compiled files that contain preactivations
2953 ;; The overall overhead for this should be negligible because people normally
2954 ;; don't lookup documentation for the same function over and over again.
2956 (defun ad-make-single-advice-docstring (advice class
&optional style
)
2957 (let ((advice-docstring (ad-docstring (ad-advice-definition advice
))))
2958 (cond ((eq style
'plain
)
2961 (format "Permanent %s-advice `%s':%s%s"
2962 class
(ad-advice-name advice
)
2963 (if advice-docstring
"\n" "")
2964 (or advice-docstring
"")))
2965 (t (if advice-docstring
2966 (format "%s-advice `%s':\n%s"
2967 (capitalize (symbol-name class
))
2968 (ad-advice-name advice
)
2970 (format "%s-advice `%s'."
2971 (capitalize (symbol-name class
))
2972 (ad-advice-name advice
)))))))
2974 (require 'help-fns
) ;For help-split-fundoc and help-add-fundoc-usage.
2976 (defun ad-make-advised-docstring (function &optional style
)
2977 "Construct a documentation string for the advised FUNCTION.
2978 It concatenates the original documentation with the documentation
2979 strings of the individual pieces of advice which will be formatted
2980 according to STYLE. STYLE can be `plain' or `freeze', everything else
2981 will be interpreted as `default'. The order of the advice documentation
2982 strings corresponds to before/around/after and the individual ordering
2983 in any of these classes."
2984 (let* ((origdef (ad-real-orig-definition function
))
2985 (origtype (symbol-name (ad-definition-type origdef
)))
2987 ;; Retrieve raw doc, key substitution will be taken care of later:
2988 (ad-real-documentation origdef t
))
2989 (usage (help-split-fundoc origdoc function
))
2990 paragraphs advice-docstring ad-usage
)
2991 (setq usage
(if (null usage
) t
(setq origdoc
(cdr usage
)) (car usage
)))
2992 (if origdoc
(setq paragraphs
(list origdoc
)))
2993 (unless (eq style
'plain
)
2994 (push (propertize (concat "This " origtype
" is advised.")
2995 'face
'font-lock-warning-face
)
2997 (ad-dolist (class ad-advice-classes
)
2998 (ad-dolist (advice (ad-get-enabled-advices function class
))
2999 (setq advice-docstring
3000 (ad-make-single-advice-docstring advice class style
))
3001 (if advice-docstring
3002 (push advice-docstring paragraphs
))))
3003 (setq origdoc
(if paragraphs
3005 ;; separate paragraphs with blank lines:
3006 (mapconcat 'identity
(nreverse paragraphs
) "\n\n")
3007 'ad-advice-info function
)))
3008 (help-add-fundoc-usage origdoc usage
)))
3010 (defun ad-make-plain-docstring (function)
3011 (ad-make-advised-docstring function
'plain
))
3012 (defun ad-make-freeze-docstring (function)
3013 (ad-make-advised-docstring function
'freeze
))
3015 ;; @@@ Accessing overriding arglists and interactive forms:
3016 ;; ========================================================
3018 (defun ad-advised-arglist (function)
3019 "Find first defined arglist in FUNCTION's redefining advices."
3020 (ad-dolist (advice (append (ad-get-enabled-advices function
'before
)
3021 (ad-get-enabled-advices function
'around
)
3022 (ad-get-enabled-advices function
'after
)))
3023 (let ((arglist (ad-arglist (ad-advice-definition advice
))))
3025 ;; We found the first one, use it:
3026 (ad-do-return arglist
)))))
3028 (defun ad-advised-interactive-form (function)
3029 "Find first interactive form in FUNCTION's redefining advices."
3030 (ad-dolist (advice (append (ad-get-enabled-advices function
'before
)
3031 (ad-get-enabled-advices function
'around
)
3032 (ad-get-enabled-advices function
'after
)))
3033 (let ((interactive-form
3034 (ad-interactive-form (ad-advice-definition advice
))))
3035 (if interactive-form
3036 ;; We found the first one, use it:
3037 (ad-do-return interactive-form
)))))
3039 ;; @@@ Putting it all together:
3040 ;; ============================
3042 (defun ad-make-advised-definition (function)
3043 "Generate an advised definition of FUNCTION from its advice info."
3044 (if (and (ad-is-advised function
)
3045 (ad-has-redefining-advice function
))
3046 (let* ((origdef (ad-real-orig-definition function
))
3047 (origname (ad-get-advice-info-field function
'origname
))
3048 (orig-interactive-p (commandp origdef
))
3049 (orig-subr-p (ad-subr-p origdef
))
3050 (orig-special-form-p (ad-special-form-p origdef
))
3051 (orig-macro-p (ad-macro-p origdef
))
3052 ;; Construct the individual pieces that we need for assembly:
3053 (orig-arglist (ad-arglist origdef function
))
3054 (advised-arglist (or (ad-advised-arglist function
)
3056 (advised-interactive-form (ad-advised-interactive-form function
))
3058 (cond (orig-macro-p nil
)
3059 (advised-interactive-form)
3060 ((interactive-form origdef
)
3062 (if (and (symbolp function
) (get function
'elp-info
))
3063 (aref (get function
'elp-info
) 2)
3066 (cond ((or orig-special-form-p orig-macro-p
)
3067 ;; Special forms and macros will be advised into macros.
3068 ;; The trick is to construct an expansion for the advised
3069 ;; macro that does the correct thing when it gets eval'ed.
3070 ;; For macros we'll just use the expansion of the original
3071 ;; macro and return that. This way compiled advised macros
3072 ;; will be expanded into something useful. Note that after
3073 ;; advices have full control over whether they want to
3074 ;; evaluate the expansion (the value of `ad-return-value')
3075 ;; at macro expansion time or not. For special forms there
3076 ;; is no solution that interacts reasonably with the
3077 ;; compiler, hence we just evaluate the original at macro
3078 ;; expansion time and return the result. The moral of that
3079 ;; is that one should always deactivate advised special
3080 ;; forms before one byte-compiles a file.
3081 `(,(if orig-macro-p
'macroexpand
'eval
)
3083 ,(ad-get-arguments advised-arglist
0))))
3086 (not interactive-form
)
3087 (not advised-interactive-form
))
3088 ;; Check whether we were called interactively
3089 ;; in order to do proper prompting:
3090 `(if (called-interactively-p)
3091 (call-interactively ',origname
)
3092 ,(ad-make-mapped-call advised-arglist
3095 ;; And now for normal functions and non-interactive subrs
3096 ;; (or subrs whose interactive behavior was advised):
3097 (t (ad-make-mapped-call
3098 advised-arglist orig-arglist origname
)))))
3100 ;; Finally, build the sucker:
3101 (ad-assemble-advised-definition
3102 (cond (orig-macro-p 'macro
)
3103 (orig-special-form-p 'special-form
)
3106 (ad-make-advised-definition-docstring function
)
3109 (ad-get-enabled-advices function
'before
)
3110 (ad-get-enabled-advices function
'around
)
3111 (ad-get-enabled-advices function
'after
)))))
3113 (defun ad-assemble-advised-definition
3114 (type args docstring interactive orig
&optional befores arounds afters
)
3116 "Assembles an original and its advices into an advised function.
3117 It constructs a function or macro definition according to TYPE which has to
3118 be either `macro', `function' or `special-form'. ARGS is the argument list
3119 that has to be used, DOCSTRING if non-nil defines the documentation of the
3120 definition, INTERACTIVE if non-nil is the interactive form to be used,
3121 ORIG is a form that calls the body of the original unadvised function,
3122 and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
3123 should be modified. The assembled function will be returned."
3125 (let (before-forms around-form around-form-protected after-forms definition
)
3126 (ad-dolist (advice befores
)
3127 (cond ((and (ad-advice-protected advice
)
3131 ,(ad-prognify before-forms
)
3133 (ad-advice-definition advice
))))))
3134 (t (setq before-forms
3135 (append before-forms
3136 (ad-body-forms (ad-advice-definition advice
)))))))
3138 (setq around-form
`(setq ad-return-value
,orig
))
3139 (ad-dolist (advice (reverse arounds
))
3140 ;; If any of the around advices is protected then we
3141 ;; protect the complete around advice onion:
3142 (if (ad-advice-protected advice
)
3143 (setq around-form-protected t
))
3146 (function (lambda (form) (eq form
'ad-do-it
)))
3147 (function (lambda (form) around-form
))
3148 (ad-prognify (ad-body-forms (ad-advice-definition advice
))))))
3151 (if (and around-form-protected before-forms
)
3153 ,(ad-prognify before-forms
)
3155 (append before-forms
(list around-form
))))
3156 (ad-dolist (advice afters
)
3157 (cond ((and (ad-advice-protected advice
)
3161 ,(ad-prognify after-forms
)
3163 (ad-advice-definition advice
))))))
3164 (t (setq after-forms
3166 (ad-body-forms (ad-advice-definition advice
)))))))
3169 `(,@(if (memq type
'(macro special-form
)) '(macro))
3172 ,@(if docstring
(list docstring
))
3173 ,@(if interactive
(list interactive
))
3174 (let (ad-return-value)
3176 ,(if (eq type
'special-form
)
3177 '(list 'quote ad-return-value
)
3178 'ad-return-value
))))
3180 (ad-insert-argument-access-forms definition args
)))
3182 ;; This is needed for activation/deactivation hooks:
3183 (defun ad-make-hook-form (function hook-name
)
3184 "Make hook-form from FUNCTION's advice bodies in class HOOK-NAME."
3186 (mapcar (function (lambda (advice)
3187 (ad-body-forms (ad-advice-definition advice
))))
3188 (ad-get-enabled-advices function hook-name
))))
3190 (ad-prognify (apply 'append hook-forms
)))))
3195 ;; Generating an advised definition of a function is moderately expensive,
3196 ;; hence, it makes sense to cache it so we can reuse it in appropriate
3197 ;; circumstances. Of course, it only makes sense to reuse a cached
3198 ;; definition if the current advice and function definition state is the
3199 ;; same as it was at the time when the cached definition was generated.
3200 ;; For that purpose we associate every cache with an id so we can verify
3201 ;; if it is still valid at a certain point in time. This id mechanism
3202 ;; makes it possible to preactivate advised functions, write the compiled
3203 ;; advised definitions to a file and reuse them during the actual
3204 ;; activation without having to risk that the resulting definition will be
3205 ;; incorrect, well, almost.
3207 ;; A cache id is a list with six elements:
3208 ;; 1) the list of names of enabled before advices
3209 ;; 2) the list of names of enabled around advices
3210 ;; 3) the list of names of enabled after advices
3211 ;; 4) the type of the original function (macro, subr, etc.)
3212 ;; 5) the arglist of the original definition (or t if it was equal to the
3213 ;; arglist of the cached definition)
3214 ;; 6) t if the interactive form of the original definition was equal to the
3215 ;; interactive form of the cached definition
3217 ;; Here's how a cache can get invalidated or be incorrect:
3218 ;; A) a piece of advice used in the cache gets redefined
3219 ;; B) the current list of enabled advices is different from the ones used
3221 ;; C) the type of the original function changed, e.g., a function became a
3222 ;; macro, or a subr became a function
3223 ;; D) the arglist of the original function changed
3224 ;; E) the interactive form of the original function changed
3225 ;; F) a piece of advice used in the cache got redefined before the
3226 ;; defadvice with the cached definition got loaded: This is a PROBLEM!
3228 ;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice'
3229 ;; which clears the cache in such a case, B is easily checked during
3230 ;; verification at activation time.
3232 ;; Cases C, D and E have to be considered if one is slightly paranoid, i.e.,
3233 ;; if one considers the case that the original function could be different
3234 ;; from the one available at caching time (e.g., for forward advice of
3235 ;; functions that get redefined by some packages - such as `eval-region' gets
3236 ;; redefined by edebug). All these cases can be easily checked during
3237 ;; verification. Element 4 of the id lets one check case C, element 5 takes
3238 ;; care of case D (using t in the equality case saves some space, because the
3239 ;; arglist can be recovered at validation time from the cached definition),
3240 ;; and element 6 takes care of case E which is only a problem if the original
3241 ;; was actually a function whose interactive form was not overridden by a
3244 ;; Case F is the only one which will lead to an incorrect advised function.
3245 ;; There is no way to avoid this without storing the complete advice definition
3246 ;; in the cache-id which is not feasible.
3248 ;; The cache-id of a typical advised function with one piece of advice and
3249 ;; no arglist redefinition takes 7 conses which is a small price to pay for
3250 ;; the added efficiency. The validation itself is also pretty cheap, certainly
3251 ;; a lot cheaper than reconstructing an advised definition.
3253 (defmacro ad-get-cache-definition
(function)
3254 `(car (ad-get-advice-info-field ,function
'cache
)))
3256 (defmacro ad-get-cache-id
(function)
3257 `(cdr (ad-get-advice-info-field ,function
'cache
)))
3259 (defmacro ad-set-cache
(function definition id
)
3260 `(ad-set-advice-info-field
3261 ,function
'cache
(cons ,definition
,id
)))
3263 (defun ad-clear-cache (function)
3264 "Clears a previously cached advised definition of FUNCTION.
3265 Clear the cache if you want to force `ad-activate' to construct a new
3266 advised definition from scratch."
3268 (list (ad-read-advised-function "Clear cached definition of")))
3269 (ad-set-advice-info-field function
'cache nil
))
3271 (defun ad-make-cache-id (function)
3272 "Generate an identifying image of the current advices of FUNCTION."
3273 (let ((original-definition (ad-real-orig-definition function
))
3274 (cached-definition (ad-get-cache-definition function
)))
3275 (list (mapcar (function (lambda (advice) (ad-advice-name advice
)))
3276 (ad-get-enabled-advices function
'before
))
3277 (mapcar (function (lambda (advice) (ad-advice-name advice
)))
3278 (ad-get-enabled-advices function
'around
))
3279 (mapcar (function (lambda (advice) (ad-advice-name advice
)))
3280 (ad-get-enabled-advices function
'after
))
3281 (ad-definition-type original-definition
)
3282 (if (equal (ad-arglist original-definition function
)
3283 (ad-arglist cached-definition
))
3285 (ad-arglist original-definition function
))
3286 (if (eq (ad-definition-type original-definition
) 'function
)
3287 (equal (interactive-form original-definition
)
3288 (interactive-form cached-definition
))))))
3290 (defun ad-get-cache-class-id (function class
)
3291 "Return the part of FUNCTION's cache id that identifies CLASS."
3292 (let ((cache-id (ad-get-cache-id function
)))
3293 (if (eq class
'before
)
3295 (if (eq class
'around
)
3297 (nth 2 cache-id
)))))
3299 (defun ad-verify-cache-class-id (cache-class-id advices
)
3300 (ad-dolist (advice advices
(null cache-class-id
))
3301 (if (ad-advice-enabled advice
)
3302 (if (eq (car cache-class-id
) (ad-advice-name advice
))
3303 (setq cache-class-id
(cdr cache-class-id
))
3304 (ad-do-return nil
)))))
3306 ;; There should be a way to monitor if and why a cache verification failed
3307 ;; in order to determine whether a certain preactivation could be used or
3308 ;; not. Right now the only way to find out is to trace
3309 ;; `ad-cache-id-verification-code'. The code it returns indicates where the
3310 ;; verification failed. Tracing `ad-verify-cache-class-id' might provide
3311 ;; some additional useful information.
3313 (defun ad-cache-id-verification-code (function)
3314 (let ((cache-id (ad-get-cache-id function
))
3315 (code 'before-advice-mismatch
))
3316 (and (ad-verify-cache-class-id
3317 (car cache-id
) (ad-get-advice-info-field function
'before
))
3318 (setq code
'around-advice-mismatch
)
3319 (ad-verify-cache-class-id
3320 (nth 1 cache-id
) (ad-get-advice-info-field function
'around
))
3321 (setq code
'after-advice-mismatch
)
3322 (ad-verify-cache-class-id
3323 (nth 2 cache-id
) (ad-get-advice-info-field function
'after
))
3324 (setq code
'definition-type-mismatch
)
3325 (let ((original-definition (ad-real-orig-definition function
))
3326 (cached-definition (ad-get-cache-definition function
)))
3327 (and (eq (nth 3 cache-id
) (ad-definition-type original-definition
))
3328 (setq code
'arglist-mismatch
)
3329 (equal (if (eq (nth 4 cache-id
) t
)
3330 (ad-arglist original-definition function
)
3332 (ad-arglist cached-definition
))
3333 (setq code
'interactive-form-mismatch
)
3334 (or (null (nth 5 cache-id
))
3335 (equal (interactive-form original-definition
)
3336 (interactive-form cached-definition
)))
3337 (setq code
'verified
))))
3340 (defun ad-verify-cache-id (function)
3341 "True if FUNCTION's cache-id is compatible with its current advices."
3342 (eq (ad-cache-id-verification-code function
) 'verified
))
3345 ;; @@ Preactivation:
3346 ;; =================
3347 ;; Preactivation can be used to generate compiled advised definitions
3348 ;; at compile time without having to give up the dynamic runtime flexibility
3349 ;; of the advice mechanism. Preactivation is a special feature of `defadvice',
3350 ;; it involves the following steps:
3351 ;; - remembering the function's current state (definition and advice-info)
3352 ;; - advising it with the defined piece of advice
3353 ;; - clearing its cache
3354 ;; - generating an interpreted advised definition by activating it, this will
3355 ;; make use of all its current active advice and its current definition
3356 ;; - saving the so generated cached definition and id
3357 ;; - resetting the function's advice and definition state to what it was
3358 ;; before the preactivation
3359 ;; - Returning the saved definition and its id to be used in the expansion of
3360 ;; `defadvice' to assign it as an initial cache, hence it will be compiled
3361 ;; at time the `defadvice' gets compiled.
3362 ;; Naturally, for preactivation to be effective it has to be applied/compiled
3363 ;; at the right time, i.e., when the current state of advices and function
3364 ;; definition exactly reflects the state at activation time. Should that not
3365 ;; be the case, the precompiled definition will just be discarded and a new
3366 ;; advised definition will be generated.
3368 (defun ad-preactivate-advice (function advice class position
)
3369 "Preactivate FUNCTION and returns the constructed cache."
3370 (let* ((function-defined-p (fboundp function
))
3372 (if function-defined-p
3373 (symbol-function function
)))
3374 (old-advice-info (ad-copy-advice-info function
))
3375 (ad-advised-functions ad-advised-functions
))
3378 (ad-add-advice function advice class position
)
3379 (ad-enable-advice function class
(ad-advice-name advice
))
3380 (ad-clear-cache function
)
3381 (ad-activate function -
1)
3382 (if (and (ad-is-active function
)
3383 (ad-get-cache-definition function
))
3384 (list (ad-get-cache-definition function
)
3385 (ad-get-cache-id function
))))
3386 (ad-set-advice-info function old-advice-info
)
3387 ;; Don't `fset' function to nil if it was previously unbound:
3388 (if function-defined-p
3389 (ad-safe-fset function old-definition
)
3390 (fmakunbound function
)))))
3395 ;; Freezing transforms a `defadvice' into a redefining `defun/defmacro'
3396 ;; for the advised function without keeping any advice information. This
3397 ;; feature was jwz's idea: It generates a dumpable function definition
3398 ;; whose documentation can be written to the DOC file, and the generated
3399 ;; code does not need any Advice runtime support. Of course, frozen advices
3400 ;; cannot be undone.
3402 ;; Freezing only considers the advice of the particular `defadvice', other
3403 ;; already existing advices for the same function will be ignored. To ensure
3404 ;; proper interaction when an already advised function gets redefined with
3405 ;; a frozen advice, frozen advices always use the actual original definition
3406 ;; of the function, i.e., they are always at the core of the onion. E.g., if
3407 ;; an already advised function gets redefined with a frozen advice and then
3408 ;; unadvised, the frozen advice remains as the new definition of the function.
3410 ;; While multiple freeze advices for a single function or freeze-advising
3411 ;; of an already advised function are possible, they are better avoided,
3412 ;; because definition/compile/load ordering is relevant, and it becomes
3413 ;; incomprehensible pretty quickly.
3415 (defun ad-make-freeze-definition (function advice class position
)
3416 (if (not (ad-has-proper-definition function
))
3418 "ad-make-freeze-definition: `%s' is not yet defined"
3420 (let* ((name (ad-advice-name advice
))
3421 ;; With a unique origname we can have multiple freeze advices
3422 ;; for the same function, each overloading the previous one:
3424 (intern (format "%s-%s-%s" (ad-make-origname function
) class name
)))
3426 ;; If FUNCTION is already advised, we'll use its current origdef
3427 ;; as the original definition of the frozen advice:
3428 (or (ad-get-orig-definition function
)
3429 (symbol-function function
)))
3431 (if (ad-is-advised function
)
3432 (ad-copy-advice-info function
)))
3434 (symbol-function 'ad-make-advised-definition-docstring
))
3436 (symbol-function 'ad-make-origname
))
3440 ;; Make sure we construct a proper docstring:
3441 (ad-safe-fset 'ad-make-advised-definition-docstring
3442 'ad-make-freeze-docstring
)
3443 ;; Make sure `unique-origname' is used as the origname:
3444 (ad-safe-fset 'ad-make-origname
(lambda (x) unique-origname
))
3445 ;; No we reset all current advice information to nil and
3446 ;; generate an advised definition that's solely determined
3447 ;; by ADVICE and the current origdef of FUNCTION:
3448 (ad-set-advice-info function nil
)
3449 (ad-add-advice function advice class position
)
3450 ;; The following will provide proper real docstrings as
3451 ;; well as a definition that will make the compiler happy:
3452 (ad-set-orig-definition function orig-definition
)
3453 (ad-make-advised-definition function
))
3454 ;; Restore the old advice state:
3455 (ad-set-advice-info function old-advice-info
)
3456 ;; Restore functions:
3458 'ad-make-advised-definition-docstring real-docstring-fn
)
3459 (ad-safe-fset 'ad-make-origname real-origname-fn
))))
3460 (if frozen-definition
3461 (let* ((macro-p (ad-macro-p frozen-definition
))
3462 (body (cdr (if macro-p
3463 (ad-lambdafy frozen-definition
)
3464 frozen-definition
))))
3466 (if (not (fboundp ',unique-origname
))
3467 (fset ',unique-origname
3468 ;; avoid infinite recursion in case the function
3469 ;; we want to freeze is already advised:
3470 (or (ad-get-orig-definition ',function
)
3471 (symbol-function ',function
))))
3472 (,(if macro-p
'defmacro
'defun
)
3477 ;; @@ Activation and definition handling:
3478 ;; ======================================
3480 (defun ad-should-compile (function compile
)
3481 "Return non-nil if the advised FUNCTION should be compiled.
3482 If COMPILE is non-nil and not a negative number then it returns t.
3483 If COMPILE is a negative number then it returns nil.
3484 If COMPILE is nil then the result depends on the value of
3485 `ad-default-compilation-action' (which see)."
3486 (if (integerp compile
)
3490 (cond ((eq ad-default-compilation-action
'never
)
3492 ((eq ad-default-compilation-action
'always
)
3494 ((eq ad-default-compilation-action
'like-original
)
3495 (or (ad-subr-p (ad-get-orig-definition function
))
3496 (ad-compiled-p (ad-get-orig-definition function
))))
3497 ;; everything else means `maybe':
3498 (t (featurep 'byte-compile
))))))
3500 (defun ad-activate-advised-definition (function compile
)
3501 "Redefine FUNCTION with its advised definition from cache or scratch.
3502 The resulting FUNCTION will be compiled if `ad-should-compile' returns t.
3503 The current definition and its cache-id will be put into the cache."
3504 (let ((verified-cached-definition
3505 (if (ad-verify-cache-id function
)
3506 (ad-get-cache-definition function
))))
3507 (ad-safe-fset function
3508 (or verified-cached-definition
3509 (ad-make-advised-definition function
)))
3510 (if (ad-should-compile function compile
)
3511 (ad-compile-function function
))
3512 (if verified-cached-definition
3513 (if (not (eq verified-cached-definition
(symbol-function function
)))
3514 ;; we must have compiled, cache the compiled definition:
3516 function
(symbol-function function
) (ad-get-cache-id function
)))
3517 ;; We created a new advised definition, cache it with a proper id:
3518 (ad-clear-cache function
)
3519 ;; ad-make-cache-id needs the new cached definition:
3520 (ad-set-cache function
(symbol-function function
) nil
)
3522 function
(symbol-function function
) (ad-make-cache-id function
)))))
3524 (defun ad-handle-definition (function)
3525 "Handle re/definition of an advised FUNCTION during de/activation.
3526 If FUNCTION does not have an original definition associated with it and
3527 the current definition is usable, then it will be stored as FUNCTION's
3528 original definition. If no current definition is available (even in the
3529 case of undefinition) nothing will be done. In the case of redefinition
3530 the action taken depends on the value of `ad-redefinition-action' (which
3531 see). Redefinition occurs when FUNCTION already has an original definition
3532 associated with it but got redefined with a new definition and then
3533 de/activated. If you do not like the current redefinition action change
3534 the value of `ad-redefinition-action' and de/activate again."
3535 (let ((original-definition (ad-get-orig-definition function
))
3536 (current-definition (if (ad-real-definition function
)
3537 (symbol-function function
))))
3538 (if original-definition
3539 (if current-definition
3540 (if (and (not (eq current-definition original-definition
))
3541 ;; Redefinition with an advised definition from a
3542 ;; different function won't count as such:
3543 (not (ad-advised-definition-p current-definition
)))
3544 ;; we have a redefinition:
3545 (if (not (memq ad-redefinition-action
'(accept discard warn
)))
3546 (error "ad-handle-definition (see its doc): `%s' %s"
3547 function
"invalidly redefined")
3548 (if (eq ad-redefinition-action
'discard
)
3549 (ad-safe-fset function original-definition
)
3550 (ad-set-orig-definition function current-definition
)
3551 (if (eq ad-redefinition-action
'warn
)
3552 (message "ad-handle-definition: `%s' got redefined"
3554 ;; either advised def or correct original is in place:
3556 ;; we have an undefinition, ignore it:
3558 (if current-definition
3559 ;; we have a first definition, save it as original:
3560 (ad-set-orig-definition function current-definition
)
3561 ;; we don't have anything noteworthy:
3565 ;; @@ The top-level advice interface:
3566 ;; ==================================
3569 (defun ad-activate (function &optional compile
)
3570 "Activate all the advice information of an advised FUNCTION.
3571 If FUNCTION has a proper original definition then an advised
3572 definition will be generated from FUNCTION's advice info and the
3573 definition of FUNCTION will be replaced with it. If a previously
3574 cached advised definition was available, it will be used.
3575 The optional COMPILE argument determines whether the resulting function
3576 or a compilable cached definition will be compiled. If it is negative
3577 no compilation will be performed, if it is positive or otherwise non-nil
3578 the resulting function will be compiled, if it is nil the behavior depends
3579 on the value of `ad-default-compilation-action' (which see).
3580 Activation of an advised function that has an advice info but no actual
3581 pieces of advice is equivalent to a call to `ad-unadvise'. Activation of
3582 an advised function that has actual pieces of advice but none of them are
3583 enabled is equivalent to a call to `ad-deactivate'. The current advised
3584 definition will always be cached for later usage."
3586 (list (ad-read-advised-function "Activate advice of")
3587 current-prefix-arg
))
3588 (if ad-activate-on-top-level
3589 ;; avoid recursive calls to `ad-activate':
3590 (ad-with-auto-activation-disabled
3591 (if (not (ad-is-advised function
))
3592 (error "ad-activate: `%s' is not advised" function
)
3593 (ad-handle-definition function
)
3594 ;; Just return for forward advised and not yet defined functions:
3595 (if (ad-get-orig-definition function
)
3596 (if (not (ad-has-any-advice function
))
3597 (ad-unadvise function
)
3598 ;; Otherwise activate the advice:
3599 (cond ((ad-has-redefining-advice function
)
3600 (ad-activate-advised-definition function compile
)
3601 (ad-set-advice-info-field function
'active t
)
3602 (eval (ad-make-hook-form function
'activation
))
3604 ;; Here we are if we have all disabled advices:
3605 (t (ad-deactivate function
)))))))))
3607 (defalias 'ad-activate-on
'ad-activate
)
3609 (defun ad-deactivate (function)
3610 "Deactivate the advice of an actively advised FUNCTION.
3611 If FUNCTION has a proper original definition, then the current
3612 definition of FUNCTION will be replaced with it. All the advice
3613 information will still be available so it can be activated again with
3614 a call to `ad-activate'."
3616 (list (ad-read-advised-function "Deactivate advice of" 'ad-is-active
)))
3617 (if (not (ad-is-advised function
))
3618 (error "ad-deactivate: `%s' is not advised" function
)
3619 (cond ((ad-is-active function
)
3620 (ad-handle-definition function
)
3621 (if (not (ad-get-orig-definition function
))
3622 (error "ad-deactivate: `%s' has no original definition"
3624 (ad-safe-fset function
(ad-get-orig-definition function
))
3625 (ad-set-advice-info-field function
'active nil
)
3626 (eval (ad-make-hook-form function
'deactivation
))
3629 (defun ad-update (function &optional compile
)
3630 "Update the advised definition of FUNCTION if its advice is active.
3631 See `ad-activate' for documentation on the optional COMPILE argument."
3633 (list (ad-read-advised-function
3634 "Update advised definition of" 'ad-is-active
)))
3635 (if (ad-is-active function
)
3636 (ad-activate function compile
)))
3638 (defun ad-unadvise (function)
3639 "Deactivate FUNCTION and then remove all its advice information.
3640 If FUNCTION was not advised this will be a noop."
3642 (list (ad-read-advised-function "Unadvise function")))
3643 (cond ((ad-is-advised function
)
3644 (if (ad-is-active function
)
3645 (ad-deactivate function
))
3646 (ad-clear-orig-definition function
)
3647 (ad-set-advice-info function nil
)
3648 (ad-pop-advised-function function
))))
3650 (defun ad-recover (function)
3651 "Try to recover FUNCTION's original definition, and unadvise it.
3652 This is more low-level than `ad-unadvise' in that it does not do
3653 deactivation, which might run hooks and get into other trouble.
3654 Use in emergencies."
3655 ;; Use more primitive interactive behavior here: Accept any symbol that's
3656 ;; currently defined in obarray, not necessarily with a function definition:
3659 (completing-read "Recover advised function: " obarray nil t
))))
3660 (cond ((ad-is-advised function
)
3661 (cond ((ad-get-orig-definition function
)
3662 (ad-safe-fset function
(ad-get-orig-definition function
))
3663 (ad-clear-orig-definition function
)))
3664 (ad-set-advice-info function nil
)
3665 (ad-pop-advised-function function
))))
3667 (defun ad-activate-regexp (regexp &optional compile
)
3668 "Activate functions with an advice name containing a REGEXP match.
3669 This activates the advice for each function
3670 that has at least one piece of advice whose name includes a match for REGEXP.
3671 See `ad-activate' for documentation on the optional COMPILE argument."
3673 (list (ad-read-regexp "Activate via advice regexp")
3674 current-prefix-arg
))
3675 (ad-do-advised-functions (function)
3676 (if (ad-find-some-advice function
'any regexp
)
3677 (ad-activate function compile
))))
3679 (defun ad-deactivate-regexp (regexp)
3680 "Deactivate functions with an advice name containing REGEXP match.
3681 This deactivates the advice for each function
3682 that has at least one piece of advice whose name includes a match for REGEXP."
3684 (list (ad-read-regexp "Deactivate via advice regexp")))
3685 (ad-do-advised-functions (function)
3686 (if (ad-find-some-advice function
'any regexp
)
3687 (ad-deactivate function
))))
3689 (defun ad-update-regexp (regexp &optional compile
)
3690 "Update functions with an advice name containing a REGEXP match.
3691 This reactivates the advice for each function
3692 that has at least one piece of advice whose name includes a match for REGEXP.
3693 See `ad-activate' for documentation on the optional COMPILE argument."
3695 (list (ad-read-regexp "Update via advice regexp")
3696 current-prefix-arg
))
3697 (ad-do-advised-functions (function)
3698 (if (ad-find-some-advice function
'any regexp
)
3699 (ad-update function compile
))))
3701 (defun ad-activate-all (&optional compile
)
3702 "Activate all currently advised functions.
3703 See `ad-activate' for documentation on the optional COMPILE argument."
3705 (ad-do-advised-functions (function)
3706 (ad-activate function compile
)))
3708 (defun ad-deactivate-all ()
3709 "Deactivate all currently advised functions."
3711 (ad-do-advised-functions (function)
3712 (ad-deactivate function
)))
3714 (defun ad-update-all (&optional compile
)
3715 "Update all currently advised functions.
3716 With prefix argument, COMPILE resulting advised definitions."
3718 (ad-do-advised-functions (function)
3719 (ad-update function compile
)))
3721 (defun ad-unadvise-all ()
3722 "Unadvise all currently advised functions."
3724 (ad-do-advised-functions (function)
3725 (ad-unadvise function
)))
3727 (defun ad-recover-all ()
3728 "Recover all currently advised functions. Use in emergencies.
3729 To recover a function means to try to find its original (pre-advice)
3730 definition, and delete all advice.
3731 This is more low-level than `ad-unadvise' in that it does not do
3732 deactivation, which might run hooks and get into other trouble."
3734 (ad-do-advised-functions (function)
3736 (ad-recover function
)
3740 ;; Completion alist of valid `defadvice' flags
3741 (defvar ad-defadvice-flags
3742 '(("protect") ("disable") ("activate")
3743 ("compile") ("preactivate") ("freeze")))
3746 (defmacro defadvice
(function args
&rest body
)
3747 "Define a piece of advice for FUNCTION (a symbol).
3748 The syntax of `defadvice' is as follows:
3750 \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3751 [DOCSTRING] [INTERACTIVE-FORM]
3754 FUNCTION ::= Name of the function to be advised.
3755 CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.
3756 NAME ::= Non-nil symbol that names this piece of advice.
3757 POSITION ::= `first' | `last' | NUMBER. Optional, defaults to `first',
3758 see also `ad-add-advice'.
3759 ARGLIST ::= An optional argument list to be used for the advised function
3760 instead of the argument list of the original. The first one found in
3761 before/around/after-advices will be used.
3762 FLAG ::= `protect'|`disable'|`activate'|`compile'|`preactivate'|`freeze'.
3763 All flags can be specified with unambiguous initial substrings.
3764 DOCSTRING ::= Optional documentation for this piece of advice.
3765 INTERACTIVE-FORM ::= Optional interactive form to be used for the advised
3766 function. The first one found in before/around/after-advices will be used.
3767 BODY ::= Any s-expression.
3769 Semantics of the various flags:
3770 `protect': The piece of advice will be protected against non-local exits in
3771 any code that precedes it. If any around-advice of a function is protected
3772 then automatically all around-advices will be protected (the complete onion).
3774 `activate': All advice of FUNCTION will be activated immediately if
3775 FUNCTION has been properly defined prior to this application of `defadvice'.
3777 `compile': In conjunction with `activate' specifies that the resulting
3778 advised function should be compiled.
3780 `disable': The defined advice will be disabled, hence, it will not be used
3781 during activation until somebody enables it.
3783 `preactivate': Preactivates the advised FUNCTION at macro-expansion/compile
3784 time. This generates a compiled advised definition according to the current
3785 advice state that will be used during activation if appropriate. Only use
3786 this if the `defadvice' gets actually compiled.
3788 `freeze': Expands the `defadvice' into a redefining `defun/defmacro' according
3789 to this particular single advice. No other advice information will be saved.
3790 Frozen advices cannot be undone, they behave like a hard redefinition of
3791 the advised function. `freeze' implies `activate' and `preactivate'. The
3792 documentation of the advised function can be dumped onto the `DOC' file
3795 See Info node `(elisp)Advising Functions' for comprehensive documentation.
3796 usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3797 [DOCSTRING] [INTERACTIVE-FORM]
3799 (declare (doc-string 3))
3800 (if (not (ad-name-p function
))
3801 (error "defadvice: Invalid function name: %s" function
))
3802 (let* ((class (car args
))
3803 (name (if (not (ad-class-p class
))
3804 (error "defadvice: Invalid advice class: %s" class
)
3806 (position (if (not (ad-name-p name
))
3807 (error "defadvice: Invalid advice name: %s" name
)
3808 (setq args
(nthcdr 2 args
))
3809 (if (ad-position-p (car args
))
3811 (setq args
(cdr args
))))))
3812 (arglist (if (listp (car args
))
3814 (setq args
(cdr args
)))))
3820 (try-completion (symbol-name flag
) ad-defadvice-flags
)))
3821 (cond ((eq completion t
) flag
)
3822 ((assoc completion ad-defadvice-flags
)
3823 (intern completion
))
3824 (t (error "defadvice: Invalid or ambiguous flag: %s"
3827 (advice (ad-make-advice
3828 name
(memq 'protect flags
)
3829 (not (memq 'disable flags
))
3830 `(advice lambda
,arglist
,@body
)))
3831 (preactivation (if (memq 'preactivate flags
)
3832 (ad-preactivate-advice
3833 function advice class position
))))
3834 ;; Now for the things to be done at evaluation time:
3835 (if (memq 'freeze flags
)
3836 ;; jwz's idea: Freeze the advised definition into a dumpable
3837 ;; defun/defmacro whose docs can be written to the DOC file:
3838 (ad-make-freeze-definition function advice class position
)
3841 (ad-add-advice ',function
',advice
',class
',position
)
3845 ;; the function will get compiled:
3846 ,(cond ((ad-macro-p (car preactivation
))
3850 (car preactivation
)))))
3852 ,(car preactivation
))))
3853 ',(car (cdr preactivation
)))))
3854 ,@(if (memq 'activate flags
)
3855 `((ad-activate ',function
3856 ,(if (memq 'compile flags
) t
))))
3863 (defmacro ad-with-originals
(functions &rest body
)
3864 "Binds FUNCTIONS to their original definitions and execute BODY.
3865 For any members of FUNCTIONS that are not currently advised the rebinding will
3866 be a noop. Any modifications done to the definitions of FUNCTIONS will be
3867 undone on exit of this macro."
3869 ;; Make let-variables to store current definitions:
3873 (setq index
(1+ index
))
3874 (list (intern (format "ad-oRiGdEf-%d" index
))
3875 `(symbol-function ',function
))))
3877 `(let ,current-bindings
3881 ;; Make forms to redefine functions to their
3882 ;; original definitions if they are advised:
3887 (setq index
(1+ index
))
3890 (or (ad-get-orig-definition ',function
)
3891 ,(car (nth index current-bindings
))))))
3895 ;; Make forms to back-define functions to the definitions
3896 ;; they had outside this macro call:
3901 (setq index
(1+ index
))
3904 ,(car (nth index current-bindings
)))))
3907 (if (not (get 'ad-with-originals
'lisp-indent-hook
))
3908 (put 'ad-with-originals
'lisp-indent-hook
1))
3911 ;; @@ Advising `documentation':
3912 ;; ============================
3913 ;; Use the advice mechanism to advise `documentation' to make it
3914 ;; generate proper documentation strings for advised definitions:
3916 ;; This makes sure we get the right arglist for `documentation'
3917 ;; during bootstrapping.
3918 (ad-define-subr-args 'documentation
'(function &optional raw
))
3920 ;; @@ Starting, stopping and recovering from the advice package magic:
3921 ;; ===================================================================
3923 (defun ad-start-advice ()
3924 "Start the automatic advice handling magic."
3926 ;; Advising `ad-activate-internal' means death!!
3927 (ad-set-advice-info 'ad-activate-internal nil
)
3928 (ad-safe-fset 'ad-activate-internal
'ad-activate
))
3930 (defun ad-stop-advice ()
3931 "Stop the automatic advice handling magic.
3932 You should only need this in case of Advice-related emergencies."
3934 ;; Advising `ad-activate-internal' means death!!
3935 (ad-set-advice-info 'ad-activate-internal nil
)
3936 (ad-safe-fset 'ad-activate-internal
'ad-activate-internal-off
))
3938 (defun ad-recover-normality ()
3939 "Undo all advice related redefinitions and unadvises everything.
3940 Use only in REAL emergencies."
3942 ;; Advising `ad-activate-internal' means death!!
3943 (ad-set-advice-info 'ad-activate-internal nil
)
3944 (ad-safe-fset 'ad-activate-internal
'ad-activate-internal-off
)
3946 (setq ad-advised-functions nil
))
3952 ;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0
3953 ;;; advice.el ends here