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