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