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