# HG changeset patch # User Roland McGrath # Date 742852255 0 # Node ID ccdff27edd2e7c452cb64083f62c76f1403a45f4 # Parent 76f7463245906cad003dbc3c1f97a48411ecbc16 Initial revision diff -r 76f746324590 -r ccdff27edd2e lisp/emacs-lisp/advice.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/advice.el Fri Jul 16 19:50:55 1993 +0000 @@ -0,0 +1,4329 @@ +;;; advice.el --- advice mechanism for Emacs Lisp functions + +;; Copyright (C) 1993 Free Software Foundation, Inc. + +;; Author: Hans Chalupsky +;; Created: 12 Dec 1992 +;; Version: advice.el,v 2.1 1993/05/26 00:07:58 hans Exp +;; Keywords: advice, function hooks + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; LCD Archive Entry: +;; advice|Hans Chalupsky|hans@cs.buffalo.edu| +;; Advice mechanism for Emacs Lisp functions| +;; 1993/05/26 00:07:58|2.1|~/packages/advice.el.Z| + + +;;; Commentary: + +;; @ Introduction: +;; =============== +;; This package implements a full-fledged Lisp-style advice mechanism +;; for Emacs Lisp. Advice is a clean and efficient way to modify the +;; behavior of Emacs Lisp functions without having to keep personal +;; modified copies of such functions around. A great number of such +;; modifications can be achieved by treating the original function as a +;; black box and specifying a different execution environment for it +;; with a piece of advice. Think of a piece of advice as a kind of fancy +;; hook that you can attach to any function/macro/subr. + +;; @ Highlights: +;; ============= +;; - Clean definition of multiple, named before/around/after advices +;; for functions, macros, subrs and special forms +;; - Full control over the arguments an advised function will receive, +;; the binding environment in which it will be executed, as well as the +;; value it will return. +;; - Allows re/definition of interactive behavior for functions and subrs +;; - Every piece of advice can have its documentation string which will be +;; combined with the original documentation of the advised function at +;; call-time of `documentation' for proper command-key substitution. +;; - The execution of every piece of advice can be protected against error +;; and non-local exits in preceding code or advices. +;; - Simple argument access either by name, or, more portable but as +;; efficient, via access macros +;; - Allows the specification of a different argument list for the advised +;; version of a function. +;; - Advised functions can be byte-compiled either at file-compile time +;; (see preactivation) or activation time. +;; - Separation of advice definition and activation +;; - Provides generally accessible function definition (after) hooks +;; - Forward advice is possible (an application of definition hooks), that is +;; as yet undefined or autoload functions can be advised without having to +;; preload the file in which they are defined. +;; - Forward redefinition is possible because around advice can be used to +;; completely redefine a function. +;; - A caching mechanism for advised definition provides for cheap deactivation +;; and reactivation of advised functions. +;; - Preactivation allows efficient construction and compilation of advised +;; definitions at file compile time without giving up the flexibility of +;; the advice mechanism. +;; - En/disablement mechanism allows the use of different "views" of advised +;; functions depending on what pieces of advice are currently en/disabled +;; - Provides manipulation mechanisms for sets of advised functions via +;; regular expressions that match advice names +;; - Allows definition of load-hooks for arbitrary Emacs Lisp files without +;; modification of these files + +;; @ How to get the latest advice.el: +;; ================================== +;; You can get the latest version of this package either via anonymous ftp +;; from ftp.cs.buffalo.edu (128.205.32.9) with pathname /pub/Emacs/advice.el, +;; or send email to hans@cs.buffalo.edu and I'll mail it to you. + +;; @ Overview, or how to read this file: +;; ===================================== +;; Advice has enough features now to justify an info file, however, I +;; didn't have the time yet to do all the necessary formatting. So, +;; until I do have the time or some kind soul does it for me I cramped +;; everything into the source file. Because about 50% of this file is +;; documentation it should be in outline-mode by default, but it is not. +;; If you choose to use outline-mode set `outline-regexp' to `";; @+"' +;; and use `M-x hide-body' to see just the headings. Use the various +;; other outline-mode functions to move around in the text. If you use +;; Lucid Emacs, you'll just have to wait until `selective-display' +;; works properly in order to be able to use outline-mode, sorry. +;; +;; And yes, I know: Documentation is for wimps. +;; +;; The four major sections of this file are: +;; +;; @ This initial information ...installation, customization etc. +;; @ Advice documentation: ...general documentation +;; @ Foo games: An advice tutorial ...teaches about advice by example +;; @ Advice implementation: ...actual code, yeah!! +;; +;; The latter three are actual headings which you can search for +;; directly in case outline-mode doesn't work for you. + +;; @ Restrictions: +;; =============== +;; - Advised functions/macros/subrs will only exhibit their advised behavior +;; when they are invoked via their function cell. This means that advice will +;; not work for the following: +;; + advised subrs that are called directly from other subrs or C-code +;; + advised subrs that got replaced with their byte-code during +;; byte-compilation (e.g., car) +;; + advised macros which were expanded during byte-compilation before +;; their advice was activated. +;; - This package was developed under GNU Emacs 18.59 and Lucid Emacs 19.6. +;; It was adapted and tested for GNU Emacs 19.8 and seems to work ok for +;; Epoch 4.2. For different Emacs environments your mileage may vary. + +;; @ Credits: +;; ========== +;; This package is an extension and generalization of packages such as +;; insert-hooks.el written by Noah S. Friedman, and advise.el written by +;; Raul J. Acevedo. Some ideas used in here come from these packages, +;; others come from the various Lisp advice mechanisms I've come across +;; so far, and a few are simply mine. + +;; @ Comments, suggestions, bug reports: +;; ===================================== +;; If you find any bugs, have suggestions for new advice features, find the +;; documentation wrong, confusing, incomplete, or otherwise unsatisfactory, +;; have any questions about advice.el, or have otherwise enlightening +;; comments feel free to send me email at . + +;; @ Safety Rules and Emergency Exits: +;; =================================== +;; Before we begin: CAUTION!! +;; advice.el provides you with a lot of rope to hang yourself on very +;; easily accessible trees, so, here are a few important things you +;; should know: Once advice has been started with `ad-start-advice' it +;; generates advised definitions of the `documentation' function, and, +;; if definition hooks are enabled (e.g., for forward advice), also of +;; `defun', `defmacro' and `fset' (if you use Jamie Zawinski's (jwz) +;; optimizing byte-compiler as standardly used in GNU Emacs-19 and +;; Lucid Emacs-19 (Lemacs), then enabling definition hooks will also +;; redefine the `byte-code' subr). All these changes can be undone at +;; any time with `M-x ad-stop-advice'. +;; +;; If you experience any strange behavior/errors etc. that you attribute to +;; advice.el or to some ill-advised function do one of the following: + +;; - M-x ad-deactivate FUNCTION (if you have a definite suspicion what +;; function gives you problems) +;; - M-x ad-deactivate-all (if you don't have a clue what's going wrong) +;; - M-x ad-stop-advice (if you think the problem is related to the +;; advised functions used by advice.el itself) +;; - M-x ad-recover-normality (for real emergencies) +;; - If none of the above solves your advice related problem go to another +;; terminal, kill your Emacs process and send me some hate mail. + +;; The first three measures have restarts, i.e., once you've figured out +;; the problem you can reactivate advised functions with either `ad-activate', +;; `ad-activate-all', or `ad-start-advice'. `ad-recover-normality' unadvises +;; everything so you won't be able to reactivate any advised functions, you'll +;; have to stick with their standard incarnations for the rest of the session. + +;; IMPORTANT: With advice.el loaded always do `M-x ad-deactivate-all' before +;; you byte-compile a file, because advised special forms and macros can lead +;; to unwanted compilation results. When you are done compiling use +;; `M-x ad-activate-all' to go back to the advised state of all your +;; advised functions. + +;; RELAX: advice.el is pretty safe even if you are oblivious to the above. +;; I use it extensively and haven't run into any serious trouble in a long +;; time. Just wanted you to be warned. + +;; @ Installation: +;; =============== +;; Put this file somewhere into your Emacs `load-path' and byte-compile it. +;; Both steps are mandatory! You cannot (and would not want to) run advice +;; uncompiled, and because there is bootstrapping going on the byte-compiler +;; needs to preload advice in order to compile it, hence, it has to find it +;; in your `load-path' (you can preload advice.el "by hand" before you compile +;; it if you don't want to put it into your `load-path'). Once you have +;; compiled advice put the following autoload declarations into your .emacs +;; to load it on demand +;; +;; (autoload 'defadvice "advice" "Define a piece of advice" nil t) +;; (autoload 'ad-add-advice "advice" "Add a piece of advice") +;; (autoload 'ad-start-advice "advice" "Start advice magic" t) +;; +;; or explicitly load it with (require 'advice) or (load "advice"). + +;; @@ Preloading: +;; ============== +;; If you preload the complete advice.el or its autoloads into a dumped Emacs +;; image and you use jwz's byte-compiler make sure advice gets loaded after the +;; byte-compiler runtime support is loaded so that `ad-use-jwz-byte-compiler' +;; receives the proper initial value. + +;; @ Customization: +;; ================ +;; Part of the advice magic does not start until you call `ad-start-advice' +;; which you can either do interactively, explicitly in your .emacs, or by +;; putting +;; +;; (setq ad-start-advice-on-load t) +;; +;; into your .emacs which will automatically start advice when the file gets +;; loaded. + +;; If you want to be able to forward advise functions, that is to advise them +;; when they are not yet defined or defined as autoloads, then you should put +;; the following into your .emacs +;; +;; (setq ad-activate-on-definition t) +;; +;; which will activate all advice at the time the function gets actually +;; defined/loaded. The value of this variable will not have any effect until +;; `ad-start-advice' gets executed. + +;; If you use a v18 Emacs but use jwz's byte-compiler and want to use +;; forward advice make sure that `ad-use-jwz-byte-compiler' has a non-NIL +;; value after advice.el got loaded. If it doesn't set it explicitly in +;; your .emacs with +;; +;; (setq ad-use-jwz-byte-compiler t) +;; +;; Also make sure that you read the paragraph on forward advice below to +;; find out about the trade-offs involved for this combination of features. + +;; Look at the documentation of `ad-redefinition-action' for possible values +;; of this variable. Its default value is `warn' which will print a warning +;; message when an already defined advised function gets redefined with a +;; new original definition and de/activated. + +;; @ Motivation: +;; ============= +;; Before I go on explaining how advice works, here are four simple examples +;; how this package can be used. The first three are very useful, the last one +;; is just a joke: + +;;(defadvice switch-to-buffer (before existing-buffers-only activate) +;; "When called interactively switch to existing buffers only, unless +;;when called with a prefix argument." +;; (interactive +;; (list (read-buffer "Switch to buffer: " (other-buffer) +;; (null current-prefix-arg))))) +;; +;;(defadvice switch-to-buffer (around confirm-non-existing-buffers activate) +;; "Switch to non-existing buffers only upon confirmation." +;; (interactive "BSwitch to buffer: ") +;; (if (or (get-buffer (ad-get-arg 0)) +;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0)))) +;; ad-do-it)) +;; +;;(defadvice find-file (before existing-files-only activate) +;; "Find existing files only" +;; (interactive "fFind file: ")) +;; +;;(defadvice car (around interactive activate) +;; "Make `car' an interactive function." +;; (interactive "xCar of list: ") +;; ad-do-it +;; (if (interactive-p) +;; (message "%s" ad-return-value))) + + +;; @ Advice documentation: +;; ======================= +;; Below is general documentation of the various features of advice. For more +;; concrete examples check the corresponding sections in the tutorial part. + +;; @@ Terminology: +;; =============== +;; - GNU Emacs-19: GNU's version of Emacs with major version 19 +;; - Lemacs: Lucid's version of Emacs with major version 19 +;; - v18: Any Emacs with major version 18 or built as an extension to that +;; (such as Epoch) +;; - v19: Any Emacs with major version 19 +;; - jwz: Jamie Zawinski - keeper of Lemacs and creator of the optimizing +;; byte-compiler used in v19s. +;; - advices: Short for "pieces of advice". + +;; @@ Defining a piece of advice with `defadvice': +;; =============================================== +;; The main means of defining a piece of advice is the macro `defadvice', +;; there is no interactive way of specifying a piece of advice. A call to +;; `defadvice' has the following syntax which is similar to the syntax of +;; `defun/defmacro': +;; +;; (defadvice ( [] [] {}*) +;; [ [] [] ] +;; {}* ) + +;; is the name of the function/macro/subr to be advised. + +;; is the class of the advice which has to be one of `before', +;; `around', `after', `activation' or `deactivation' (the last two allow +;; definition of special act/deactivation hooks). + +;; is the name of the advice which has to be a non-NIL symbol. +;; Names uniquely identify a piece of advice in a certain advice class, +;; hence, advices can be redefined by defining an advice with the same class +;; and name. Advice names are global symbols, hence, the same name space +;; conventions used for function names should be applied. + +;; An optional specifies where in the current list of advices of +;; the specified this new advice will be placed. has to +;; be either `first', `last' or a number that specifies a zero-based +;; position (`first' is equivalent to 0). If no position is specified +;; `first' will be used as a default. If this call to `defadvice' redefines +;; an already existing advice (see above) then the position argument will +;; be ignored and the position of the already existing advice will be used. + +;; An optional which has to be a list can be used to define the +;; argument list of the advised function. This argument list should of +;; course be compatible with the argument list of the original function, +;; otherwise functions that call the advised function with the original +;; argument list in mind will break. If more than one advice specify an +;; argument list then the first one (the one with the smallest position) +;; found in the list of before/around/after advices will be used. + +;; is a list of symbols that specify further information about the +;; advice. All flags can be specified with unambiguous initial substrings. +;; `activate': Specifies that the advice information of the advised +;; function should be activated right after this advice has been +;; defined. In forward advices `activate' will be ignored. +;; `protect': Specifies that this advice should be protected against +;; non-local exits and errors in preceding code/advices. +;; `compile': Specifies that the advised function should be byte-compiled. +;; This flag will be ignored unless `activate' is also specified. +;; `disable': Specifies that the defined advice should be disabled, hence, +;; it will not be used in an activation until somebody enables it. +;; `preactivate': Specifies that the advised function should get preactivated +;; at macro-expansion/compile time of this `defadvice'. This +;; generates a compiled advised definition according to the +;; current advice state which will be used during activation +;; if appropriate. Only use this if the `defadvice' gets +;; actually compiled (with a v18 byte-compiler put the `defadvice' +;; into the body of a `defun' to accomplish proper compilation). + +;; An optional can be supplied to document the advice. +;; On call of the `documentation' function it will be combined with the +;; documentation strings of the original function and other advices. + +;; An optional form can be supplied to change/add +;; interactive behavior of the original function. If more than one advice +;; has an `(interactive ...)' specification then the first one (the one +;; with the smallest position) found in the list of before/around/after +;; advices will be used. + +;; A possibly empty list of specifies the body of the advice in +;; an implicit progn. The body of an advice can access/change arguments, +;; the return value, the binding environment, and can have all sorts of +;; other side effects. + +;; @@ Assembling advised definitions: +;; ================================== +;; Suppose a function/macro/subr/special-form has N pieces of before advice, +;; M pieces of around advice and K pieces of after advice. Assuming none of +;; the advices is protected, its advised definition will look like this +;; (body-form indices correspond to the position of the respective advice in +;; that advice class): + +;; ([macro] lambda +;; [ [] [(interactive ...)] ] +;; (let (ad-return-value) +;; {}* +;; .... +;; {}* +;; {}* +;; {}* +;; .... +;; {}* +;; (setq ad-return-value +;; >) +;; {}* +;; .... +;; {}* +;; {}* +;; {}* +;; .... +;; {}* +;; ad-return-value)) + +;; Macros and special forms will be redefined as macros, hence the optional +;; [macro] in the beginning of the definition. + +;; is either the argument list of the original function or the +;; first argument list defined in the list of before/around/after advices. +;; The values of variables can be accessed/changed in the body of +;; an advice by simply referring to them by their original name, however, +;; more portable argument access macros are also provided (see below). For +;; subrs/special-forms for which neither explicit argument list definitions +;; are available, nor their documentation strings contain such definitions +;; (as they do v19s), `(&rest ad-subr-args)' will be used. + +;; is an optional, special documentation string which will +;; be expanded into a proper documentation string upon call of `documentation'. + +;; (interactive ...) is an optional interactive form either taken from the +;; original function or from a before/around/after advice. For advised +;; interactive subrs that do not have an interactive form specified in any +;; advice we have to use (interactive) and then call the subr interactively +;; if the advised function was called interactively, because the +;; interactive specification of subrs is not accessible. This is the only +;; case where changing the values of arguments will not have an affect +;; because they will be reset by the interactive specification of the subr. +;; If this is a problem one can always specify an interactive form in a +;; before/around/after advice to gain control over argument values that +;; were supplied interactively. +;; +;; Then the body forms of the various advices in the various classes of advice +;; are assembled in order. The forms of around advice L are normally part of +;; one of the forms of around advice L-1. An around advice can specify where +;; the forms of the wrapped or surrounded forms should go with the special +;; keyword `ad-do-it', which will be substituted with a `progn' containing the +;; forms of the surrounded code. + +;; The innermost part of the around advice onion is +;; > +;; whose form depends on the type of the original function. The variable +;; `ad-return-value' will be set to its result. This variable is visible to +;; all pieces of advice which can access and modify it before it gets returned. +;; +;; The semantic structure of advised functions that contain protected pieces +;; of advice is the same. The only difference is that `unwind-protect' forms +;; make sure that the protected advice gets executed even if some previous +;; piece of advice had an error or a non-local exit. If any around advice is +;; protected then the whole around advice onion will be protected. + +;; @@ Argument access in advised functions: +;; ======================================== +;; As already mentioned, the simplest way to access the arguments of an +;; advised function in the body of an advice is to refer to them by name. To +;; do that, the advice programmer needs to know either the names of the +;; argument variables of the original function, or the names used in the +;; argument list redefinition given in a piece of advice. While this simple +;; method might be sufficient in many cases, it has the disadvantage that it +;; is not very portable because it hardcodes the argument names into the +;; advice. If the definition of the original function changes the advice +;; might break even though the code might still be correct. Situations like +;; that arise, for example, if one advises a subr like `eval-region' which +;; gets redefined in a non-advice style into a function by the edebug +;; package. If the advice assumes `eval-region' to be a subr it might break +;; once edebug is loaded. Similar situations arise when one wants to use the +;; same piece of advice across different versions of Emacs. Some subrs in a +;; v18 Emacs are functions in v19 and vice versa, but for the most part the +;; semantics remain the same, hence, the same piece of advice might be usable +;; in both Emacs versions. + +;; As a solution to that advice provides argument list access macros that get +;; translated into the proper access forms at activation time, i.e., when the +;; advised definition gets constructed. Access macros access actual arguments +;; by position regardless of how these actual argument get distributed onto +;; the argument variables of a function. The rational behind this is that in +;; Emacs Lisp the semantics of an argument is strictly determined by its +;; position (there are no keyword arguments). + +;; Suppose the function `foo' is defined as +;; +;; (defun foo (x y &optional z &rest r) ....) +;; +;; and is then called with +;; +;; (foo 0 1 2 3 4 5 6) + +;; which means that X=0, Y=1, Z=2 and R=(3 4 5 6). The assumption is that +;; the semantics of an actual argument is determined by its position. It is +;; this semantics that has to be known by the advice programmer. Then s/he +;; can access these arguments in a piece of advice with some of the +;; following macros (the arrows indicate what value they will return): + +;; (ad-get-arg 0) -> 0 +;; (ad-get-arg 1) -> 1 +;; (ad-get-arg 2) -> 2 +;; (ad-get-arg 3) -> 3 +;; (ad-get-args 2) -> (2 3 4 5 6) +;; (ad-get-args 4) -> (4 5 6) + +;; `(ad-get-arg )' will return the actual argument that was supplied +;; at , `(ad-get-args )' will return the list of actual +;; arguments supplied starting at . Note that these macros can be +;; used without any knowledge about the form of the actual argument list of +;; the original function. + +;; Similarly, `(ad-set-arg )' can be used to set the +;; value of the actual argument at to . For example, +;; +;; (ad-set-arg 5 "five") +;; +;; will have the effect that R=(3 4 "five" 6) once the original function is +;; called. `(ad-set-args )' can be used to set +;; the list of actual arguments starting at to . +;; For example, +;; +;; (ad-set-args 0 '(5 4 3 2 1 0)) +;; +;; will have the effect that X=5, Y=4, Z=3 and R=(2 1 0) once the original +;; function is called. + +;; All these access macros are text macros rather than real Lisp macros. When +;; the advised definition gets constructed they get replaced with actual access +;; forms depending on the argument list of the advised function, i.e., after +;; that argument access is in most cases as efficient as using the argument +;; variable names directly. + +;; @@@ Accessing argument bindings of arbitrary functions: +;; ======================================================= +;; Some functions (such as `trace-function' defined in trace.el) need a +;; method of accessing the names and bindings of the arguments of an +;; arbitrary advised function. To do that within an advice one can use the +;; special keyword `ad-arg-bindings' which is a text macro that will be +;; substituted with a form that will evaluate to a list of binding +;; specifications, one for every argument variable. These binding +;; specifications can then be examined in the body of the advice. For +;; example, somewhere in an advice we could do this: +;; +;; (let* ((bindings ad-arg-bindings) +;; (firstarg (car bindings)) +;; (secondarg (car (cdr bindings)))) +;; ;; Print info about first argument +;; (print (format "%s=%s (%s)" +;; (ad-arg-binding-field firstarg 'name) +;; (ad-arg-binding-field firstarg 'value) +;; (ad-arg-binding-field firstarg 'type))) +;; ....) +;; +;; The `type' of an argument is either `required', `optional' or `rest'. +;; Wherever `ad-arg-bindings' appears a form will be inserted that evaluates +;; to the list of bindings, hence, in order to avoid multiple unnecessary +;; evaluations one should always bind it to some variable. + +;; @@@ Argument list mapping: +;; ========================== +;; Because `defadvice' allows the specification of the argument list of the +;; advised function we need a mapping mechanism that maps this argument list +;; onto that of the original function. For example, somebody might specify +;; `(sym newdef)' as the argument list of `fset', while advice might use +;; `(&rest ad-subr-args)' as the argument list of the original function +;; (depending on what Emacs version is used). Hence SYM and NEWDEF have to +;; be properly mapped onto the &rest variable when the original definition is +;; called. Advice automatically takes care of that mapping, hence, the advice +;; programmer can specify an argument list without having to know about the +;; exact structure of the original argument list as long as the new argument +;; list takes a compatible number/magnitude of actual arguments. + +;; @@@ Definition of subr argument lists: +;; ====================================== +;; When advice constructs the advised definition of a function it has to +;; know the argument list of the original function. For functions and macros +;; the argument list can be determined from the actual definition, however, +;; for subrs there is no such direct access available. In Lemacs and for some +;; subrs in GNU Emacs-19 the argument list of a subr can be determined from +;; its documentation string, in a v18 Emacs even that is not possible. If +;; advice cannot at all determine the argument list of a subr it uses +;; `(&rest ad-subr-args)' which will always work but is inefficient because +;; it conses up arguments. The macro `ad-define-subr-args' can be used by +;; the advice programmer to explicitly tell advice about the argument list +;; of a certain subr, for example, +;; +;; (ad-define-subr-args 'fset '(sym newdef)) +;; +;; is used by advice itself to tell a v18 Emacs about the arguments of `fset'. +;; The following can be used to undo such a definition: +;; +;; (ad-undefine-subr-args 'fset) +;; +;; The argument list definition is stored on the property list of the subr +;; name symbol. When an argument list could be determined from the +;; documentation string it will be cached under that property. The general +;; mechanism for looking up the argument list of a subr is the following: +;; 1) look for a definition stored on the property list +;; 2) if that failed try to infer it from the documentation string and +;; if successful cache it on the property list +;; 3) otherwise use `(&rest ad-subr-args)' + +;; @@ Activation and deactivation: +;; =============================== +;; The definition of an advised function does not change until all its advice +;; gets actually activated. Activation can either happen with the `activate' +;; flag specified in the `defadvice', with an explicit call or interactive +;; invocation of `ad-activate', or if forward advice is enabled (i.e., the +;; value of `ad-activate-on-definition' is t) at the time an already advised +;; function gets defined. + +;; When a function gets first activated its original definition gets saved, +;; all defined and enabled pieces of advice will get combined with the +;; original definition, the resulting definition might get compiled depending +;; on some conditions described below, and then the function will get +;; redefined with the advised definition. This also means that undefined +;; functions cannot get activated even though they might be already advised. + +;; The advised definition will get compiled either if `ad-activate' was called +;; interactively with a prefix argument, or called explicitly with its second +;; argument as t, or, if this was a case of forward advice if the original +;; definition of the function was compiled. If the advised definition was +;; constructed during "preactivation" (see below) then that definition will +;; be already compiled because it was constructed during byte-compilation of +;; the file that contained the `defadvice' with the `preactivate' flag. + +;; `ad-deactivate' can be used to back-define an advised function to its +;; original definition. It can be called interactively or directly. Because +;; `ad-activate' caches the advised definition the function can be +;; reactivated via `ad-activate' with only minor overhead (it is checked +;; whether the current advice state is consistent with the cached +;; definition, see the section on caching below). + +;; `ad-activate-regexp' and `ad-deactivate-regexp' can be used to de/activate +;; all currently advised function that have a piece of advice with a name that +;; contains a match for a regular expression. These functions can be used to +;; de/activate sets of functions depending on certain advice naming +;; conventions. + +;; Finally, `ad-activate-all' and `ad-deactivate-all' can be used to +;; de/activate all currently advised functions. These are useful to +;; (temporarily) return to an un/advised state. + +;; @@@ Reasons for the separation of advice definition and activation: +;; =================================================================== +;; As already mentioned, advising happens in two stages: + +;; 1) definition of various pieces of advice +;; 2) activation of all advice currently defined and enabled + +;; The advantage of this is that various pieces of advice can be defined +;; before they get combined into an advised definition which avoids +;; unnecessary constructions of intermediate advised definitions. The more +;; important advantage is that it allows the implementation of forward advice. +;; Advice information for a certain function accumulates as the value of the +;; `advice-info' property of the function symbol. This accumulation is +;; completely independent of the fact that that function might not yet be +;; defined. The special forms `defun' and `defmacro' have been advised to +;; check whether the function/macro they defined had advice information +;; associated with it. If so and forward advice is enabled, the original +;; definition will be saved, and then the advice will be activated. When a +;; file is loaded in a v18 Emacs the functions/macros it defines are also +;; defined with calls to `defun/defmacro'. Hence, we can forward advise +;; functions/macros which will be defined later during a load/autoload of some +;; file (for compiled files generated by jwz's byte-compiler in a v19 Emacs +;; this is slightly more complicated but the basic idea is the same). + +;; @@ Enabling/disabling pieces or sets of advice: +;; =============================================== +;; A major motivation for the development of this advice package was to bring +;; a little bit more structure into the function overloading chaos in Emacs +;; Lisp. Many packages achieve some of their functionality by adding a little +;; bit (or a lot) to the standard functionality of some Emacs Lisp function. +;; ange-ftp is a very popular package that achieves its magic by overloading +;; most Emacs Lisp functions that deal with files. A popular function that's +;; overloaded by many packages is `expand-file-name'. The situation that one +;; function is multiply overloaded can arise easily. + +;; Once in a while it would be desirable to be able to disable some/all +;; overloads of a particular package while keeping all the rest. Ideally - +;; at least in my opinion - these overloads would all be done with advice, +;; I know I am dreaming right now... In that ideal case the enable/disable +;; mechanism of advice could be used to achieve just that. + +;; Every piece of advice is associated with an enablement flag. When the +;; advised definition of a particular function gets constructed (e.g., during +;; activation) only the currently enabled pieces of advice will be considered. +;; This mechanism allows one to have different "views" of an advised function +;; dependent on what pieces of advice are currently enabled. + +;; Another motivation for this mechanism is that it allows one to define a +;; piece of advice for some function yet keep it dormant until a certain +;; condition is met. Until then activation of the function will not make use +;; of that piece of advice. Once the condition is met the advice can be +;; enabled and a reactivation of the function will add its functionality as +;; part of the new advised definition. For example, the advices of `defun' +;; etc. used by advice itself will stay disabled until `ad-start-advice' is +;; called and some variables have the proper values. Hence, if somebody +;; else advised these functions too and activates them the advices defined +;; by advice will get used only if they are intended to be used. + +;; The main interface to this mechanism are the interactive functions +;; `ad-enable-advice' and `ad-disable-advice'. For example, the following +;; would disable a particular advice of the function `foo': +;; +;; (ad-disable-advice 'foo 'before 'my-advice) +;; +;; This call by itself only changes the flag, to get the proper effect in +;; the advised definition too one has to activate `foo' with +;; +;; (ad-activate 'foo) +;; +;; or interactively. To disable whole sets of advices one can use a regular +;; expression mechanism. For example, let us assume that ange-ftp actually +;; used advice to overload all its functions, and that it used the +;; "ange-ftp-" prefix for all its advice names, then we could temporarily +;; disable all its advices with +;; +;; (ad-disable-regexp "^ange-ftp-") +;; +;; and the following call would put that actually into effect: +;; +;; (ad-activate-regexp "^ange-ftp-") +;; +;; A saver way would have been to use +;; +;; (ad-update-regexp "^ange-ftp-") +;; +;; instead which would have only reactivated currently actively advised +;; functions, but not functions that were currently deactivated. All these +;; functions can also be called interactively. + +;; A certain piece of advice is considered a match if its name contains a +;; match for the regular expression. To enable ange-ftp again we would use +;; `ad-enable-regexp' and then activate or update again. + +;; @@ Forward advice, function definition hooks: +;; ============================================= +;; Because most Emacs Lisp packages are loaded on demand via an autoload +;; mechanism it is essential to be able to "forward advise" functions. +;; Otherwise, proper advice definition and activation would make it necessary +;; to preload every file that defines a certain function before it can be +;; advised, which would partly defeat the purpose of the advice mechanism. + +;; In the following, "forward advice" always implies its automatic activation +;; once a function gets defined, and not just the accumulation of advice +;; information for a possibly undefined function. + +;; Advice implements forward advice mainly via the following: 1) Separation +;; of advice definition and activation that makes it possible to accumulate +;; advice information without having the original function already defined, +;; 2) special versions of the function defining functions `defun', `defmacro' +;; and `fset' that check for advice information whenever they define a +;; function. If advice information was found and forward advice is enabled +;; then the advice will immediately get activated when the function gets +;; defined. + +;; @@@ Enabling forward advice: +;; ============================ +;; Forward advice is enabled by setting `ad-activate-on-definition' to t +;; and then calling `ad-start-advice' which can either be done interactively, +;; directly with `(ad-start-advice)' in your .emacs, or by setting +;; `ad-start-advice-on-load' to t before advice gets loaded. For example, +;; putting the following into your .emacs will enable forward advice: +;; +;; (setq ad-start-advice-on-load t) +;; (setq ad-activate-on-definition t) +;; +;; "Activation on definition" means, that whenever a function gets defined +;; with either `defun', `defmacro', `fset' or by loading a byte-compiled +;; file, and the function has some advice-info stored with it then that +;; advice will get activated right away. + +;; If jwz's byte-compiler is used then `ad-use-jwz-byte-compiler' should +;; be t in order to make forward advice work with functions defined in +;; compiled files generated by that compiler. In v19s which use this +;; compiler the value of this variable will be correct automatically. +;; If you use a v18 Emacs in conjunction with jwz's compiler and you want +;; to use forward advice then you should check its value after loading +;; advice. If it is nil set it explicitly with +;; +;; (setq ad-use-jwz-byte-compiler t) +;; +;; along with `ad-activate-on-definition' before you start advice (see above). + +;; IMPORTANT: A v18 Emacs + jwz's compiler + forward advice means performance +;; tradeoffs which are described below. + +;; @@@ Forward advice with compiled files generated by jwz's byte-compiler: +;; ======================================================================== +;; The v18 byte-compiler only uses `defun/defmacro' to define compiled +;; functions, hence, providing advised versions of these functions was +;; sufficient to achieve forward advice. With the advent of Jamie Zawinski's +;; optimizing byte-compiler which is now standardly used in GNU Emacs-19 and +;; Lemacs things became more complicated. jwz's compiler defines functions +;; in hunks of byte-code without explicit usage of `defun/defmacro'. To +;; still provide forward advice even in this scenario, advice defines an +;; advised version of the `byte-code' subr that scans its arguments for +;; function definitions during the loading of compiled files. While this is +;; no problem in a v19 Emacs, because it uses a new datatype for compiled +;; code objects and the `byte-code' subr is only rarely used at all, it +;; presents a major problem in a v18 Emacs because there calls to +;; `byte-code' are the only means of executing compiled code (every body of +;; a compiled function contains a call to `byte-code'). Because the advised +;; `byte-code' has to perform some extra checks every call to a compiled +;; function becomes more expensive. + +;; Enabling forward advice leads to performance degradation in the following +;; situations: +;; - A v18 Emacs is used and the value of `ad-use-jwz-byte-compiler' is t +;; (either because jwz's byte-compiler is used instead of the standard v18 +;; compiler, or some compiled files generated by jwz's compiler are used). +;; - A v19 Emacs is used with some old-style v18 compiled files. +;; Some performance experiments I conducted showed that function call intensive +;; code (such as the highly recursive byte-compiler itself) slows down by a +;; factor of 1.8. Function call intensive code that runs while a file gets +;; loaded can slow down by a factor of 6! For the v19 scenario this performance +;; lossage would only apply to code that was loaded from old v18 compiled +;; files. + +;; MORAL: If you use a v18 Emacs in conjunction with jwz's byte-compiler you +;; should think twice whether you really need forward advice. There are some +;; alternatives to forward advice described below that might give you what +;; you need without the loss of performance (that performance loss probably +;; outweighs by far any performance gain due to the optimizing nature of jwz's +;; compiler). + +;; @@@ Alternatives to automatic activation of forward advice: +;; =========================================================== +;; If you use a v18 Emacs in conjunction with jwz's compiler, or you simply +;; don't trust the automatic activation mechanism of forward advice, then +;; you can use some of the following alternatives to get around that: +;; - Preload the file that contains the definition of the function that you +;; want to advice. Inelegant and wasteful, but it works. +;; - If the package that contains the definition of the function you want to +;; advise has any mode hooks, and the advised function is only used once such +;; a mode has been entered, then you can activate the advice in the mode +;; hook. Just put a form like `(ad-activate 'my-advised-fn t)' into the +;; hook definition. The caching mechanism will reuse advised definitions, +;; so calling that mode hook over and over again will not construct +;; advised definitions over and over again, so you won't loose any +;; performance. +;; - If your Emacs comes with file load hooks (such as v19's +;; `after-load-alist' mechanism), then you can put the activation form +;; into that, for example, add `("myfile" (ad-activate 'my-advised-fn t))' +;; to it to activate the advice right ater "myfile" got loaded. + +;; @@@ Function definition hooks: +;; ============================== +;; Automatic activation of forward advice is implemented as an application +;; of a more general function definition hook mechanism. After a function +;; gets re/defined with `defun/defmacro/fset' or via a hunk of byte-code +;; during the loading of a byte-compiled file, and function definition hooks +;; are enabled, then all hook functions stored in `ad-definition-hooks' are +;; run with the variable `ad-defined-function' bound to the name of the +;; currently defined function. + +;; Function definition hooks can be enabled with +;; +;; (setq ad-enable-definition-hooks t) +;; +;; before advice gets started with `ad-start-advice'. Setting +;; `ad-activate-on-definition' to t automatically enables definition hooks +;; regardless of the value of `ad-enable-definition-hooks'. + +;; @@@ Wish list: +;; ============== +;; - The implementation of definition hooks for v19 compiled files would be +;; safer if jwz's byte-compiler used something like `byte-code-tl' instead +;; of `byte-code' to execute hunks of function defining byte-code at the +;; top level of compiled files. +;; - Definition hooks should be implemented directly as part of the C-code +;; that implements `fset', because then advice.el wouldn't have to use all +;; these dirty hacks to achieve this functionality. + +;; @@ Caching of advised definitions: +;; ================================== +;; After an advised definition got constructed it gets cached as part of the +;; advised function's advice-info so it can be reused, for example, after an +;; intermediate deactivation. Because the advice-info of a function might +;; change between the time of caching and reuse a cached definition gets +;; a cache-id associated with it so it can be verified whether the cached +;; definition is still valid (the main application of this is preactivation +;; - see below). + +;; When an advised function gets activated and a verifiable cached definition +;; is available, then that definition will be used instead of creating a new +;; advised definition from scratch. If you want to make sure that a new +;; definition gets constructed then you should use `ad-clear-cache' before you +;; activate the advised function. + +;; @@ Preactivation: +;; ================= +;; Constructing an advised definition is moderately expensive. In a situation +;; where one package defines a lot of advised functions it might be +;; prohibitively expensive to do all the advised definition construction at +;; runtime. Preactivation is a mechanism that allows compile-time construction +;; of compiled advised definitions that can be activated cheaply during +;; runtime. Preactivation uses the caching mechanism to do that. Here's how it +;; works: + +;; When the byte-compiler compiles a `defadvice' that has the `preactivate' +;; flag specified, it uses the current original definition of the advised +;; function plus the advice specified in this `defadvice' (even if it is +;; specified as disabled) and all other currently enabled pieces of advice to +;; construct an advised definition and an identifying cache-id and makes them +;; part of the `defadvice' expansion which will then be compiled by the +;; byte-compiler (to ensure that in a v18 emacs you have to put the +;; `defadvice' inside a `defun' to get it compiled and then you have to call +;; that compiled `defun' in order to actually execute the `defadvice'). When +;; the file with the compiled, preactivating `defadvice' gets loaded the +;; precompiled advised definition will be cached on the advised function's +;; advice-info. When it gets activated (can be immediately on execution of the +;; `defadvice' or any time later) the cache-id gets checked against the +;; current state of advice and if it is verified the precompiled definition +;; will be used directly (the verification is pretty cheap). If it couldn't get +;; verified a new advised definition for that function will be built from +;; scratch, hence, the efficiency added by the preactivation mechanism does +;; not at all impair the flexibility of the advice mechanism. + +;; MORAL: In order get all the efficiency out of preactivation the advice +;; state of an advised function at the time the file with the +;; preactivating `defadvice' gets byte-compiled should be exactly +;; the same as it will be when the advice of that function gets +;; actually activated. If it is not there is a high chance that the +;; cache-id will not match and hence a new advised definition will +;; have to be constructed at runtime. + +;; Preactivation and forward advice do not contradict each other. It is +;; perfectly ok to load a file with a preactivating `defadvice' before the +;; original definition of the advised function is available. The constructed +;; advised definition will be used once the original function gets defined and +;; its advice gets activated. The only constraint is that at the time the +;; file with the preactivating `defadvice' got compiled the original function +;; definition was available. + +;; TIPS: Here are some indications that a preactivation did not work the way +;; you intended it to work: +;; - Activation of the advised function takes longer than usual/expected +;; - The byte-compiler gets loaded while an advised function gets +;; activated +;; - `byte-compile' is part of the `features' variable even though you +;; did not use the byte-compiler +;; Right now advice does not provide an elegant way to find out whether +;; and why a preactivation failed. What you can do is to trace the +;; function `ad-cache-id-verification-code' (with the function +;; `trace-function-background' defined in my trace.el package) before +;; any of your advised functions get activated. After they got +;; activated check whether all calls to `ad-cache-id-verification-code' +;; returned `verified' as a result. Other values indicate why the +;; verification failed which should give you enough information to +;; fix your preactivation/compile/load/activation sequence. + +;; IMPORTANT: There is one case (that I am aware of) that can make +;; preactivation fail, i.e., a preconstructed advised definition that does +;; NOT match the current state of advice gets used nevertheless. That case +;; arises if one package defines a certain piece of advice which gets used +;; during preactivation, and another package incompatibly redefines that +;; very advice (i.e., same function/class/name), and it is the second advice +;; that is available when the preconstructed definition gets activated, and +;; that was the only definition of that advice so far (`ad-add-advice' +;; catches advice redefinitions and clears the cache in such a case). +;; Catching that would make the cache verification too expensive. + +;; MORAL-II: Redefining somebody else's advice is BAAAAD (to speak with +;; George Walker Bush), and why would you redefine your own advice anyway? +;; Advice is a mechanism to facilitate function redefinition, not advice +;; redefinition (wait until I write meta-advice.el :-). If you really have +;; to undo somebody else's advice try to write a "neutralizing" advice. + +;; @@ Advising macros and special forms and other dangerous things: +;; ================================================================ +;; Look at the corresponding tutorial sections for more information on +;; these topics. Here it suffices to point out that the special treatment +;; of macros and special forms by the byte-compiler can lead to problems +;; when they get advised. Macros can create problems because they get +;; expanded at compile time, hence, they might not have all the necessary +;; runtime support and such advice cannot be de/activated or changed as +;; it is possible for functions. Special forms create problems because they +;; have to be advised "into" macros, i.e., an advised special form is a +;; implemented as a macro, hence, in most cases the byte-compiler will +;; not recognize it as a special form anymore which can lead to very strange +;; results. +;; +;; MORAL: - Only advise macros or special forms when you are absolutely sure +;; what you are doing. +;; - As a safety measure, always do `ad-deactivate-all' before you +;; byte-compile a file to make sure that even if some inconsiderate +;; person advised some special forms you'll get proper compilation +;; results. After compilation do `ad-activate-all' to get back to +;; the previous state. + +;; @@ Adding a piece of advice with `ad-add-advice': +;; ================================================= +;; The non-interactive function `ad-add-advice' can be used to add a piece of +;; advice to some function without using `defadvice'. This is useful if advice +;; has to be added somewhere by a function (also look at `ad-make-advice'). + +;; @@ Activation/deactivation advices, file load hooks: +;; ==================================================== +;; There are two special classes of advice called `activation' and +;; `deactivation'. The body forms of these advices are not included into the +;; advised definition of a function, rather they are assembled into a hook +;; form which will be evaluated whenever the advice-info of the advised +;; function gets activated or deactivated. One application of this mechanism +;; is to define file load hooks for files that do not provide such hooks +;; (v19s already come with a general file-load-hook mechanism, v18s don't). +;; For example, suppose you want to print a message whenever `file-x' gets +;; loaded, and suppose the last function defined in `file-x' is +;; `file-x-last-fn'. Then we can define the following advice: +;; +;; (defadvice file-x-last-fn (activation file-x-load-hook) +;; "Executed whenever file-x is loaded" +;; (if load-in-progress (message "Loaded file-x"))) +;; +;; This will constitute a forward advice for function `file-x-last-fn' which +;; will get activated when `file-x' is loaded (only if forward advice is +;; enabled of course). Because there are no "real" pieces of advice +;; available for it, its definition will not be changed, but the activation +;; advice will be run during its activation which is equivalent to having a +;; file load hook for `file-x'. + +;; @@ Summary of main advice concepts: +;; =================================== +;; - Definition: +;; A piece of advice gets defined with `defadvice' and added to the +;; `advice-info' property of a function. +;; - Enablement: +;; Every piece of advice has an enablement flag associated with it. Only +;; enabled advices are considered during construction of an advised +;; definition. +;; - Activation: +;; Redefine an advised function with its advised definition. Constructs +;; an advised definition from scratch if no verifiable cached advised +;; definition is available and caches it. +;; - Deactivation: +;; Back-define an advised function to its original definition. +;; - Update: +;; Reactivate an advised function but only if its advice is currently +;; active. This can be used to bring all currently advised function up +;; to date with the current state of advice without also activating +;; currently deactivated functions. +;; - Caching: +;; Is the saving of an advised definition and an identifying cache-id so +;; it can be reused, for example, for activation after deactivation. +;; - Preactivation: +;; Is the construction of an advised definition according to the current +;; state of advice during byte-compilation of a file with a preactivating +;; `defadvice'. That advised definition can then rather cheaply be used +;; during activation without having to construct an advised definition +;; from scratch at runtime. + +;; @@ Summary of interactive advice manipulation functions: +;; ======================================================== +;; The following interactive functions can be used to manipulate the state +;; of advised functions (all of them support completion on function names, +;; advice classes and advice names): + +;; - ad-activate to activate the advice of a FUNCTION +;; - ad-deactivate to deactivate the advice of a FUNCTION +;; - ad-update to activate the advice of a FUNCTION unless it was not +;; yet activated or is currently deactivated. +;; - ad-unadvise deactivates a FUNCTION and removes all of its advice +;; information, hence, it cannot be activated again +;; - ad-recover tries to redefine a FUNCTION to its original definition and +;; discards all advice information (a low-level `ad-unadvise'). +;; Use only in emergencies. + +;; - ad-remove-advice removes a particular piece of advice of a FUNCTION. +;; You still have to do call `ad-activate' or `ad-update' to +;; activate the new state of advice. +;; - ad-enable-advice enables a particular piece of advice of a FUNCTION. +;; - ad-disable-advice disables a particular piece of advice of a FUNCTION. +;; - ad-enable-regexp maps over all currently advised functions and enables +;; every advice whose name contains a match for a regular +;; expression. +;; - ad-disable-regexp disables matching advices. + +;; - ad-activate-regexp activates all advised function with a matching advice +;; - ad-deactivate-regexp deactivates all advised function with matching advice +;; - ad-update-regexp updates all advised function with a matching advice +;; - ad-activate-all activates all advised functions +;; - ad-deactivate-all deactivates all advised functions +;; - ad-update-all updates all advised functions +;; - ad-unadvise-all unadvises all advised functions +;; - ad-recover-all recovers all advised functions + +;; - ad-compile byte-compiles a function/macro if it is compilable. + +;; @@ Summary of forms with special meanings when used within an advice: +;; ===================================================================== +;; ad-return-value name of the return value variable (get/settable) +;; ad-subr-args name of &rest argument variable used for advised +;; subrs whose actual argument list cannot be +;; determined (get/settable) +;; (ad-get-arg ), (ad-get-args ), +;; (ad-set-arg ), (ad-set-args ) +;; argument access text macros to get/set the values of +;; actual arguments at a certain position +;; ad-arg-bindings text macro that returns the actual names, values +;; and types of the arguments as a list of bindings. The +;; order of the bindings corresponds to the order of the +;; arguments. The individual fields of every binding (name, +;; value and type) can be accessed with the function +;; `ad-arg-binding-field' (see example above). +;; ad-do-it text macro that identifies the place where the original +;; or wrapped definition should go in an around advice + + +;; @ Foo games: An advice tutorial +;; =============================== +;; The following tutorial was created in GNU Emacs 18.59. Left-justified +;; s-expressions are input forms followed by one or more result forms. +;; First we have to start the advice magic: +;; +;; (ad-start-advice) +;; nil +;; +;; We start by defining an innocent looking function `foo' that simply +;; adds 1 to its argument X: +;; +;; (defun foo (x) +;; "Add 1 to X." +;; (1+ x)) +;; foo +;; +;; (foo 3) +;; 4 +;; +;; @@ Defining a simple piece of advice: +;; ===================================== +;; Now let's define the first piece of advice for `foo'. To do that we +;; use the macro `defadvice' which takes a function name, a list of advice +;; specifiers and a list of body forms as arguments. The first element of +;; the advice specifiers is the class of the advice, the second is its name, +;; the third its position and the rest are some flags. The class of our +;; first advice is `before', its name is `fg-add2', its position among the +;; currently defined before advices (none so far) is `first', and the advice +;; will be `activate'ed immediately. Advice names are global symbols, hence, +;; the name space conventions used for function names should be applied. All +;; advice names in this tutorial will be prefixed with `fg' for `Foo Games' +;; (because everybody has the right to be inconsistent all the function names +;; used in this tutorial do NOT follow this convention). +;; +;; In the body of an advice we can refer to the argument variables of the +;; original function by name. Here we add 1 to X so the effect of calling +;; `foo' will be to actually add 2. All of the advice definitions below only +;; have one body form for simplicity, but there is no restriction to that +;; extent. Every piece of advice can have a documentation string which will +;; be combined with the documentation of the original function. +;; +;; (defadvice foo (before fg-add2 first activate) +;; "Add 2 to X." +;; (setq x (1+ x))) +;; foo +;; +;; (foo 3) +;; 5 +;; +;; @@ Specifying the position of an advice: +;; ======================================== +;; Now we define the second before advice which will cancel the effect of +;; the previous advice. This time we specify the position as 0 which is +;; equivalent to `first'. A number can be used to specify the zero-based +;; position of an advice among the list of advices in the same class. This +;; time we already have one before advice hence the position specification +;; actually has an effect. So, after the following definition the position +;; of the previous advice will be 1 even though we specified it with `first' +;; above, the reason for this is that the position argument is relative to +;; the currently defined pieces of advice which by now has changed. +;; +;; (defadvice foo (before fg-cancel-add2 0 activate) +;; "Again only add 1 to X." +;; (setq x (1- x))) +;; foo +;; +;; (foo 3) +;; 4 +;; +;; @@ Redefining a piece of advice: +;; ================================ +;; Now we define an advice with the same class and same name but with a +;; different position. Defining an advice in a class in which an advice with +;; that name already exists is interpreted as a redefinition of that +;; particular advice, in which case the position argument will be ignored +;; and the previous position of the redefined piece of advice is used. +;; Advice flags can be specified with non-ambiguous initial substrings, hence, +;; from now on we'll use `act' instead of the verbose `activate'. +;; +;; (defadvice foo (before fg-cancel-add2 last act) +;; "Again only add 1 to X." +;; (setq x (1- x))) +;; foo +;; +;; @@ Assembly of advised documentation: +;; ===================================== +;; The documentation strings of the various pieces of advice are assembled +;; in order which shows that advice `fg-cancel-add2' is still the first +;; `before' advice even though we specified position `last' above: +;; +;; (documentation 'foo) +;; "Add 1 to X. +;; +;; This function is advised with the following advice(s): +;; +;; fg-cancel-add2 (before): +;; Again only add 1 to X. +;; +;; fg-add2 (before): +;; Add 2 to X." +;; +;; @@ Advising interactive behavior: +;; ================================= +;; We can make a function interactive (or change its interactive behavior) +;; by specifying an interactive form in one of the before or around +;; advices (there could also be body forms in this advice). The particular +;; definition always assigns 5 as an argument to X which gives us 6 as a +;; result when we call foo interactively: +;; +;; (defadvice foo (before fg-inter last act) +;; "Use 5 as argument when called interactively." +;; (interactive (list 5))) +;; foo +;; +;; (call-interactively 'foo) +;; 6 +;; +;; If more than one advice have an interactive declaration, then the one of +;; the advice with the smallest position will be used (before advices go +;; before around and after advices), hence, the declaration below does +;; not have any effect: +;; +;; (defadvice foo (before fg-inter2 last act) +;; (interactive (list 6))) +;; foo +;; +;; (call-interactively 'foo) +;; 6 +;; +;; Let's have a look at what the definition of `foo' looks like now +;; (indentation added by hand for legibility): +;; +;; (symbol-function 'foo) +;; (lambda (x) +;; "$ad-doc: foo$" +;; (interactive (list 5)) +;; (let (ad-return-value) +;; (setq x (1- x)) +;; (setq x (1+ x)) +;; (setq ad-return-value (ad-Orig-foo x)) +;; ad-return-value)) +;; +;; @@ Around advices: +;; ================== +;; Now we'll try some `around' advices. An around advice is a wrapper around +;; the original definition. It can shadow or establish bindings for the +;; original definition, and it can look at and manipulate the value returned +;; by the original function. The position of the special keyword `ad-do-it' +;; specifies where the code of the original function will be executed. The +;; keyword can appear multiple times which will result in multiple calls of +;; the original function in the resulting advised code. Note, that if we don't +;; specify a position argument (i.e., `first', `last' or a number), then +;; `first' (or 0) is the default): +;; +;; (defadvice foo (around fg-times-2 act) +;; "First double X." +;; (let ((x (* x 2))) +;; ad-do-it)) +;; foo +;; +;; (foo 3) +;; 7 +;; +;; Around advices are assembled like onion skins where the around advice +;; with position 0 is the outermost skin and the advice at the last position +;; is the innermost skin which is directly wrapped around the call of the +;; original definition of the function. Hence, after the next `defadvice' we +;; will first multiply X by 2 then add 1 and then call the original +;; definition (i.e., add 1 again): +;; +;; (defadvice foo (around fg-add-1 last act) +;; "Add 1 to X." +;; (let ((x (1+ x))) +;; ad-do-it)) +;; foo +;; +;; (foo 3) +;; 8 +;; +;; Again, let's see what the definition of `foo' looks like so far: +;; +;; (symbol-function 'foo) +;; (lambda (x) +;; "$ad-doc: foo$" +;; (interactive (list 5)) +;; (let (ad-return-value) +;; (setq x (1- x)) +;; (setq x (1+ x)) +;; (let ((x (* x 2))) +;; (let ((x (1+ x))) +;; (setq ad-return-value (ad-Orig-foo x)))) +;; ad-return-value)) +;; +;; @@ Controlling advice activation: +;; ================================= +;; In every `defadvice' so far we have used the flag `activate' to activate +;; the advice immediately after its definition, and that's what we want in +;; most cases. However, if we define multiple pieces of advice for a single +;; function then activating every advice immediately is inefficient. A +;; better way to do this is to only activate the last defined advice. +;; For example: +;; +;; (defadvice foo (after fg-times-x) +;; "Multiply the result with X." +;; (setq ad-return-value (* ad-return-value x))) +;; foo +;; +;; This still yields the same result as before: +;; (foo 3) +;; 8 +;; +;; Now we define another advice and activate which will also activate the +;; previous advice `fg-times-x'. Note the use of the special variable +;; `ad-return-value' in the body of the advice which is set to the result of +;; the original function. If we change its value then the value returned by +;; the advised function will be changed accordingly: +;; +;; (defadvice foo (after fg-times-x-again act) +;; "Again multiply the result with X." +;; (setq ad-return-value (* ad-return-value x))) +;; foo +;; +;; Now the advices have an effect: +;; +;; (foo 3) +;; 72 +;; +;; @@ Protecting advice execution: +;; =============================== +;; Once in a while we define an advice to perform some cleanup action, +;; for example: +;; +;; (defadvice foo (after fg-cleanup last act) +;; "Do some cleanup." +;; (print "Let's clean up now!")) +;; foo +;; +;; However, in case of an error the cleanup won't be performed: +;; +;; (condition-case error +;; (foo t) +;; (error 'error-in-foo)) +;; error-in-foo +;; +;; To make sure a certain piece of advice gets executed even if some error or +;; non-local exit occurred in any preceding code, we can protect it by using +;; the `protect' keyword. (if any of the around advices is protected then the +;; whole around advice onion will be protected): +;; +;; (defadvice foo (after fg-cleanup prot act) +;; "Do some protected cleanup." +;; (print "Let's clean up now!")) +;; foo +;; +;; Now the cleanup form will be executed even in case of an error: +;; +;; (condition-case error +;; (foo t) +;; (error 'error-in-foo)) +;; "Let's clean up now!" +;; error-in-foo +;; +;; Again, let's see what `foo' looks like: +;; +;; (symbol-function 'foo) +;; (lambda (x) +;; "$ad-doc: foo$" +;; (interactive (list 5)) +;; (let (ad-return-value) +;; (unwind-protect +;; (progn (setq x (1- x)) +;; (setq x (1+ x)) +;; (let ((x (* x 2))) +;; (let ((x (1+ x))) +;; (setq ad-return-value (ad-Orig-foo x)))) +;; (setq ad-return-value (* ad-return-value x)) +;; (setq ad-return-value (* ad-return-value x))) +;; (print "Let's clean up now!")) +;; ad-return-value)) +;; +;; @@ Compilation of advised definitions: +;; ====================================== +;; Finally, we can specify the `compile' keyword in a `defadvice' to say +;; that we want the resulting advised function to be byte-compiled +;; (`compile' will be ignored unless we also specified `activate'): +;; +;; (defadvice foo (after fg-cleanup prot act comp) +;; "Do some protected cleanup." +;; (print "Let's clean up now!")) +;; foo +;; +;; Now `foo' is byte-compiled: +;; +;; (symbol-function 'foo) +;; (lambda (x) +;; "$ad-doc: foo$" +;; (interactive (byte-code "....." [5] 1)) +;; (byte-code "....." [ad-return-value x nil ((byte-code "....." [print "Let's clean up now!"] 2)) * 2 ad-Orig-foo] 6)) +;; +;; (foo 3) +;; "Let's clean up now!" +;; 72 +;; +;; @@ Enabling and disabling pieces of advice: +;; =========================================== +;; Once in a while it is desirable to temporarily disable a piece of advice +;; so that it won't be considered during activation, for example, if two +;; different packages advise the same function and one wants to temporarily +;; neutralize the effect of the advice of one of the packages. +;; +;; The following disables the after advice `fg-times-x' in the function `foo'. +;; All that does is to change a flag for this particular advice. All the +;; other information defining it will be left unchanged (e.g., its relative +;; position in this advice class, etc.). +;; +;; (ad-disable-advice 'foo 'after 'fg-times-x) +;; nil +;; +;; For this to have an effect we have to activate `foo': +;; +;; (ad-activate 'foo) +;; foo +;; +;; (foo 3) +;; "Let's clean up now!" +;; 24 +;; +;; If we want to disable all multiplication advices in `foo' we can use a +;; regular expression that matches the names of such advices. Actually, any +;; advice name that contains a match for the regular expression will be +;; called a match. A special advice class `any' can be used to consider +;; all advice classes: +;; +;; (ad-disable-advice 'foo 'any "^fg-.*times") +;; nil +;; +;; (ad-activate 'foo) +;; foo +;; +;; (foo 3) +;; "Let's clean up now!" +;; 5 +;; +;; To enable the disabled advice we could use either `ad-enable-advice' +;; similar to `ad-disable-advice', or as an alternative `ad-enable-regexp' +;; which will enable matching advices in ALL currently advised functions. +;; Hence, this can be used to dis/enable advices made by a particular +;; package to a set of functions as long as that package obeys standard +;; advice name conventions. We prefixed all advice names with `fg-', hence +;; the following will do the trick (`ad-enable-regexp' returns the number +;; of matched advices): +;; +;; (ad-enable-regexp "^fg-") +;; 9 +;; +;; The following will activate all currently active advised functions that +;; contain some advice matched by the regular expression. This is a save +;; way to update the activation of advised functions whose advice changed +;; in some way or other without accidentally also activating currently +;; deactivated functions: +;; +;; (ad-update-regexp "^fg-") +;; nil +;; +;; (foo 3) +;; "Let's clean up now!" +;; 72 +;; +;; Another use for the dis/enablement mechanism is to define a piece of advice +;; and keep it "dormant" until a particular condition is satisfied, i.e., until +;; then the advice will not be used during activation. The `disable' flag lets +;; one do that with `defadvice': +;; +;; (defadvice foo (before fg-1-more dis) +;; "Add yet 1 more." +;; (setq x (1+ x))) +;; foo +;; +;; (ad-activate 'foo) +;; foo +;; +;; (foo 3) +;; "Let's clean up now!" +;; 72 +;; +;; (ad-enable-advice 'foo 'before 'fg-1-more) +;; nil +;; +;; (ad-activate 'foo) +;; foo +;; +;; (foo 3) +;; "Let's clean up now!" +;; 160 +;; +;; @@ Caching: +;; =========== +;; Advised definitions get cached to allow efficient activation/deactivation +;; without having to reconstruct them if nothing in the advice-info of a +;; function has changed. The following idiom can be used to temporarily +;; deactivate functions that have a piece of advice defined by a certain +;; package (we save the old definition to check out caching): +;; +;; (setq old-definition (symbol-function 'foo)) +;; (lambda (x) ....) +;; +;; (ad-deactivate-regexp "^fg-") +;; nil +;; +;; (foo 3) +;; 4 +;; +;; (ad-activate-regexp "^fg-") +;; nil +;; +;; (eq old-definition (symbol-function 'foo)) +;; t +;; +;; (foo 3) +;; "Let's clean up now!" +;; 160 +;; +;; @@ Forward advice: +;; ================== +;; To enable automatic activation of forward advice we first have to set +;; `ad-activate-on-definition' to t and restart advice: +;; +;; (setq ad-activate-on-definition t) +;; t +;; +;; (ad-start-advice) +;; (ad-activate-defined-function) +;; +;; Let's define a piece of advice for an undefined function: +;; +;; (defadvice bar (before fg-sub-1-more act) +;; "Subtract one more from X." +;; (setq x (1- x))) +;; bar +;; +;; `bar' is not yet defined: +;; (fboundp 'bar) +;; nil +;; +;; Now we define it and the forward advice will get activated (only because +;; `ad-activate-on-definition' was t when we started advice above with +;; `ad-start-advice'): +;; +;; (defun bar (x) +;; "Subtract 1 from X." +;; (1- x)) +;; bar +;; +;; (bar 4) +;; 2 +;; +;; Redefinition will activate any available advice if the value of +;; `ad-redefinition-action' is either `warn', `accept' or `discard': +;; +;; (defun bar (x) +;; "Subtract 2 from X." +;; (- x 2)) +;; bar +;; +;; (bar 4) +;; 1 +;; +;; @@ Preactivation: +;; ================= +;; Constructing advised definitions is moderately expensive, hence, it is +;; desirable to have a way to construct them at byte-compile time. +;; Preactivation is a mechanism that allows one to do that. +;; +;; (defun fie (x) +;; "Multiply X by 2." +;; (* x 2)) +;; fie +;; +;; (defadvice fie (before fg-times-4 preact) +;; "Multiply X by 4." +;; (setq x (* x 2))) +;; fie +;; +;; This advice did not affect `fie'... +;; +;; (fie 2) +;; 4 +;; +;; ...but it constructed a cached definition that will be used once `fie' gets +;; activated as long as its current advice state is the same as it was during +;; preactivation: +;; +;; (setq cached-definition (ad-get-cache-definition 'fie)) +;; (lambda (x) ....) +;; +;; (ad-activate 'fie) +;; fie +;; +;; (eq cached-definition (symbol-function 'fie)) +;; t +;; +;; (fie 2) +;; 8 +;; +;; If you put a preactivating `defadvice' into an elisp file that gets byte- +;; compiled then the constructed advised definition will get compiled by +;; the byte-compiler. For that to occur in a v18 emacs you have to put the +;; `defadvice' inside a `defun' because the v18 compiler does not compile +;; top-level forms other than `defun' or `defmacro', for example, +;; +;; (defun fg-defadvice-fum () +;; (defadvice fum (before fg-times-4 preact act) +;; "Multiply X by 4." +;; (setq x (* x 2)))) +;; fg-defadvice-fum +;; +;; So far, no `defadvice' for `fum' got executed, but when we compile +;; `fg-defadvice-fum' the `defadvice' will be expanded by the byte compiler. +;; In order for preactivation to be effective we have to have a proper +;; definition of `fum' around at preactivation time, hence, we define it now: +;; +;; (defun fum (x) +;; "Multiply X by 2." +;; (* x 2)) +;; fum +;; +;; Now we compile the defining function which will construct an advised +;; definition during expansion of the `defadvice', compile it and store it +;; as part of the compiled `fg-defadvice-fum': +;; +;; (ad-compile-function 'fg-defadvice-fum) +;; (lambda nil (byte-code ...)) +;; +;; `fum' is still completely unaffected: +;; +;; (fum 2) +;; 4 +;; +;; (ad-get-advice-info 'fum) +;; nil +;; +;; (fg-defadvice-fum) +;; fum +;; +;; Now the advised version of `fum' is compiled because the compiled definition +;; constructed during preactivation was used, even though we did not specify +;; the `compile' flag: +;; +;; (symbol-function 'fum) +;; (lambda (x) +;; "$ad-doc: fum$" +;; (byte-code "....." [ad-return-value x nil * 2 ad-Orig-fum] 4)) +;; +;; (fum 2) +;; 8 +;; +;; A preactivated definition will only be used if it matches the current +;; function definition and advice information. If it does not match it +;; will simply be discarded and a new advised definition will be constructed +;; from scratch. For example, let's first remove all advice-info for `fum': +;; +;; (ad-unadvise 'fum) +;; (("fie") ("bar") ("foo") ...) +;; +;; And now define a new piece of advice: +;; +;; (defadvice fum (before fg-interactive act) +;; "Make fum interactive." +;; (interactive "nEnter x: ")) +;; fum +;; +;; When we now try to use a preactivation it will not be used because the +;; current advice state is different from the one at preactivation time. This +;; is no tragedy, everything will work as expected just not as efficient, +;; because a new advised definition has to be constructed from scratch: +;; +;; (fg-defadvice-fum) +;; fum +;; +;; A new uncompiled advised definition got constructed: +;; +;; (ad-compiled-p (symbol-function 'fum)) +;; nil +;; +;; (fum 2) +;; 8 +;; +;; MORAL: To get all the efficiency out of preactivation the function +;; definition and advice state at preactivation time must be the same as the +;; state at activation time. Preactivation does work with forward advice, all +;; that's necessary is that the definition of the forward advised function is +;; available when the `defadvice' with the preactivation gets compiled. +;; +;; @@ Portable argument access: +;; ============================ +;; So far, we always used the actual argument variable names to access an +;; argument in a piece of advice. For many advice applications this is +;; perfectly ok and keeps advices simple. However, it decreases portability +;; of advices because it assumes specific argument variable names. For example, +;; if one advises a subr such as `eval-region' which then gets redefined by +;; some package (e.g., edebug) into a function with different argument names, +;; then a piece of advice written for `eval-region' that was written with +;; the subr arguments in mind will break. Similar situations arise when one +;; switches between major Emacs versions, e.g., certain subrs in v18 are +;; functions in v19 and vice versa. Also, in v19s subr argument lists +;; are available and will be used, while they are not available in v18. +;; +;; Argument access text macros allow one to access arguments of an advised +;; function in a portable way without having to worry about all these +;; possibilities. These macros will be translated into the proper access forms +;; at activation time, hence, argument access will be as efficient as if +;; the arguments had been used directly in the definition of the advice. +;; +;; (defun fuu (x y z) +;; "Add 3 numbers." +;; (+ x y z)) +;; fuu +;; +;; (fuu 1 1 1) +;; 3 +;; +;; Argument access macros specify actual arguments at a certain position. +;; Position 0 access the first actual argument, position 1 the second etc. +;; For example, the following advice adds 1 to each of the 3 arguments: +;; +;; (defadvice fuu (before fg-add-1-to-all act) +;; "Adds 1 to all arguments." +;; (ad-set-arg 0 (1+ (ad-get-arg 0))) +;; (ad-set-arg 1 (1+ (ad-get-arg 1))) +;; (ad-set-arg 2 (1+ (ad-get-arg 2)))) +;; fuu +;; +;; (fuu 1 1 1) +;; 6 +;; +;; Now suppose somebody redefines `fuu' with a rest argument. Our advice +;; will still work because we used access macros (note, that automatic +;; advice activation is still in effect, hence, the redefinition of `fuu' +;; will automatically activate all its advice): +;; +;; (defun fuu (&rest numbers) +;; "Add NUMBERS." +;; (apply '+ numbers)) +;; fuu +;; +;; (fuu 1 1 1) +;; 6 +;; +;; (fuu 1 1 1 1 1 1) +;; 9 +;; +;; What's important to notice is that argument access macros access actual +;; arguments regardless of how they got distributed onto argument variables. +;; In Emacs Lisp the semantics of an actual argument is determined purely +;; by position, hence, as long as nobody changes the semantics of what a +;; certain actual argument at a certain position means the access macros +;; will do the right thing. +;; +;; Because of &rest arguments we need a second kind of access macro that +;; can access all actual arguments starting from a certain position: +;; +;; (defadvice fuu (before fg-print-args act) +;; "Print all arguments." +;; (print (ad-get-args 0))) +;; fuu +;; +;; (fuu 1 2 3 4 5) +;; (1 2 3 4 5) +;; 18 +;; +;; (defadvice fuu (before fg-set-args act) +;; "Swaps 2nd and 3rd arg and discards all the rest." +;; (ad-set-args 1 (list (ad-get-arg 2) (ad-get-arg 1)))) +;; fuu +;; +;; (fuu 1 2 3 4 4 4 4 4 4) +;; (1 3 2) +;; 9 +;; +;; (defun fuu (x y z) +;; "Add 3 numbers." +;; (+ x y z)) +;; +;; (fuu 1 2 3) +;; (1 3 2) +;; 9 +;; +;; @@ Defining the argument list of an advised function: +;; ===================================================== +;; Once in a while it might be desirable to advise a function and additionally +;; give it an extra argument that controls the advised code, for example, one +;; might want to make an interactive function sensitive to a prefix argument. +;; For such cases `defadvice' allows the specification of an argument list +;; for the advised function. Similar to the redefinition of interactive +;; behavior, the first argument list specification found in the list of before/ +;; around/after advices will be used. Of course, the specified argument list +;; should be downward compatible with the original argument list, otherwise +;; functions that call the advised function with the original argument list +;; in mind will break. +;; +;; (defun fii (x) +;; "Add 1 to X." +;; (1+ x)) +;; fii +;; +;; Now we advise `fii' to use an optional second argument that controls the +;; amount of incrementation. A list following the (optional) position +;; argument of the advice will be interpreted as an argument list +;; specification. This means you cannot specify an empty argument list, and +;; why would you want to anyway? +;; +;; (defadvice fii (before fg-inc-x (x &optional incr) act) +;; "Increment X by INCR (default is 1)." +;; (setq x (+ x (1- (or incr 1))))) +;; fii +;; +;; (fii 3) +;; 4 +;; +;; (fii 3 2) +;; 5 +;; +;; @@ Specifying argument lists of subrs: +;; ====================================== +;; The argument lists of subrs cannot be determined directly from Lisp. +;; This means that advice.el has to use `(&rest ad-subr-args)' as the +;; argument list of the advised subr which is not very efficient. In Lemacs +;; subr argument lists can be determined from their documentation string, in +;; GNU Emacs-19 this is the case for some but not all subrs. To accommodate +;; for the cases where the argument lists cannot be determined (e.g., in a +;; v18 Emacs) advice.el comes with a specification mechanism that allows the +;; advice programmer to tell advice what the argument list of a certain subr +;; really is. +;; +;; In a v18 Emacs the following will return the &rest idiom: +;; +;; (ad-arglist (symbol-function 'car)) +;; (&rest ad-subr-args) +;; +;; To tell advice what the argument list of `car' really is we +;; can do the following: +;; +;; (ad-define-subr-args 'car '(list)) +;; ((list)) +;; +;; Now `ad-arglist' will return the proper argument list (this method is +;; actually used by advice itself for the advised definition of `fset'): +;; +;; (ad-arglist (symbol-function 'car)) +;; (list) +;; +;; The defined argument list will be stored on the property list of the +;; subr name symbol. When advice looks for a subr argument list it first +;; checks for a definition on the property list, if that fails it tries +;; to infer it from the documentation string and caches it on the property +;; list if it was successful, otherwise `(&rest ad-subr-args)' will be used. +;; +;; @@ Advising interactive subrs: +;; ============================== +;; For the most part there is no difference between advising functions and +;; advising subrs. There is one situation though where one might have to write +;; slightly different advice code for subrs than for functions. This case +;; arises when one wants to access subr arguments in a before/around advice +;; when the arguments were determined by an interactive call to the subr. +;; Advice cannot determine what `interactive' form determines the interactive +;; behavior of the subr, hence, when it calls the original definition in an +;; interactive subr invocation it has to use `call-interactively' to generate +;; the proper interactive behavior. Thus up to that call the arguments of the +;; interactive subr will be nil. For example, the following advice for +;; `kill-buffer' will not work in an interactive invocation... +;; +;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) +;; (my-before-kill-buffer-hook (ad-get-arg 0))) +;; kill-buffer +;; +;; ...because the buffer argument will be nil in that case. The way out of +;; this dilemma is to provide an `interactive' specification that mirrors +;; the interactive behavior of the unadvised subr, for example, the following +;; will do the right thing even when `kill-buffer' is called interactively: +;; +;; (defadvice kill-buffer (before fg-kill-buffer-hook first act preact comp) +;; (interactive "bKill buffer: ") +;; (my-before-kill-buffer-hook (ad-get-arg 0))) +;; kill-buffer +;; +;; @@ Advising macros: +;; =================== +;; Advising macros is slightly different because there are two significant +;; time points in the invocation of a macro: Expansion and evaluation time. +;; For an advised macro instead of evaluating the original definition we +;; use `macroexpand', that is, changing argument values and binding +;; environments by pieces of advice has an affect during macro expansion +;; but not necessarily during evaluation. In particular, any side effects +;; of pieces of advice will occur during macro expansion. To also affect +;; the behavior during evaluation time one has to change the value of +;; `ad-return-value' in a piece of after advice. For example: +;; +;; (defmacro foom (x) +;; (` (list (, x)))) +;; foom +;; +;; (foom '(a)) +;; ((a)) +;; +;; (defadvice foom (before fg-print-x act) +;; "Print the value of X." +;; (print x)) +;; foom +;; +;; The following works as expected because evaluation immediately follows +;; macro expansion: +;; +;; (foom '(a)) +;; (quote (a)) +;; ((a)) +;; +;; However, the printing happens during expansion (or byte-compile) time: +;; +;; (macroexpand '(foom '(a))) +;; (quote (a)) +;; (list (quote (a))) +;; +;; If we want it to happen during evaluation time we have to do the +;; following (first remove the old advice): +;; +;; (ad-remove-advice 'foom 'before 'fg-print-x) +;; nil +;; +;; (defadvice foom (after fg-print-x act) +;; "Print the value of X." +;; (setq ad-return-value +;; (` (progn (print (, x)) +;; (, ad-return-value))))) +;; foom +;; +;; (macroexpand '(foom '(a))) +;; (progn (print (quote (a))) (list (quote (a)))) +;; +;; (foom '(a)) +;; (a) +;; ((a)) +;; +;; While this method might seem somewhat cumbersome, it is very general +;; because it allows one to influence macro expansion as well as evaluation. +;; In general, advising macros should be a rather rare activity anyway, in +;; particular, because compile-time macro expansion takes away a lot of the +;; flexibility and effectiveness of the advice mechanism. Macros that were +;; compile-time expanded before the advice was activated will of course never +;; exhibit the advised behavior. +;; +;; @@ Advising special forms: +;; ========================== +;; Now for something that should be even more rare than advising macros: +;; Advising special forms. Because special forms are irregular in their +;; argument evaluation behavior (e.g., `setq' evaluates the second but not +;; the first argument) they have to be advised into macros. A dangerous +;; consequence of this is that the byte-compiler will not recognize them +;; as special forms anymore (well, in most cases) and use their expansion +;; rather than the proper byte-code. Also, because the original definition +;; of a special form cannot be `funcall'ed, `eval' has to be used instead +;; which is less efficient. +;; +;; MORAL: Do not advise special forms unless you are completely sure about +;; what you are doing (some of the forward advice behavior is +;; implemented via advice of the special forms `defun' and `defmacro'). +;; As a safety measure one should always do `ad-deactivate-all' before +;; one byte-compiles a file to avoid any interference of advised +;; special forms. +;; +;; Apart from the safety concerns advising special forms is not any different +;; from advising plain functions or subrs. + + +;;; Change Log: + +;; advice.el,v +;; Revision 2.1 1993/05/26 00:07:58 hans +;; * advise `defalias' and `define-function' to properly handle forward +;; advice in GNU Emacs-19.7 and later +;; * fix minor bug in `ad-preactivate-advice' +;; * merge with FSF installation of version 2.0 +;; +;; Revision 2.0 1993/05/18 01:29:02 hans +;; * Totally revamped: Now also works with v19s, function indirection +;; instead of body copying for original function calls, caching of +;; advised definitions, en/disable mechanism, more and better +;; interactive functions, forward advice support for jwz's compiler, +;; definition hooks, portable argument access, argument list definition +;; for advised functions, preactivation mechanism, pretty comprehensive +;; docs (still no info file) +;; +;; Revision 1.8 1992/12/15 22:54:45 hans +;; * Replaced non-standard `member' with `memq'. +;; +;; Revision 1.7 1992/12/14 22:41:49 hans +;; * First publicly released version +;; +;; Revision 1.1 1992/12/12 05:37:33 hans +;; * Created + + +;;; Code: + +;; @ Advice implementation: +;; ======================== + +;; @@ Compilation idiosyncrasies: +;; ============================== + +;; `defadvice' expansion needs quite a few advice functions and variables, +;; hence, I need to preload the file before it can be compiled. To avoid +;; interference of bogus compiled files I always preload the source file: +(provide 'advice-preload) +;; During a normal load this is a noop: +(require 'advice-preload "advice.el") + +;; For the odd case that ``' does not have an autoload definition in some +;; Emacs we autoload it here. It is only needed for compilation, hence, +;; I don't want to unconditionally `require' it (re-autoloading ``' after +;; this file got preloaded will properly redefine this autoload): +(if (not (fboundp '`)) (autoload '` "backquote")) + + +;; @@ Variable definitions: +;; ======================== + +(defconst ad-version "2.1") + +(defconst ad-emacs19-p + (not (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19"))) + "Non-NIL if we run Emacs version 19 or higher. +This will be true for GNU Emacs-19 as well as Lemacs.") + +(defconst ad-lemacs-p + (and ad-emacs19-p (string-match "Lucid" emacs-version)) + "Non-NIL if we run Lucid's version of Emacs-19.") + +;;;###autoload +(defvar ad-start-advice-on-load nil + "*Non-NIL will start advice magic when this file gets loaded. +Also see function `ad-start-advice'.") + +;;;###autoload +(defvar ad-activate-on-definition nil + "*Non-NIL means automatic advice activation at function definition. +Set this variable to t if you want to enable forward advice (which is +automatic advice activation of a previously undefined function at the +point the function gets defined/loaded/autoloaded). The value of this +variable takes effect only during the execution of `ad-start-advice'. +If non-NIL it will enable definition hooks regardless of the value +of `ad-enable-definition-hooks'.") + +;;;###autoload +(defvar ad-redefinition-action 'warn + "*Defines what to do with redefinitions during de/activation. +Redefinition occurs if a previously activated function that already has an +original definition associated with it gets redefined and then de/activated. +In such a case we can either accept the current definition as the new +original definition, discard the current definition and replace it with the +old original, or keep it and raise an error. The values `accept', `discard', +`error' or `warn' govern what will be done. `warn' is just like `accept' but +it additionally prints a warning message. All other values will be +interpreted as `error'.") + +;;;###autoload +(defvar ad-definition-hooks nil + "*List of hooks to be run after a function definition. +The variable `ad-defined-function' will be bound to the name of +the currently defined function when the hook function is run.") + +;;;###autoload +(defvar ad-enable-definition-hooks nil + "*Non-NIL will enable hooks to be run on function definition. +Setting this variable is a noop unless the value of +`ad-activate-on-definition' (which see) is NIL.") + +;; The following autoload depends on proper preloading of the runtime +;; support of jwz's byte-compiler for accurate initialization: + +;;;###autoload +(defvar ad-use-jwz-byte-compiler + ;; True if jwz's bytecomp-runtime is loaded: + (fboundp 'eval-when-compile) + "*Non-NIL means Jamie Zawinski's v19 byte-compiler will be used. +If you use a v18 Emacs and don't use jwz's optimizing byte-compiler (the +normal case) then this variable should be NIL, because otherwise +enabling definition hooks (e.g., for forward advice) will redefine the +`byte-code' subr which will lead to some performance degradation for +byte-compiled code.") + + +;; @@ `fset/byte-code' hack for jwz's byte-compiler: +;; ================================================= +;; Because byte-compiled files that were generated by jwz's byte-compiler +;; (as standardly used in v19s) define compiled functions and macros via +;; `fset' and `byte-code' instead of `defun/defmacro' we have to advise +;; `fset' similar to `defun/defmacro' and redefine `byte-code' to allow +;; proper forward advice; hence, we have to make sure that there are +;; proper primitive versions around that can be used by the advice package +;; itself. +;; +;; Wish: A `byte-code-tl' function to be used at the top level of byte- +;; compiled files which could be advised for the purpose of forward +;; advice without creating all that trouble caused by redefining +;; `byte-code'. + +(if (not (fboundp 'ad-real-fset)) + (progn (fset 'ad-real-fset (symbol-function 'fset)) + ;; Copy byte-compiler properties: + (put 'ad-real-fset 'byte-compile (get 'fset 'byte-compile)) + (put 'ad-real-fset 'byte-opcode (get 'fset 'byte-opcode)))) + +(if (not (fboundp 'ad-real-byte-code)) + (fset 'ad-real-byte-code (symbol-function 'byte-code))) + + +;; @@ Some utilities: +;; ================== + +;; We don't want the local arguments to interfere with anything +;; referenced in the supplied functions => the cryptic casing: +(defun ad-substitute-tree (sUbTrEe-TeSt fUnCtIoN tReE) + ;;"Substitutes qualifying subTREEs with result of FUNCTION(subTREE). + ;;Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4) + ;;then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are + ;;allowed too. Once a qualifying subtree has been found its subtrees will + ;;not be considered anymore. (ad-substitute-tree 'atom 'identity tree) + ;;generates a copy of TREE." + (cond ((consp tReE) + (cons (if (funcall sUbTrEe-TeSt (car tReE)) + (funcall fUnCtIoN (car tReE)) + (if (consp (car tReE)) + (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (car tReE)) + (car tReE))) + (ad-substitute-tree sUbTrEe-TeSt fUnCtIoN (cdr tReE)))) + ((funcall sUbTrEe-TeSt tReE) + (funcall fUnCtIoN tReE)) + (t tReE))) + +;; this is just faster than `ad-substitute-tree': +(defun ad-copy-tree (tree) + ;;"Returns a copy of the list structure of TREE." + (cond ((consp tree) + (cons (ad-copy-tree (car tree)) + (ad-copy-tree (cdr tree)))) + (t tree))) + +(defmacro ad-dolist (varform &rest body) + "A Common-Lisp-style dolist iterator with the following syntax: + + (ad-dolist ( []) + {body-form}*) + +which will iterate over the list yielded by binding to the +current head at every iteration. If is supplied its value will +be returned at the end of the iteration, NIL otherwise. The iteration can be +exited prematurely with (ad-do-return [])." + (let ((expansion + (` (let ((ad-dO-vAr (, (car (cdr varform)))) + (, (car varform))) + (while ad-dO-vAr + (setq (, (car varform)) (car ad-dO-vAr)) + (,@ body) + ;;work around a backquote bug: + ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong + ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) + (, '(setq ad-dO-vAr (cdr ad-dO-vAr)))) + (, (car (cdr (cdr varform)))))))) + ;;ok, this wastes some cons cells but only during compilation: + (if (catch 'contains-return + (ad-substitute-tree + (function (lambda (subtree) + (cond ((eq (car-safe subtree) 'ad-dolist)) + ((eq (car-safe subtree) 'ad-do-return) + (throw 'contains-return t))))) + 'identity body) + nil) + (` (catch 'ad-dO-eXiT (, expansion))) + expansion))) + +(defmacro ad-do-return (value) + (` (throw 'ad-dO-eXiT (, value)))) + +(if (not (get 'ad-dolist 'lisp-indent-hook)) + (put 'ad-dolist 'lisp-indent-hook 1)) + + +;; @@ Advice info access fns: +;; ========================== + +;; Advice information for a particular function is stored on the +;; advice-info property of the function symbol. It is stored as an +;; alist of the following format: +;; +;; ((active . t/nil) +;; (before adv1 adv2 ...) +;; (around adv1 adv2 ...) +;; (after adv1 adv2 ...) +;; (activation adv1 adv2 ...) +;; (deactivation adv1 adv2 ...) +;; (origname . ) +;; (cache . ( . ))) + +;; List of currently advised though not necessarily activated functions +;; (this list is maintained as a completion table): +(defvar ad-advised-functions nil) + +(defmacro ad-pushnew-advised-function (function) + ;;"Add FUNCTION to `ad-advised-functions' unless its already there." + (` (if (not (assoc (symbol-name (, function)) ad-advised-functions)) + (setq ad-advised-functions + (cons (list (symbol-name (, function))) + ad-advised-functions))))) + +(defmacro ad-pop-advised-function (function) + ;;"Remove FUNCTION from `ad-advised-functions'." + (` (setq ad-advised-functions + (delq (assoc (symbol-name (, function)) ad-advised-functions) + ad-advised-functions)))) + +(defmacro ad-do-advised-functions (varform &rest body) + ;;"`ad-dolist'-style iterator that maps over `ad-advised-functions'. + ;; (ad-do-advised-functions ( []) + ;; {body-form}*) + ;;Also see `ad-dolist'. On each iteration will be bound to the + ;;name of an advised function (a symbol)." + (` (ad-dolist ((, (car varform)) + ad-advised-functions + (, (car (cdr varform)))) + (setq (, (car varform)) (intern (car (, (car varform))))) + (,@ body)))) + +(if (not (get 'ad-do-advised-functions 'lisp-indent-hook)) + (put 'ad-do-advised-functions 'lisp-indent-hook 1)) + +(defmacro ad-get-advice-info (function) + (` (get (, function) 'ad-advice-info))) + +(defmacro ad-set-advice-info (function advice-info) + (` (put (, function) 'ad-advice-info (, advice-info)))) + +(defmacro ad-copy-advice-info (function) + (` (ad-copy-tree (get (, function) 'ad-advice-info)))) + +(defmacro ad-is-advised (function) + ;;"Returns non-NIL if FUNCTION has any advice info associated with it. + ;;This does not mean that the advice is also active." + (list 'ad-get-advice-info function)) + +(defun ad-initialize-advice-info (function) + ;;"Initializes the advice info for FUNCTION. + ;;Assumes that FUNCTION has not yet been advised." + (ad-pushnew-advised-function function) + (ad-set-advice-info function (list (cons 'active nil)))) + +(defmacro ad-get-advice-info-field (function field) + ;;"Retrieves the value of the advice info FIELD of FUNCTION." + (` (cdr (assq (, field) (ad-get-advice-info (, function)))))) + +(defun ad-set-advice-info-field (function field value) + ;;"Destructively modifies VALUE of the advice info FIELD of FUNCTION." + (and (ad-is-advised function) + (cond ((assq field (ad-get-advice-info function)) + ;; A field with that name is already present: + (rplacd (assq field (ad-get-advice-info function)) value)) + (t;; otherwise, create a new field with that name: + (nconc (ad-get-advice-info function) + (list (cons field value))))))) + +;; Don't make this a macro so we can use it as a predicate: +(defun ad-is-active (function) + ;;"non-NIL if FUNCTION is advised and activated." + (ad-get-advice-info-field function 'active)) + + +;; @@ Access fns for single pieces of advice and related predicates: +;; ================================================================= + +(defun ad-make-advice (name protect enable definition) + "Constructs single piece of advice to be stored in some advice-info. +NAME should be a non-NIL symbol, PROTECT and ENABLE should each be +either t or nil, and DEFINITION should be a list of the form + (advice lambda ({}*) [docstring] [(interactive ...)] {body-form}*)" + (list name protect enable definition)) + +;; ad-find-advice uses the alist structure directly -> +;; change if this data structure changes!! +(defmacro ad-advice-name (advice) + (list 'car advice)) +(defmacro ad-advice-protected (advice) + (list 'nth 1 advice)) +(defmacro ad-advice-enabled (advice) + (list 'nth 2 advice)) +(defmacro ad-advice-definition (advice) + (list 'nth 3 advice)) + +(defun ad-advice-set-enabled (advice flag) + (rplaca (cdr (cdr advice)) flag)) + +(defun ad-class-p (thing) + (memq thing ad-advice-classes)) +(defun ad-name-p (thing) + (and thing (symbolp thing))) +(defun ad-position-p (thing) + (or (natnump thing) + (memq thing '(first last)))) + + +;; @@ Advice access functions: +;; =========================== + +;; List of defined advice classes: +(defvar ad-advice-classes '(before around after activation deactivation)) + +(defun ad-has-enabled-advice (function class) + ;;"True if at least one of FUNCTION's advices in CLASS is enabled." + (ad-dolist (advice (ad-get-advice-info-field function class)) + (if (ad-advice-enabled advice) (ad-do-return t)))) + +(defun ad-has-redefining-advice (function) + ;;"True if FUNCTION's advice info defines at least 1 redefining advice. + ;;Redefining advices affect the construction of an advised definition." + (and (ad-is-advised function) + (or (ad-has-enabled-advice function 'before) + (ad-has-enabled-advice function 'around) + (ad-has-enabled-advice function 'after)))) + +(defun ad-has-any-advice (function) + ;;"True if the advice info of FUNCTION defines at least one advice." + (and (ad-is-advised function) + (ad-dolist (class ad-advice-classes nil) + (if (ad-get-advice-info-field function class) + (ad-do-return t))))) + +(defun ad-get-enabled-advices (function class) + ;;"Returns the list of enabled advices of FUNCTION in CLASS." + (let (enabled-advices) + (ad-dolist (advice (ad-get-advice-info-field function class)) + (if (ad-advice-enabled advice) + (setq enabled-advices (cons advice enabled-advices)))) + (reverse enabled-advices))) + + +;; @@ Access functions for original definitions: +;; ============================================ +;; The advice-info of an advised function contains its `origname' which is +;; a symbol that is fbound to the original definition available at the first +;; proper activation of the function after a legal re/definition. If the +;; original was defined via fcell indirection then `origname' will be defined +;; just so. Hence, to get hold of the actual original definition of a function +;; we need to use `ad-real-orig-definition'. + +(defun ad-make-origname (function) + ;;"Makes name to be used to call the original FUNCTION." + (intern (format "ad-Orig-%s" function))) + +(defmacro ad-get-orig-definition (function) + (` (let ((origname (ad-get-advice-info-field (, function) 'origname))) + (if (fboundp origname) + (symbol-function origname))))) + +(defmacro ad-set-orig-definition (function definition) + (` (ad-real-fset + (ad-get-advice-info-field function 'origname) (, definition)))) + +(defmacro ad-clear-orig-definition (function) + (` (fmakunbound (ad-get-advice-info-field (, function) 'origname)))) + + +;; @@ Interactive input functions: +;; =============================== + +(defun ad-read-advised-function (&optional prompt predicate default) + ;;"Reads name of advised function with completion from the minibuffer. + ;;An optional PROMPT will be used to prompt for the function. PREDICATE + ;;plays the same role as for `try-completion' (which see). DEFAULT will + ;;be returned on empty input (defaults to the first advised function for + ;;which PREDICATE returns non-NIL)." + (if (null ad-advised-functions) + (error "ad-read-advised-function: There are no advised functions")) + (setq default + (or default + (ad-do-advised-functions (function) + (if (or (null predicate) + (funcall predicate function)) + (ad-do-return function))) + (error "ad-read-advised-function: %s" + "There are no qualifying advised functions"))) + (let* ((ad-pReDiCaTe predicate) + (function + (completing-read + (format "%s(default %s) " (or prompt "Function: ") default) + ad-advised-functions + (if predicate + (function + (lambda (function) + ;; Oops, no closures - the joys of dynamic scoping: + ;; `predicate' clashed with the `predicate' argument + ;; of Lemacs' `completing-read'..... + (funcall ad-pReDiCaTe (intern (car function)))))) + t))) + (if (equal function "") + (if (ad-is-advised default) + default + (error "ad-read-advised-function: `%s' is not advised" default)) + (intern function)))) + +(defvar ad-advice-class-completion-table + (mapcar '(lambda (class) (list (symbol-name class))) + ad-advice-classes)) + +(defun ad-read-advice-class (function &optional prompt default) + ;;"Reads a legal advice class with completion from the minibuffer. + ;;An optional PROMPT will be used to prompt for the class. DEFAULT will + ;;be returned on empty input (defaults to the first non-empty advice + ;;class of FUNCTION)." + (setq default + (or default + (ad-dolist (class ad-advice-classes) + (if (ad-get-advice-info-field function class) + (ad-do-return class))) + (error "ad-read-advice-class: `%s' has no advices" function))) + (let ((class (completing-read + (format "%s(default %s) " (or prompt "Class: ") default) + ad-advice-class-completion-table nil t))) + (if (equal class "") + default + (intern class)))) + +(defun ad-read-advice-name (function class &optional prompt) + ;;"Reads name of existing advice of CLASS for FUNCTION with completion. + ;;An optional PROMPT is used to prompt for the name." + (let* ((name-completion-table + (mapcar (function (lambda (advice) + (list (symbol-name (ad-advice-name advice))))) + (ad-get-advice-info-field function class))) + (default + (if (null name-completion-table) + (error "ad-read-advice-name: `%s' has no %s advice" + function class) + (car (car name-completion-table)))) + (prompt (format "%s(default %s) " (or prompt "Name: ") default)) + (name (completing-read prompt name-completion-table nil t))) + (if (equal name "") + (intern default) + (intern name)))) + +(defun ad-read-advice-specification (&optional prompt) + ;;"Reads a complete function/class/name specification from minibuffer. + ;;The list of read symbols will be returned. The optional PROMPT will + ;;be used to prompt for the function." + (let* ((function (ad-read-advised-function prompt)) + (class (ad-read-advice-class function)) + (name (ad-read-advice-name function class))) + (list function class name))) + +;; Use previous regexp as a default: +(defvar ad-last-regexp "") + +(defun ad-read-regexp (&optional prompt) + ;;"Reads a regular expression from the minibuffer." + (let ((regexp (read-from-minibuffer + (concat (or prompt "Regular expression: ") + (if (equal ad-last-regexp "") "" + (format "(default \"%s\") " ad-last-regexp)))))) + (setq ad-last-regexp + (if (equal regexp "") ad-last-regexp regexp)))) + + +;; @@ Finding, enabling, adding and removing pieces of advice: +;; =========================================================== + +(defmacro ad-find-advice (function class name) + ;;"Finds the first advice of FUNCTION in CLASS with NAME." + (` (assq (, name) (ad-get-advice-info-field (, function) (, class))))) + +(defun ad-advice-position (function class name) + ;;"Returns position of first advice of FUNCTION in CLASS with NAME." + (let* ((found-advice (ad-find-advice function class name)) + (advices (ad-get-advice-info-field function class))) + (if found-advice + (- (length advices) (length (memq found-advice advices)))))) + +(defun ad-find-some-advice (function class name) + "Finds the first of FUNCTION's advices in CLASS matching NAME. +NAME can be a symbol or a regular expression matching part of an advice name. +If CLASS is `any' all legal advice classes will be checked." + (if (ad-is-advised function) + (let (found-advice) + (ad-dolist (advice-class ad-advice-classes) + (if (or (eq class 'any) (eq advice-class class)) + (setq found-advice + (ad-dolist (advice (ad-get-advice-info-field + function advice-class)) + (if (or (and (stringp name) + (string-match + name (symbol-name + (ad-advice-name advice)))) + (eq name (ad-advice-name advice))) + (ad-do-return advice))))) + (if found-advice (ad-do-return found-advice)))))) + +(defun ad-enable-advice-internal (function class name flag) + ;;"Sets enable FLAG of FUNCTION's advices in CLASS matching NAME. + ;;If NAME is a string rather than a symbol then it's interpreted as a regular + ;;expression and all advices whose name contain a match for it will be + ;;affected. If CLASS is `any' advices in all legal advice classes will be + ;;considered. The number of changed advices will be returned (or NIL if + ;;FUNCTION was not advised)." + (if (ad-is-advised function) + (let ((matched-advices 0)) + (ad-dolist (advice-class ad-advice-classes) + (if (or (eq class 'any) (eq advice-class class)) + (ad-dolist (advice (ad-get-advice-info-field + function advice-class)) + (cond ((or (and (stringp name) + (string-match + name (symbol-name (ad-advice-name advice)))) + (eq name (ad-advice-name advice))) + (setq matched-advices (1+ matched-advices)) + (ad-advice-set-enabled advice flag)))))) + matched-advices))) + +(defun ad-enable-advice (function class name) + "Enables the advice of FUNCTION with CLASS and NAME." + (interactive (ad-read-advice-specification "Enable advice of: ")) + (if (ad-is-advised function) + (if (eq (ad-enable-advice-internal function class name t) 0) + (error "ad-enable-advice: `%s' has no %s advice matching `%s'" + function class name)) + (error "ad-enable-advice: `%s' is not advised" function))) + +(defun ad-disable-advice (function class name) + "Disables the advice of FUNCTION with CLASS and NAME." + (interactive (ad-read-advice-specification "Disable advice of: ")) + (if (ad-is-advised function) + (if (eq (ad-enable-advice-internal function class name nil) 0) + (error "ad-disable-advice: `%s' has no %s advice matching `%s'" + function class name)) + (error "ad-disable-advice: `%s' is not advised" function))) + +(defun ad-enable-regexp-internal (regexp class flag) + ;;"Sets enable FLAGs of all CLASS advices whose name contains a REGEXP match. + ;;If CLASS is `any' all legal advice classes are considered. The number of + ;;affected advices will be returned." + (let ((matched-advices 0)) + (ad-do-advised-functions (advised-function) + (setq matched-advices + (+ matched-advices + (or (ad-enable-advice-internal + advised-function class regexp flag) + 0)))) + matched-advices)) + +(defun ad-enable-regexp (regexp) + "Enables all advices with names that contain a match for REGEXP. +All currently advised functions will be considered." + (interactive + (list (ad-read-regexp "Enable advices via regexp: "))) + (let ((matched-advices (ad-enable-regexp-internal regexp 'any t))) + (if (interactive-p) + (message "%d matching advices enabled" matched-advices)) + matched-advices)) + +(defun ad-disable-regexp (regexp) + "Disables all advices with names that contain a match for REGEXP. +All currently advised functions will be considered." + (interactive + (list (ad-read-regexp "Disable advices via regexp: "))) + (let ((matched-advices (ad-enable-regexp-internal regexp 'any nil))) + (if (interactive-p) + (message "%d matching advices disabled" matched-advices)) + matched-advices)) + +(defun ad-remove-advice (function class name) + "Removes FUNCTION's advice with NAME from its advices in CLASS. +If such an advice was found it will be removed from the list of advices +in that CLASS." + (interactive (ad-read-advice-specification "Remove advice of: ")) + (if (ad-is-advised function) + (let* ((advice-to-remove (ad-find-advice function class name))) + (if advice-to-remove + (ad-set-advice-info-field + function class + (delq advice-to-remove (ad-get-advice-info-field function class))) + (error "ad-remove-advice: `%s' has no %s advice `%s'" + function class name))) + (error "ad-remove-advice: `%s' is not advised" function))) + +;;;###autoload +(defun ad-add-advice (function advice class position) + "Adds a piece of ADVICE to FUNCTION's list of advices in CLASS. +If FUNCTION already has one or more pieces of advice of the specified +CLASS then POSITION determines where the new piece will go. The value +of POSITION can either be `first', `last' or a number where 0 corresponds +to `first'. Numbers outside the range will be mapped to the closest +extreme position. If there was already a piece of ADVICE with the same +name, then the position argument will be ignored and the old advice +will be overwritten with the new one. + If the FUNCTION was not advised already, then its advice info will be +initialized. Redefining a piece of advice whose name is part of the cache-id +will clear the cache." + (cond ((not (ad-is-advised function)) + (ad-initialize-advice-info function) + (ad-set-advice-info-field + function 'origname (ad-make-origname function)))) + (let* ((previous-position + (ad-advice-position function class (ad-advice-name advice))) + (advices (ad-get-advice-info-field function class)) + ;; Determine a numerical position for the new advice: + (position (cond (previous-position) + ((eq position 'first) 0) + ((eq position 'last) (length advices)) + ((numberp position) + (max 0 (min position (length advices)))) + (t 0)))) + ;; Check whether we have to clear the cache: + (if (memq (ad-advice-name advice) (ad-get-cache-class-id function class)) + (ad-clear-cache function)) + (if previous-position + (setcar (nthcdr position advices) advice) + (if (= position 0) + (ad-set-advice-info-field function class (cons advice advices)) + (setcdr (nthcdr (1- position) advices) + (cons advice (nthcdr position advices))))))) + + +;; @@ Accessing and manipulating function definitions: +;; =================================================== + +(defmacro ad-macrofy (definition) + ;;"Takes a lambda function DEFINITION and makes a macro out of it." + (` (cons 'macro (, definition)))) + +(defmacro ad-lambdafy (definition) + ;;"Takes a macro function DEFINITION and makes a lambda out of it." + (` (cdr (, definition)))) + +;; There is no way to determine whether some subr is a special form or not, +;; hence we need this list (which is the same for v18s and v19s): +(defvar ad-special-forms + (mapcar 'symbol-function + '(and catch cond condition-case defconst defmacro + defun defvar function if interactive let let* + or prog1 prog2 progn quote save-excursion + save-restriction save-window-excursion setq + setq-default unwind-protect while + with-output-to-temp-buffer))) + +(defmacro ad-special-form-p (definition) + ;;"non-NIL if DEFINITION is a special form." + (list 'memq definition 'ad-special-forms)) + +(defmacro ad-interactive-p (definition) + ;;"non-NIL if DEFINITION can be called interactively." + (list 'commandp definition)) + +(defmacro ad-subr-p (definition) + ;;"non-NIL if DEFINITION is a subr." + (list 'subrp definition)) + +(defmacro ad-macro-p (definition) + ;;"non-NIL if DEFINITION is a macro." + (` (eq (car-safe (, definition)) 'macro))) + +(defmacro ad-lambda-p (definition) + ;;"non-NIL if DEFINITION is a lambda expression." + (` (eq (car-safe (, definition)) 'lambda))) + +;; see ad-make-advice for the format of advice definitions: +(defmacro ad-advice-p (definition) + ;;"non-NIL if DEFINITION is a piece of advice." + (` (eq (car-safe (, definition)) 'advice))) + +;; GNU Emacs-19/Lemacs cross-compatibility +;; (compiled-function-p is an obsolete function in GNU Emacs-19): +(if (and (not (fboundp 'byte-code-function-p)) + (fboundp 'compiled-function-p)) + (ad-real-fset 'byte-code-function-p 'compiled-function-p)) + +(defmacro ad-v19-compiled-p (definition) + ;;"non-NIL if DEFINITION is a compiled object of a v19 Emacs." + (` (and ad-emacs19-p + (or (byte-code-function-p (, definition)) + (and (ad-macro-p (, definition)) + (byte-code-function-p (ad-lambdafy (, definition)))))))) + +(defmacro ad-v19-compiled-code (compiled-definition) + ;;"Returns the byte-code object of a v19 COMPILED-DEFINITION." + (` (if (ad-macro-p (, compiled-definition)) + (ad-lambdafy (, compiled-definition)) + (, compiled-definition)))) + +(defun ad-lambda-expression (definition) + ;;"Returns the lambda expression of a function/macro/advice DEFINITION." + (cond ((ad-lambda-p definition) + definition) + ((ad-macro-p definition) + (ad-lambdafy definition)) + ((ad-advice-p definition) + (cdr definition)) + (t nil))) + +(defun ad-arglist (definition &optional name) + ;;"Returns the argument list of DEFINITION. + ;;If DEFINITION could be from a subr then its NAME should be + ;;supplied to make subr arglist lookup more efficient." + (cond ((ad-v19-compiled-p definition) + (aref (ad-v19-compiled-code definition) 0)) + ((consp definition) + (car (cdr (ad-lambda-expression definition)))) + ((ad-subr-p definition) + (if name + (ad-subr-arglist name) + ;; otherwise get it from its printed representation: + (setq name (format "%s" definition)) + (string-match "^#]+\\)>$" name) + (ad-subr-arglist + (intern (substring name (match-beginning 1) (match-end 1)))))))) + +;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish +;; a defined empty arglist `(nil)' from an undefined arglist: +(defmacro ad-define-subr-args (subr arglist) + (` (put (, subr) 'ad-subr-arglist (list (, arglist))))) +(defmacro ad-undefine-subr-args (subr) + (` (put (, subr) 'ad-subr-arglist nil))) +(defmacro ad-subr-args-defined-p (subr) + (` (get (, subr) 'ad-subr-arglist))) +(defmacro ad-get-subr-args (subr) + (` (car (get (, subr) 'ad-subr-arglist)))) + +(defun ad-subr-arglist (subr-name) + ;;"Retrieve arglist of the subr with SUBR-NAME. + ;;Either use the one stored under the `ad-subr-arglist' property, or, if we + ;;have a v19 Emacs try to retrieve it from the docstring and cache it under + ;;that property, or otherwise use `(&rest ad-subr-args)'." + (if (ad-subr-args-defined-p subr-name) + (ad-get-subr-args subr-name) + (let ((doc (if ad-emacs19-p + (documentation subr-name)))) + (cond ((and doc + (string-match "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc)) + (ad-define-subr-args + subr-name + (car (read-from-string doc (match-beginning 1) (match-end 1)))) + (ad-get-subr-args subr-name)) + (t '(&rest ad-subr-args)))))) + +(defun ad-docstring (definition) + ;;"Returns the unexpanded docstring of DEFINITION." + (let ((docstring + (if (ad-v19-compiled-p definition) + (condition-case nodoc + (aref (ad-v19-compiled-code definition) 4) + (error nil)) + (car (cdr (cdr (ad-lambda-expression definition))))))) + (if (or (stringp docstring) + (natnump docstring)) + docstring))) + +(defun ad-interactive-form (definition) + ;;"Returns the interactive form of DEFINITION." + (cond ((ad-v19-compiled-p definition) + (and (commandp definition) + (list 'interactive (aref (ad-v19-compiled-code definition) 5)))) + ((or (ad-advice-p definition) + (ad-lambda-p definition)) + (commandp (ad-lambda-expression definition))))) + +(defun ad-body-forms (definition) + ;;"Returns the list of body forms of DEFINITION." + (cond ((ad-v19-compiled-p definition) + (setq definition (ad-v19-compiled-code definition)) + ;; build a standard (byte-code ...) form from the v19 code + ;; (I don't think I ever use this): + (list (list 'byte-code + (aref definition 1) + (aref definition 2) + (aref definition 3)))) + ((consp definition) + (nthcdr (+ (if (ad-docstring definition) 1 0) + (if (ad-interactive-form definition) 1 0)) + (cdr (cdr (ad-lambda-expression definition))))))) + +(defun ad-compiled-p (definition) + ;;"non-NIL if DEFINITION is byte-compiled." + (or (ad-v19-compiled-p definition) + (memq (car-safe (car (ad-body-forms definition))) + '(byte-code ad-real-byte-code)))) + +;; Matches the docstring of an advised definition. +;; The first group of the regexp matches the function name: +(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$") + +(defun ad-make-advised-definition-docstring (function) + ;; Makes an identifying docstring for the advised definition of FUNCTION. + ;; Put function name into the documentation string so we can infer + ;; the name of the advised function from the docstring. This is needed + ;; to generate a proper advised docstring even if we are just given a + ;; definition (also see the defadvice for `documentation'): + (format "$ad-doc: %s$" (prin1-to-string function))) + +(defun ad-advised-definition-p (definition) + ;;"non-NIL if DEFINITION was generated from advice information." + (if (or (ad-lambda-p definition) + (ad-macro-p definition) + (ad-compiled-p definition)) + (let ((docstring (ad-docstring definition))) + (and (stringp docstring) + (string-match + ad-advised-definition-docstring-regexp docstring))))) + +(defun ad-definition-type (definition) + ;;"Returns symbol that describes the type of DEFINITION." + (if (ad-macro-p definition) + 'macro + (if (ad-subr-p definition) + (if (ad-special-form-p definition) + 'special-form + 'subr) + (if (or (ad-lambda-p definition) + (ad-compiled-p definition)) + 'function + (if (ad-advice-p definition) + 'advice))))) + +(defun ad-has-proper-definition (function) + ;;"True if FUNCTION is a symbol with a proper definition. + ;;For that it has to be fbound with a non-autoload definition." + (and (symbolp function) + (fboundp function) + (not (eq (car-safe (symbol-function function)) 'autoload)))) + +;; The following two are necessary for the sake of packages such as +;; ange-ftp which redefine functions via fcell indirection: +(defun ad-real-definition (function) + ;;"Finds FUNCTION's definition at the end of function cell indirection." + (if (ad-has-proper-definition function) + (let ((definition (symbol-function function))) + (if (symbolp definition) + (ad-real-definition definition) + definition)))) + +(defun ad-real-orig-definition (function) + ;;"Finds FUNCTION's real original definition starting from its `origname'." + (if (ad-is-advised function) + (ad-real-definition (ad-get-advice-info-field function 'origname)))) + +(defun ad-is-compilable (function) + ;;"True if FUNCTION has an interpreted definition that can be compiled." + (and (ad-has-proper-definition function) + (or (ad-lambda-p (symbol-function function)) + (ad-macro-p (symbol-function function))) + (not (ad-compiled-p (symbol-function function))))) + +;; Need this because the v18 `byte-compile' can't compile macros: +(defun ad-compile-function (function) + "Byte-compiles FUNCTION (or macro) if it is not yet compiled." + (interactive "aByte-compile function: ") + (if (ad-is-compilable function) + (or (progn + (require 'byte-compile "bytecomp") + (byte-compile function)) + ;; If we get here we must have a macro and a + ;; standard non-optimizing v18 byte-compiler: + (and (ad-macro-p (symbol-function function)) + (ad-real-fset + function (ad-macrofy + (byte-compile-lambda + (ad-lambda-expression + (symbol-function function))))))))) + +(defun ad-real-byte-codify (function) + ;;"Compile FUNCTION and use `ad-real-byte-code' in the compiled body. + ;;This is needed when forward advice with jwz-byte-compiled files is used in + ;;order to avoid infinite recursion and keep efficiency as high as possible." + (ad-compile-function function) + (let ((definition (symbol-function function))) + (cond ((ad-v19-compiled-p definition)) + ((ad-compiled-p definition) + ;; Use ad-real-byte-code in the body of function: + (setcar (car (ad-body-forms definition)) + 'ad-real-byte-code))))) + + +;; @@ Constructing advised definitions: +;; ==================================== +;; +;; Main design decisions about the form of advised definitions: +;; +;; A) How will original definitions be called? +;; B) What will argument lists of advised functions look like? +;; +;; Ad A) +;; I chose to use function indirection for all four types of original +;; definitions (functions, macros, subrs and special forms), i.e., create +;; a unique symbol `ad-Orig-' which is fbound to the original +;; definition and call it according to type and arguments. Functions and +;; subrs that don't have any &rest arguments can be called directly in a +;; `(ad-Orig- ....)' form. If they have a &rest argument we have to +;; use `apply'. Macros will be called with +;; `(macroexpand '(ad-Orig- ....))', and special forms also need a +;; form like that with `eval' instead of `macroexpand'. +;; +;; Ad B) +;; Use original arguments where possible and `(&rest ad-subr-args)' +;; otherwise, even though this seems to be more complicated and less +;; uniform than a general `(&rest args)' approach. My reason to still +;; do it that way is that in most cases my approach leads to the more +;; efficient form for the advised function, and portability (e.g., to +;; make the same advice work regardless of whether something is a +;; function or a subr) can still be achieved with argument access macros. + + +(defun ad-prognify (forms) + (cond ((<= (length forms) 1) + (car forms)) + (t (cons 'progn forms)))) + +;; @@@ Accessing argument lists: +;; ============================= + +(defun ad-parse-arglist (arglist) + ;;"Parses ARGLIST into its required, optional and rest parameters. + ;;A three-element list is returned, where the 1st element is the list of + ;;required arguments, the 2nd is the list of optional arguments, and the 3rd + ;;is the name of an optional rest parameter (or NIL)." + (let* (required optional rest) + (setq rest (car (cdr (memq '&rest arglist)))) + (if rest (setq arglist (reverse (cdr (memq '&rest (reverse arglist)))))) + (setq optional (cdr (memq '&optional arglist))) + (if optional + (setq required (reverse (cdr (memq '&optional (reverse arglist))))) + (setq required arglist)) + (list required optional rest))) + +(defun ad-retrieve-args-form (arglist) + ;;"Generates a form which evaluates into names/values/types of ARGLIST. + ;;When the form gets evaluated within a function with that argument list + ;;it will result in a list with one entry for each argument, where the + ;;first element of each entry is the name of the argument, the second + ;;element is its actual current value, and the third element is either + ;;`required', `optional' or `rest' depending on the type of the argument." + (let* ((parsed-arglist (ad-parse-arglist arglist)) + (rest (nth 2 parsed-arglist))) + (` (list + (,@ (mapcar (function + (lambda (req) + (` (list '(, req) (, req) 'required)))) + (nth 0 parsed-arglist))) + (,@ (mapcar (function + (lambda (opt) + (` (list '(, opt) (, opt) 'optional)))) + (nth 1 parsed-arglist))) + (,@ (if rest (list (` (list '(, rest) (, rest) 'rest))))) + )))) + +(defun ad-arg-binding-field (binding field) + (cond ((eq field 'name) (car binding)) + ((eq field 'value) (car (cdr binding))) + ((eq field 'type) (car (cdr (cdr binding)))))) + +(defun ad-list-access (position list) + (cond ((= position 0) list) + ((= position 1) (list 'cdr list)) + (t (list 'nthcdr position list)))) + +(defun ad-element-access (position list) + (cond ((= position 0) (list 'car list)) + ((= position 1) (` (car (cdr (, list))))) + (t (list 'nth position list)))) + +(defun ad-access-argument (arglist index) + ;;"Tells how to access ARGLIST's actual argument at position INDEX. + ;;For a required/optional arg it simply returns it, if a rest argument has + ;;to be accessed, it returns a list with the index and name." + (let* ((parsed-arglist (ad-parse-arglist arglist)) + (reqopt-args (append (nth 0 parsed-arglist) + (nth 1 parsed-arglist))) + (rest-arg (nth 2 parsed-arglist))) + (cond ((< index (length reqopt-args)) + (nth index reqopt-args)) + (rest-arg + (list (- index (length reqopt-args)) rest-arg))))) + +(defun ad-get-argument (arglist index) + ;;"Returns form to access ARGLIST's actual argument at position INDEX." + (let ((argument-access (ad-access-argument arglist index))) + (cond ((consp argument-access) + (ad-element-access + (car argument-access) (car (cdr argument-access)))) + (argument-access)))) + +(defun ad-set-argument (arglist index value-form) + ;;"Returns form to set ARGLIST's actual arg at INDEX to VALUE-FORM." + (let ((argument-access (ad-access-argument arglist index))) + (cond ((consp argument-access) + ;; should this check whether there actually is something to set? + (` (setcar (, (ad-list-access + (car argument-access) (car (cdr argument-access)))) + (, value-form)))) + (argument-access + (` (setq (, argument-access) (, value-form)))) + (t (error "ad-set-argument: No argument at position %d of `%s'" + index arglist))))) + +(defun ad-get-arguments (arglist index) + ;;"Returns form to access all actual arguments starting at position INDEX." + (let* ((parsed-arglist (ad-parse-arglist arglist)) + (reqopt-args (append (nth 0 parsed-arglist) + (nth 1 parsed-arglist))) + (rest-arg (nth 2 parsed-arglist)) + args-form) + (if (< index (length reqopt-args)) + (setq args-form (` (list (,@ (nthcdr index reqopt-args)))))) + (if rest-arg + (if args-form + (setq args-form (` (nconc (, args-form) (, rest-arg)))) + (setq args-form (ad-list-access (- index (length reqopt-args)) + rest-arg)))) + args-form)) + +(defun ad-set-arguments (arglist index values-form) + ;;"Makes form to assign elements of VALUES-FORM as actual ARGLIST args. + ;;The assignment starts at position INDEX." + (let ((values-index 0) + argument-access set-forms) + (while (setq argument-access (ad-access-argument arglist index)) + (if (symbolp argument-access) + (setq set-forms + (cons (ad-set-argument + arglist index + (ad-element-access values-index 'ad-vAlUeS)) + set-forms)) + (setq set-forms + (cons (if (= (car argument-access) 0) + (list 'setq + (car (cdr argument-access)) + (ad-list-access values-index 'ad-vAlUeS)) + (list 'setcdr + (ad-list-access (1- (car argument-access)) + (car (cdr argument-access))) + (ad-list-access values-index 'ad-vAlUeS))) + set-forms)) + ;; terminate loop + (setq arglist nil)) + (setq index (1+ index)) + (setq values-index (1+ values-index))) + (if (null set-forms) + (error "ad-set-arguments: No argument at position %d of `%s'" + index arglist) + (if (= (length set-forms) 1) + ;; For exactly one set-form we can use values-form directly,... + (ad-substitute-tree + (function (lambda (form) (eq form 'ad-vAlUeS))) + (function (lambda (form) values-form)) + (car set-forms)) + ;; ...if we have more we have to bind it to a variable: + (` (let ((ad-vAlUeS (, values-form))) + (,@ (reverse set-forms)) + ;; work around the old backquote bug: + (, 'ad-vAlUeS))))))) + +(defun ad-insert-argument-access-forms (definition arglist) + ;;"Expands arg-access text macros in DEFINITION according to ARGLIST." + (ad-substitute-tree + (function + (lambda (form) + (or (eq form 'ad-arg-bindings) + (and (memq (car-safe form) + '(ad-get-arg ad-get-args ad-set-arg ad-set-args)) + (integerp (car-safe (cdr form))))))) + (function + (lambda (form) + (if (eq form 'ad-arg-bindings) + (ad-retrieve-args-form arglist) + (let ((accessor (car form)) + (index (car (cdr form))) + (val (car (cdr (ad-insert-argument-access-forms + (cdr form) arglist))))) + (cond ((eq accessor 'ad-get-arg) + (ad-get-argument arglist index)) + ((eq accessor 'ad-set-arg) + (ad-set-argument arglist index val)) + ((eq accessor 'ad-get-args) + (ad-get-arguments arglist index)) + ((eq accessor 'ad-set-args) + (ad-set-arguments arglist index val))))))) + definition)) + +;; @@@ Mapping argument lists: +;; =========================== +;; Here is the problem: +;; Suppose function foo was called with (foo 1 2 3 4 5), and foo has the +;; argument list (x y &rest z), and we want to call the function bar which +;; has argument list (a &rest b) with a combination of x, y and z so that +;; the effect is just as if we had called (bar 1 2 3 4 5) directly. +;; The mapping should work for any two argument lists. + +(defun ad-map-arglists (source-arglist target-arglist) + "Makes funcall/apply form to map SOURCE-ARGLIST to TARGET-ARGLIST. +The arguments supplied to TARGET-ARGLIST will be taken from SOURCE-ARGLIST just +as if they had been supplied to a function with TARGET-ARGLIST directly. +Excess source arguments will be neglected, missing source arguments will be +supplied as NIL. Returns a funcall or apply form with the second element being +`function' which has to be replaced by an actual function argument. +Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return + (funcall function a (car args) (car (cdr args)) (nth 2 args))" + (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) + (source-reqopt-args (append (nth 0 parsed-source-arglist) + (nth 1 parsed-source-arglist))) + (source-rest-arg (nth 2 parsed-source-arglist)) + (parsed-target-arglist (ad-parse-arglist target-arglist)) + (target-reqopt-args (append (nth 0 parsed-target-arglist) + (nth 1 parsed-target-arglist))) + (target-rest-arg (nth 2 parsed-target-arglist)) + (need-apply (and source-rest-arg target-rest-arg)) + (target-arg-index -1)) + ;; This produces ``error-proof'' target function calls with the exception + ;; of a case like (&rest a) mapped onto (x &rest y) where the actual args + ;; supplied to A might not be enough to supply the required target arg X + (append (list (if need-apply 'apply 'funcall) 'function) + (cond (need-apply + ;; `apply' can take care of that directly: + (append source-reqopt-args (list source-rest-arg))) + (t (mapcar (function + (lambda (arg) + (setq target-arg-index (1+ target-arg-index)) + (ad-get-argument + source-arglist target-arg-index))) + (append target-reqopt-args + (and target-rest-arg + ;; If we have a rest arg gobble up + ;; remaining source args: + (nthcdr (length target-reqopt-args) + source-reqopt-args))))))))) + +(defun ad-make-mapped-call (source-arglist target-arglist target-function) + ;;"Makes form to call TARGET-FUNCTION with args from SOURCE-ARGLIST." + (let* ((mapped-form (ad-map-arglists source-arglist target-arglist))) + (if (eq (car mapped-form) 'funcall) + (cons target-function (cdr (cdr mapped-form))) + (prog1 mapped-form + (setcar (cdr mapped-form) (list 'quote target-function)))))) + +;; @@@ Making an advised documentation string: +;; =========================================== +;; New policy: The documentation string for an advised function will be built +;; at the time the advised `documentation' function is called. This has the +;; following advantages: +;; 1) command-key substitutions will automatically be correct +;; 2) No wasted string space due to big advised docstrings in caches or +;; compiled files that contain preactivations +;; The overall overhead for this should be negligible because people normally +;; don't lookup documentation for the same function over and over again. + +(defun ad-make-single-advice-docstring (advice class) + (let ((advice-docstring (ad-docstring (ad-advice-definition advice)))) + ;; Always show advice name/class even if there is no docstring: + (format "%s (%s):%s%s" + (ad-advice-name advice) class + (if advice-docstring "\n" "") + (or advice-docstring "")))) + +(defun ad-make-advised-docstring (function) + ;;"Constructs a documentation string for the advised FUNCTION. + ;;It concatenates the original documentation with the documentation + ;;strings of the individual pieces of advice. Name and class of every + ;;advice will be displayed too. The order of the advice documentation + ;;strings corresponds to before/around/after and the individual ordering + ;;in any of these classes." + (let* ((origdef (ad-real-orig-definition function)) + (origdoc + ;; Use this wacky apply construction to avoid an Lemacs compiler + ;; warning (its `documentation' has only 1 arg as opposed to GNU + ;; Emacs-19's version which has an optional `raw' arg): + (apply 'documentation + origdef + (if (and ad-emacs19-p (not ad-lemacs-p)) + ;; If we have GNU Emacs-19 retrieve raw doc, because + ;; key substitution will be taken care of later anyway: + '(t))))) + (concat (or origdoc "") + (if origdoc "\n\n" "\n") + ;; Always inform about advice even if there is no origdoc: + "This " (symbol-name (ad-definition-type origdef)) + " is advised with the following advice(s):" + ;; Combine advice docstrings: + (mapconcat + (function + (lambda (class) + (mapconcat + (function + (lambda (advice) + (concat + "\n\n" (ad-make-single-advice-docstring advice class)))) + (ad-get-enabled-advices function class) ""))) + ad-advice-classes "")))) + +;; @@@ Accessing overriding arglists and interactive forms: +;; ======================================================== + +(defun ad-advised-arglist (function) + ;;"Finds first defined arglist in FUNCTION's redefining advices." + (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (ad-get-enabled-advices function 'around) + (ad-get-enabled-advices function 'after))) + (let ((arglist (ad-arglist (ad-advice-definition advice)))) + (if arglist + ;; We found the first one, use it: + (ad-do-return arglist))))) + +(defun ad-advised-interactive-form (function) + ;;"Finds first interactive form in FUNCTION's redefining advices." + (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (ad-get-enabled-advices function 'around) + (ad-get-enabled-advices function 'after))) + (let ((interactive-form + (ad-interactive-form (ad-advice-definition advice)))) + (if interactive-form + ;; We found the first one, use it: + (ad-do-return interactive-form))))) + +;; @@@ Putting it all together: +;; ============================ + +(defun ad-make-advised-definition (function) + ;;"Generates an advised definition of FUNCTION from its advice info." + (if (and (ad-is-advised function) + (ad-has-redefining-advice function)) + (let* ((origdef (ad-real-orig-definition function)) + (origname (ad-get-advice-info-field function 'origname)) + (orig-interactive-p (ad-interactive-p origdef)) + (orig-subr-p (ad-subr-p origdef)) + (orig-special-form-p (ad-special-form-p origdef)) + (orig-macro-p (ad-macro-p origdef)) + ;; Construct the individual pieces that we need for assembly: + (orig-arglist (ad-arglist origdef function)) + (advised-arglist (or (ad-advised-arglist function) + orig-arglist)) + (advised-interactive-form (ad-advised-interactive-form function)) + (interactive-form + (cond (orig-macro-p nil) + (advised-interactive-form) + ((ad-interactive-form origdef)) + ;; Otherwise we must have a subr: make it interactive if + ;; we have to and initialize required arguments in case + ;; it is called interactively: + (orig-interactive-p + (let ((reqargs (car (ad-parse-arglist advised-arglist)))) + (if reqargs + (` (interactive + '(, (make-list (length reqargs) nil)))) + '(interactive)))))) + (orig-form + (cond ((or orig-special-form-p orig-macro-p) + ;; Special forms and macros will be advised into macros. + ;; The trick is to construct an expansion for the advised + ;; macro that does the correct thing when it gets eval'ed. + ;; For macros we'll just use the expansion of the original + ;; macro and return that. This way compiled advised macros + ;; will be expanded into something useful. Note that after + ;; advices have full control over whether they want to + ;; evaluate the expansion (the value of `ad-return-value') + ;; at macro expansion time or not. For special forms there + ;; is no solution that interacts reasonably with the + ;; compiler, hence we just evaluate the original at macro + ;; expansion time and return the result. The moral of that + ;; is that one should always deactivate advised special + ;; forms before one byte-compiles a file. + (` ((, (if orig-macro-p + 'macroexpand + 'eval)) + (cons '(, origname) + (, (ad-get-arguments advised-arglist 0)))))) + ((and orig-subr-p + orig-interactive-p + (not advised-interactive-form)) + ;; Check whether we were called interactively + ;; in order to do proper prompting: + (` (if (interactive-p) + (call-interactively '(, origname)) + (, (ad-make-mapped-call + orig-arglist advised-arglist origname))))) + ;; And now for normal functions and non-interactive subrs + ;; (or subrs whose interactive behavior was advised): + (t (ad-make-mapped-call + advised-arglist orig-arglist origname))))) + + ;; Finally, build the sucker: + (ad-assemble-advised-definition + (cond (orig-macro-p 'macro) + (orig-special-form-p 'special-form) + (t 'function)) + advised-arglist + (ad-make-advised-definition-docstring function) + interactive-form + orig-form + (ad-get-enabled-advices function 'before) + (ad-get-enabled-advices function 'around) + (ad-get-enabled-advices function 'after))))) + +(defun ad-assemble-advised-definition + (type args docstring interactive orig &optional befores arounds afters) + + ;;"Assembles an original and its advices into an advised function. + ;;It constructs a function or macro definition according to TYPE which has to + ;;be either `macro', `function' or `special-form'. ARGS is the argument list + ;;that has to be used, DOCSTRING if non-NIL defines the documentation of the + ;;definition, INTERACTIVE if non-NIL is the interactive form to be used, + ;;ORIG is a form that calls the body of the original unadvised function, + ;;and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG + ;;should be modified. The assembled function will be returned." + + (let (before-forms around-form around-form-protected after-forms definition) + (ad-dolist (advice befores) + (cond ((and (ad-advice-protected advice) + before-forms) + (setq before-forms + (` ((unwind-protect + (, (ad-prognify before-forms)) + (,@ (ad-body-forms + (ad-advice-definition advice)))))))) + (t (setq before-forms + (append before-forms + (ad-body-forms (ad-advice-definition advice))))))) + + (setq around-form (` (setq ad-return-value (, orig)))) + (ad-dolist (advice (reverse arounds)) + ;; If any of the around advices is protected then we + ;; protect the complete around advice onion: + (if (ad-advice-protected advice) + (setq around-form-protected t)) + (setq around-form + (ad-substitute-tree + (function (lambda (form) (eq form 'ad-do-it))) + (function (lambda (form) around-form)) + (ad-prognify (ad-body-forms (ad-advice-definition advice)))))) + + (setq after-forms + (if (and around-form-protected before-forms) + (` ((unwind-protect + (, (ad-prognify before-forms)) + (, around-form)))) + (append before-forms (list around-form)))) + (ad-dolist (advice afters) + (cond ((and (ad-advice-protected advice) + after-forms) + (setq after-forms + (` ((unwind-protect + (, (ad-prognify after-forms)) + (,@ (ad-body-forms + (ad-advice-definition advice)))))))) + (t (setq after-forms + (append after-forms + (ad-body-forms (ad-advice-definition advice))))))) + + (setq definition + (` ((,@ (if (memq type '(macro special-form)) '(macro))) + lambda + (, args) + (,@ (if docstring (list docstring))) + (,@ (if interactive (list interactive))) + (let (ad-return-value) + (,@ after-forms) + (, (if (eq type 'special-form) + '(list 'quote ad-return-value) + 'ad-return-value)))))) + + (ad-insert-argument-access-forms definition args))) + +;; This is needed for activation/deactivation hooks: +(defun ad-make-hook-form (function hook-name) + ;;"Makes hook-form from FUNCTION's advice bodies in class HOOK-NAME." + (let ((hook-forms + (mapcar (function (lambda (advice) + (ad-body-forms (ad-advice-definition advice)))) + (ad-get-enabled-advices function hook-name)))) + (if hook-forms + (ad-prognify (apply 'append hook-forms))))) + + +;; @@ Caching: +;; =========== +;; Generating an advised definition of a function is moderately expensive, +;; hence, it makes sense to cache it so we can reuse it in appropriate +;; circumstances. Of course, it only makes sense to reuse a cached +;; definition if the current advice and function definition state is the +;; same as it was at the time when the cached definition was generated. +;; For that purpose we associate every cache with an id so we can verify +;; if it is still valid at a certain point in time. This id mechanism +;; makes it possible to preactivate advised functions, write the compiled +;; advised definitions to a file and reuse them during the actual +;; activation without having to risk that the resulting definition will be +;; incorrect, well, almost. +;; +;; A cache id is a list with six elements: +;; 1) the list of names of enabled before advices +;; 2) the list of names of enabled around advices +;; 3) the list of names of enabled after advices +;; 4) the type of the original function (macro, subr, etc.) +;; 5) the arglist of the original definition (or t if it was equal to the +;; arglist of the cached definition) +;; 6) t if the interactive form of the original definition was equal to the +;; interactive form of the cached definition +;; +;; Here's how a cache can get invalidated or be incorrect: +;; A) a piece of advice used in the cache gets redefined +;; B) the current list of enabled advices is different from the ones used +;; for the cache +;; C) the type of the original function changed, e.g., a function became a +;; macro, or a subr became a function +;; D) the arglist of the original function changed +;; E) the interactive form of the original function changed +;; F) a piece of advice used in the cache got redefined before the +;; defadvice with the cached definition got loaded: This is a PROBLEM! +;; +;; Cases A and B are the normal ones. A is taken care of by `ad-add-advice' +;; which clears the cache in such a case, B is easily checked during +;; verification at activation time. +;; +;; Cases C, D and E have to be considered if one is slightly paranoid, i.e., +;; if one considers the case that the original function could be different +;; from the one available at caching time (e.g., for forward advice of +;; functions that get redefined by some packages - such as `eval-region' gets +;; redefined by edebug). All these cases can be easily checked during +;; verification. Element 4 of the id lets one check case C, element 5 takes +;; care of case D (using t in the equality case saves some space, because the +;; arglist can be recovered at validation time from the cached definition), +;; and element 6 takes care of case E which is only a problem if the original +;; was actually a function whose interactive form was not overridden by a +;; piece of advice. +;; +;; Case F is the only one which will lead to an incorrect advised function. +;; There is no way to avoid this without storing the complete advice definition +;; in the cache-id which is not feasible. +;; +;; The cache-id of a typical advised function with one piece of advice and +;; no arglist redefinition takes 7 conses which is a small price to pay for +;; the added efficiency. The validation itself is also pretty cheap, certainly +;; a lot cheaper than reconstructing an advised definition. + +(defmacro ad-get-cache-definition (function) + (` (car (ad-get-advice-info-field (, function) 'cache)))) + +(defmacro ad-get-cache-id (function) + (` (cdr (ad-get-advice-info-field (, function) 'cache)))) + +(defmacro ad-set-cache (function definition id) + (` (ad-set-advice-info-field + (, function) 'cache (cons (, definition) (, id))))) + +(defun ad-clear-cache (function) + "Clears a previously cached advised definition of FUNCTION. +Clear the cache if you want to force `ad-activate' to construct a new +advised definition from scratch." + (interactive + (list (ad-read-advised-function "Clear cached definition of: "))) + (ad-set-advice-info-field function 'cache nil)) + +(defun ad-make-cache-id (function) + ;;"Generates an identifying image of the current advices of FUNCTION." + (let ((original-definition (ad-real-orig-definition function)) + (cached-definition (ad-get-cache-definition function))) + (list (mapcar (function (lambda (advice) (ad-advice-name advice))) + (ad-get-enabled-advices function 'before)) + (mapcar (function (lambda (advice) (ad-advice-name advice))) + (ad-get-enabled-advices function 'around)) + (mapcar (function (lambda (advice) (ad-advice-name advice))) + (ad-get-enabled-advices function 'after)) + (ad-definition-type original-definition) + (if (equal (ad-arglist original-definition function) + (ad-arglist cached-definition)) + t + (ad-arglist original-definition function)) + (if (eq (ad-definition-type original-definition) 'function) + (equal (ad-interactive-form original-definition) + (ad-interactive-form cached-definition)))))) + +(defun ad-get-cache-class-id (function class) + ;;"Returns the part of FUNCTION's cache id that identifies CLASS." + (let ((cache-id (ad-get-cache-id function))) + (if (eq class 'before) + (car cache-id) + (if (eq class 'around) + (nth 1 cache-id) + (nth 2 cache-id))))) + +(defun ad-verify-cache-class-id (cache-class-id advices) + (ad-dolist (advice advices (null cache-class-id)) + (if (ad-advice-enabled advice) + (if (eq (car cache-class-id) (ad-advice-name advice)) + (setq cache-class-id (cdr cache-class-id)) + (ad-do-return nil))))) + +;; There should be a way to monitor if and why a cache verification failed +;; in order to determine whether a certain preactivation could be used or +;; not. Right now the only way to find out is to trace +;; `ad-cache-id-verification-code'. The code it returns indicates where the +;; verification failed. Tracing `ad-verify-cache-class-id' might provide +;; some additional useful information. + +(defun ad-cache-id-verification-code (function) + (let ((cache-id (ad-get-cache-id function)) + (code 'before-advice-mismatch)) + (and (ad-verify-cache-class-id + (car cache-id) (ad-get-advice-info-field function 'before)) + (setq code 'around-advice-mismatch) + (ad-verify-cache-class-id + (nth 1 cache-id) (ad-get-advice-info-field function 'around)) + (setq code 'after-advice-mismatch) + (ad-verify-cache-class-id + (nth 2 cache-id) (ad-get-advice-info-field function 'after)) + (setq code 'definition-type-mismatch) + (let ((original-definition (ad-real-orig-definition function)) + (cached-definition (ad-get-cache-definition function))) + (and (eq (nth 3 cache-id) (ad-definition-type original-definition)) + (setq code 'arglist-mismatch) + (equal (if (eq (nth 4 cache-id) t) + (ad-arglist original-definition function) + (nth 4 cache-id) ) + (ad-arglist cached-definition)) + (setq code 'interactive-form-mismatch) + (or (null (nth 5 cache-id)) + (equal (ad-interactive-form original-definition) + (ad-interactive-form cached-definition))) + (setq code 'verified)))) + code)) + +(defun ad-verify-cache-id (function) + ;;"True if FUNCTION's cache-id is compatible with its current advices." + (eq (ad-cache-id-verification-code function) 'verified)) + + +;; @@ Preactivation: +;; ================= +;; Preactivation can be used to generate compiled advised definitions +;; at compile time without having to give up the dynamic runtime flexibility +;; of the advice mechanism. Preactivation is a special feature of `defadvice', +;; it involves the following steps: +;; - remembering the function's current state (definition and advice-info) +;; - advising it with the defined piece of advice +;; - clearing its cache +;; - generating an interpreted advised definition by activating it, this will +;; make use of all its current active advice and its current definition +;; - saving the so generated cached definition and id +;; - resetting the function's advice and definition state to what it was +;; before the preactivation +;; - Returning the saved definition and its id to be used in the expansion of +;; `defadvice' to assign it as an initial cache, hence it will be compiled +;; at time the `defadvice' gets compiled (for v18 byte-compilers the +;; `defadvice' needs to be in the body of a `defun' for that to occur). +;; Naturally, for preactivation to be effective it has to be applied/compiled +;; at the right time, i.e., when the current state of advices and function +;; definition exactly reflects the state at activation time. Should that not +;; be the case, the precompiled definition will just be discarded and a new +;; advised definition will be generated. + +(defun ad-preactivate-advice (function advice class position) + ;;"Preactivates FUNCTION and returns the constructed cache." + (let* ((function-defined-p (fboundp function)) + (old-definition + (if function-defined-p + (symbol-function function))) + (old-advice-info (ad-copy-advice-info function)) + (ad-advised-functions ad-advised-functions)) + (unwind-protect + (progn + (ad-add-advice function advice class position) + (ad-enable-advice function class (ad-advice-name advice)) + (ad-clear-cache function) + (ad-activate function nil) + (if (and (ad-is-active function) + (ad-get-cache-definition function)) + (list (ad-get-cache-definition function) + (ad-get-cache-id function)))) + (ad-set-advice-info function old-advice-info) + ;; Don't `fset' function to nil if it was previously unbound: + (if function-defined-p + (ad-real-fset function old-definition) + (fmakunbound function))))) + +(defun ad-activate-advised-definition (function compile) + ;;"Redefines FUNCTION with its advised definition from cache or scratch. + ;;If COMPILE is true the resulting FUNCTION will be compiled. The current + ;;definition and its cache-id will be put into the cache." + (let ((verified-cached-definition + (if (ad-verify-cache-id function) + (ad-get-cache-definition function)))) + (ad-real-fset function + (or verified-cached-definition + (ad-make-advised-definition function))) + (if compile (ad-compile-function function)) + (if verified-cached-definition + (if (not (eq verified-cached-definition (symbol-function function))) + ;; we must have compiled, cache the compiled definition: + (ad-set-cache + function (symbol-function function) (ad-get-cache-id function))) + ;; We created a new advised definition, cache it with a proper id: + (ad-clear-cache function) + ;; ad-make-cache-id needs the new cached definition: + (ad-set-cache function (symbol-function function) nil) + (ad-set-cache + function (symbol-function function) (ad-make-cache-id function))))) + +(defun ad-handle-definition (function) + "Handles re/definition of an advised FUNCTION during de/activation. +If FUNCTION does not have an original definition associated with it and +the current definition is usable, then it will be stored as FUNCTION's +original definition. If no current definition is available (even in the +case of undefinition) nothing will be done. In the case of redefinition +the action taken depends on the value of `ad-redefinition-action' (which +see). Redefinition occurs when FUNCTION already has an original definition +associated with it but got redefined with a new definition and then +de/activated. If you do not like the current redefinition action change +the value of `ad-redefinition-action' and de/activate again." + (let ((original-definition (ad-get-orig-definition function)) + (current-definition (if (ad-real-definition function) + (symbol-function function)))) + (if original-definition + (if current-definition + (if (and (not (eq current-definition original-definition)) + ;; Redefinition with an advised definition from a + ;; different function won't count as such: + (not (ad-advised-definition-p current-definition))) + ;; we have a redefinition: + (if (not (memq ad-redefinition-action '(accept discard warn))) + (error "ad-handle-definition (see its doc): `%s' %s" + function "illegally redefined") + (if (eq ad-redefinition-action 'discard) + (ad-real-fset function original-definition) + (ad-set-orig-definition function current-definition) + (if (eq ad-redefinition-action 'warn) + (message "ad-handle-definition: `%s' got redefined" + function)))) + ;; either advised def or correct original is in place: + nil) + ;; we have an undefinition, ignore it: + nil) + (if current-definition + ;; we have a first definition, save it as original: + (ad-set-orig-definition function current-definition) + ;; we don't have anything noteworthy: + nil)))) + + +;; @@ The top-level advice interface: +;; ================================== + +(defun ad-activate (function &optional compile) + "Activates all the advice information of an advised FUNCTION. +If FUNCTION has a proper original definition then an advised +definition will be generated from FUNCTION's advice info and the +definition of FUNCTION will be replaced with it. If a previously +cached advised definition was available, it will be used. With an +argument (compile is non-NIL) the resulting function (or a compilable +cached definition) will also be compiled. Activation of an advised +function that has an advice info but no actual pieces of advice is +equivalent to a call to `ad-unadvise'. Activation of an advised +function that has actual pieces of advice but none of them are enabled +is equivalent to a call to `ad-deactivate'. The current advised +definition will always be cached for later usage." + (interactive + (list (ad-read-advised-function "Activate advice of: ") + current-prefix-arg)) + (if (not (ad-is-advised function)) + (error "ad-activate: `%s' is not advised" function) + (ad-handle-definition function) + ;; Just return for forward advised and not yet defined functions: + (if (ad-get-orig-definition function) + (if (not (ad-has-any-advice function)) + (ad-unadvise function) + ;; Otherwise activate the advice: + (cond ((ad-has-redefining-advice function) + (ad-activate-advised-definition function compile) + (ad-set-advice-info-field function 'active t) + (eval (ad-make-hook-form function 'activation)) + function) + ;; Here we are if we have all disabled advices: + (t (ad-deactivate function))))))) + +(defun ad-deactivate (function) + "Deactivates the advice of an actively advised FUNCTION. +If FUNCTION has a proper original definition, then the current +definition of FUNCTION will be replaced with it. All the advice +information will still be available so it can be activated again with +a call to `ad-activate'." + (interactive + (list (ad-read-advised-function "Deactivate advice of: " 'ad-is-active))) + (if (not (ad-is-advised function)) + (error "ad-deactivate: `%s' is not advised" function) + (cond ((ad-is-active function) + (ad-handle-definition function) + (if (not (ad-get-orig-definition function)) + (error "ad-deactivate: `%s' has no original definition" + function) + (ad-real-fset function (ad-get-orig-definition function)) + (ad-set-advice-info-field function 'active nil) + (eval (ad-make-hook-form function 'deactivation)) + function))))) + +(defun ad-update (function &optional compile) + "Update the advised definition of FUNCTION if its advice is active. +With a prefix argument or if the current definition is compiled compile the +resulting advised definition." + (interactive + (list (ad-read-advised-function + "Update advised definition of: " 'ad-is-active))) + (if (ad-is-active function) + (ad-activate + function (or compile (ad-compiled-p (symbol-function function)))))) + +(defun ad-unadvise (function) + "Deactivates FUNCTION and then removes all its advice information. +If FUNCTION was not advised this will be a noop." + (interactive + (list (ad-read-advised-function "Unadvise function: "))) + (cond ((ad-is-advised function) + (if (ad-is-active function) + (ad-deactivate function)) + (ad-clear-orig-definition function) + (ad-set-advice-info function nil) + (ad-pop-advised-function function)))) + +(defun ad-recover (function) + "Tries to recover FUNCTION's original definition and unadvises it. +This is more low-level than `ad-unadvise' because it does not do any +deactivation which might run hooks and get into other trouble. +Use in emergencies." + ;; Use more primitive interactive behavior here: Accept any symbol that's + ;; currently defined in obarray, not necessarily with a function definition: + (interactive + (list (intern + (completing-read "Recover advised function: " obarray nil t)))) + (cond ((ad-is-advised function) + (cond ((ad-get-orig-definition function) + (ad-real-fset function (ad-get-orig-definition function)) + (ad-clear-orig-definition function))) + (ad-set-advice-info function nil) + (ad-pop-advised-function function)))) + +(defun ad-activate-regexp (regexp &optional compile) + "Activates functions with an advice name containing a REGEXP match. +With prefix argument compiles resulting advised definitions." + (interactive + (list (ad-read-regexp "Activate via advice regexp: ") + current-prefix-arg)) + (ad-do-advised-functions (function) + (if (ad-find-some-advice function 'any regexp) + (ad-activate function compile)))) + +(defun ad-deactivate-regexp (regexp) + "Deactivates functions with an advice name containing REGEXP match." + (interactive + (list (ad-read-regexp "Deactivate via advice regexp: "))) + (ad-do-advised-functions (function) + (if (ad-find-some-advice function 'any regexp) + (ad-deactivate function)))) + +(defun ad-update-regexp (regexp &optional compile) + "Updates functions with an advice name containing a REGEXP match. +With prefix argument compiles resulting advised definitions." + (interactive + (list (ad-read-regexp "Update via advice regexp: ") + current-prefix-arg)) + (ad-do-advised-functions (function) + (if (ad-find-some-advice function 'any regexp) + (ad-update function compile)))) + +(defun ad-activate-all (&optional compile) + "Activates all currently advised functions. +With prefix argument compiles resulting advised definitions." + (interactive "P") + (ad-do-advised-functions (function) + (ad-activate function))) + +(defun ad-deactivate-all () + "Deactivates all currently advised functions." + (interactive) + (ad-do-advised-functions (function) + (ad-deactivate function))) + +(defun ad-update-all (&optional compile) + "Updates all currently advised functions. +With prefix argument compiles resulting advised definitions." + (interactive "P") + (ad-do-advised-functions (function) + (ad-update function compile))) + +(defun ad-unadvise-all () + "Unadvises all currently advised functions." + (interactive) + (ad-do-advised-functions (function) + (ad-unadvise function))) + +(defun ad-recover-all () + "Recovers all currently advised functions. Use in emergencies." + (interactive) + (ad-do-advised-functions (function) + (condition-case ignore-errors + (ad-recover function) + (error nil)))) + + +;; Completion alist of legal `defadvice' flags +(defvar ad-defadvice-flags + '(("protect") ("disable") ("activate") ("compile") ("preactivate"))) + +;;;###autoload +(defmacro defadvice (function args &rest body) + "Defines a piece of advice for FUNCTION (a symbol). + + (defadvice ( [] [] {}*) + [ [] [] ] + {}* ) + + ::= name of the function to be advised + ::= before | around | after | activation | deactivation + ::= non-NIL symbol that names this piece of advice + ::= first | last | (optional, defaults to `first', + see also `ad-add-advice') + ::= an optional argument list to be used for the advised function + instead of the argument list of the original. The first one found in + before/around/after advices will be used. + ::= protect | disable | activate | compile | preactivate + All flags can be specified with unambiguous initial substrings. + ::= optional documentation for this piece of advice + ::= optional interactive form to be used for the advised + function. The first one found in before/around/after advices will be used. + ::= any s-expression + +Semantics of the various flags: +`protect': The piece of advice will be protected against non-local exits in +any code that precedes it. If any around advice of a function is protected +then automatically all around advices will be protected (the complete onion). + +`activate': All advice of FUNCTION will be activated immediately if +FUNCTION has been properly defined prior to the defadvice. + +`compile': In conjunction with `activate' specifies that the resulting +advised function should be compiled. + +`disable': The defined advice will be disabled, hence it will not be used +during activation until somebody enables it. + +`preactivate': Preactivates the advised FUNCTION at macro expansion/compile +time. This generates a compiled advised definition according to the current +advice state that will be used during activation if appropriate. Only use +this if the defadvice gets actually compiled (with a v18 byte-compiler put +the defadvice into the body of a defun). + +Look at the file advice.el for comprehensive documentation." + (if (not (ad-name-p function)) + (error "defadvice: Illegal function name: %s" function)) + (let* ((class (car args)) + (name (if (not (ad-class-p class)) + (error "defadvice: Illegal advice class: %s" class) + (nth 1 args))) + (position (if (not (ad-name-p name)) + (error "defadvice: Illegal advice name: %s" name) + (setq args (nthcdr 2 args)) + (if (ad-position-p (car args)) + (prog1 (car args) + (setq args (cdr args)))))) + (arglist (if (listp (car args)) + (prog1 (car args) + (setq args (cdr args))))) + (flags + (mapcar + (function + (lambda (flag) + (let ((completion + (try-completion (symbol-name flag) ad-defadvice-flags))) + (cond ((eq completion t) flag) + ((assoc completion ad-defadvice-flags) + (intern completion)) + (t (error "defadvice: Illegal or ambiguous flag: %s" + flag)))))) + args)) + (advice (ad-make-advice + name (memq 'protect flags) + (not (memq 'disable flags)) + (` (advice lambda (, arglist) (,@ body))))) + (preactivation (if (memq 'preactivate flags) + (ad-preactivate-advice + function advice class position)))) + ;; Now for the things to be done at evaluation time: + (` (progn + (ad-add-advice '(, function) '(, advice) '(, class) '(, position)) + (,@ (if preactivation + (` ((ad-set-cache + '(, function) + ;; the function will get compiled: + (, (cond ((ad-macro-p (car preactivation)) + (` (ad-macrofy + (function + (, (ad-lambdafy + (car preactivation))))))) + (t (` (function + (, (car preactivation))))))) + '(, (car (cdr preactivation)))))))) + (,@ (if (memq 'activate flags) + (` ((ad-activate '(, function) + (, (if (memq 'compile flags) t))))))) + '(, function))))) + + +;; @@ Tools: +;; ========= + +(defmacro ad-with-originals (functions &rest body) + "Binds FUNCTIONS to their original definitions and executes BODY. +For any members of FUNCTIONS that are not currently advised the rebinding will +be a noop. Any modifications done to the definitions of FUNCTIONS will be +undone on exit of this macro." + (let* ((index -1) + ;; Make let-variables to store current definitions: + (current-bindings + (mapcar (function + (lambda (function) + (setq index (1+ index)) + (list (intern (format "ad-oRiGdEf-%d" index)) + (` (symbol-function '(, function)))))) + functions))) + (` (let (, current-bindings) + (unwind-protect + (progn + (,@ (progn + ;; Make forms to redefine functions to their + ;; original definitions if they are advised: + (setq index -1) + (mapcar + (function + (lambda (function) + (setq index (1+ index)) + (` (ad-real-fset + '(, function) + (or (ad-get-orig-definition '(, function)) + (, (car (nth index current-bindings)))))))) + functions))) + (,@ body)) + (,@ (progn + ;; Make forms to back-define functions to the definitions + ;; they had outside this macro call: + (setq index -1) + (mapcar + (function + (lambda (function) + (setq index (1+ index)) + (` (ad-real-fset + '(, function) + (, (car (nth index current-bindings))))))) + functions)))))))) + +(if (not (get 'ad-with-originals 'lisp-indent-hook)) + (put 'ad-with-originals 'lisp-indent-hook 1)) + + +;; @@ Advising `defun', `defmacro', `fset' and `documentation' +;; =========================================================== +;; Use the advice mechanism to advise defun/defmacro/fset so we can forward +;; advise functions that might be defined later during load/autoload. +;; Enabling forward advice was the original motivation for doing this, it +;; has now been generalized to running definition hooks so other packages +;; can make use of this sort of functionality too. + +(defvar ad-defined-function nil) + +(defun ad-activate-defined-function (&optional function) + "Activates the advice of an advised and defined FUNCTION. +If the current definition of FUNCTION is byte-compiled then the advised +definition will be compiled too. FUNCTION defaults to the value of +`ad-defined-function'." + (if (and (null function) + ad-defined-function) + (setq function ad-defined-function)) + (if (and (ad-is-advised function) + (ad-real-definition function)) + (ad-activate function (ad-compiled-p (symbol-function function))))) + +;; Define some subr arglists for the benefit of v18. Do this here because +;; they have to be available at compile/preactivation time. Use the same +;; as defined in Lemacs' DOC file: +(cond ((not ad-emacs19-p) + (ad-define-subr-args 'documentation '(fun1)) + (ad-define-subr-args 'fset '(sym newdef)))) + +;; A kludge to get `defadvice's compiled with a v18 compiler: +(defun ad-execute-defadvices () + +(defadvice defun (after ad-definition-hooks first disable preact) + "Whenever a function gets re/defined with `defun' all hook functions +in `ad-definition-hooks' will be run after the re/definition with +`ad-defined-function' bound to the name of the function." + (let ((ad-defined-function (ad-get-arg 0))) + (run-hooks 'ad-definition-hooks))) + +(defadvice defmacro (after ad-definition-hooks first disable preact) + "Whenever a macro gets re/defined with `defmacro' all hook functions +in `ad-definition-hooks' will be run after the re/definition with +`ad-defined-function' bound to the name of the function." + (let ((ad-defined-function (ad-get-arg 0))) + (run-hooks 'ad-definition-hooks))) + +(defadvice fset (after ad-definition-hooks first disable preact) + "Whenever a function gets re/defined with `fset' all hook functions +in `ad-definition-hooks' will be run after the re/definition with +`ad-defined-function' bound to the name of the function. This advice was +mainly created to handle forward-advice for byte-compiled files created +by jwz's byte-compiler used in Lemacs. +CAUTION: If you need the primitive `fset' behavior either deactivate + its advice or use `ad-real-fset' instead!" + (let ((ad-defined-function (ad-get-arg 0))) + (run-hooks 'ad-definition-hooks))) + +;; Needed for GNU Emacs-19 (in v18s and Lemacs this is just a noop): +(defadvice defalias (after ad-definition-hooks first disable preact) + "Whenever a function gets re/defined with `defalias' all hook functions +in `ad-definition-hooks' will be run after the re/definition with +`ad-defined-function' bound to the name of the function. This advice was +mainly created to handle forward-advice for byte-compiled files created +by jwz's byte-compiler used in GNU Emacs-19." + (let ((ad-defined-function (ad-get-arg 0))) + ;; The new `byte-compile' uses `defalias' to set the definition which + ;; leads to infinite recursion if it gets to use the advised version + ;; (with `fset' this didn't matter because the compiled `byte-compile' + ;; called it via its byte-code). Should there be a general provision to + ;; avoid recursive application of definition hooks? + (ad-with-originals (defalias) + (run-hooks 'ad-definition-hooks)))) + +;; Needed for GNU Emacs-19 (seems to be an identical copy of `defalias', +;; it is used by simple.el and might be used later, hence, advise it): +(defadvice define-function (after ad-definition-hooks first disable preact) + "Whenever a function gets re/defined with `define-function' all hook +functions in `ad-definition-hooks' will be run after the re/definition with +`ad-defined-function' bound to the name of the function." + (let ((ad-defined-function (ad-get-arg 0))) + (ad-with-originals (define-function) + (run-hooks 'ad-definition-hooks)))) + +(defadvice documentation (after ad-advised-docstring first disable preact) + "Builds an advised docstring if FUNCTION is advised." + ;; Because we get the function name from the advised docstring + ;; this will work for function names as well as for definitions: + (if (and (stringp ad-return-value) + (string-match + ad-advised-definition-docstring-regexp ad-return-value)) + (let ((function + (car (read-from-string + ad-return-value (match-beginning 1) (match-end 1))))) + (cond ((ad-is-advised function) + (setq ad-return-value (ad-make-advised-docstring function)) + ;; Handle GNU Emacs-19's optional `raw' argument: + (if (not (ad-get-arg 1)) + (setq ad-return-value + (substitute-command-keys ad-return-value)))))))) + + +) ;; end of ad-execute-defadvices + +;; Only run this once we are compiled. Expanding the defadvices +;; with only interpreted advice functions available takes forever: +(if (ad-compiled-p (symbol-function 'ad-execute-defadvices)) + (ad-execute-defadvices)) + + +;; @@ Forward advice support for jwz's byte-compiler (M-x serious-HACK-mode-on) +;; ============================================================================ +;; Jamie Zawinski's optimizing byte-compiler used in v19 (and by some daring +;; folks in v18) produces compiled files that do not define functions via +;; explicit calls to `defun/defmacro', it rather uses `fset' for functions with +;; documentation strings, and hunks of byte-code for sets of functions without +;; any documentation. In Jamie's byte-compiler a series of compiled functions +;; without docstrings get hunked as +;; (progn (fset 'f1 ) (fset 'f2 ) ...). +;; The resulting progn will be compiled and the compiled form will be written +;; to the compiled file as `(byte-code [progn-code] [constants] [depth])'. To +;; handle forward advice we have to know when functions get defined so we can +;; activate any advice there might be. For standard v18 byte-compiled files +;; we can do this by simply advising `defun/defmacro' because these subrs are +;; evaluated explicitly when such a file is loaded. For Jamie's v19 compiler +;; our only choice is to additionally advise `fset' and change the subr +;; `byte-code' such that it analyzes its byte-code string looking for fset's +;; when we are currently loading a file. In v19 the general overhead caused +;; by the advice of `byte-code' shouldn't be too bad, because byte-compiled +;; functions do not call byte-code explicitly (as done in v18). In v18 this +;; is a problem because with the changed `byte-code' function function calls +;; become more expensive. +;; +;; Wish-List: +;; - special defining functions for use in byte-compiled files, e.g., +;; `byte-compile-fset' and `byte-code-tl' which do the same as their +;; standard brothers, but which can be advised for forward advice without +;; the problems that advising `byte-code' generates. +;; - More generally, a symbol definition hook that could be used for +;; forward advice and related purposes. +;; +;; Until then: For the analysis of the byte-code string we simply scan it for +;; an `fset' opcode (M in ascii) that is preceded by two constant references, +;; the first of which points to the function name and the second to its code. +;; A constant reference can either be a simple one-byte one, or a three-byte +;; one if the function has more than 64 constants. The scanning can pretty +;; efficiently be done with a regular expression. Here it goes: + +;; Have to hardcode these opcodes if I don't +;; want to require the byte-compiler: +(defvar byte-constant 192) +(defvar byte-constant-limit 64) +(defvar byte-constant2 129) +(defvar byte-fset 77) + +;; Matches a byte-compiled fset operation with two constant arguments: +(defvar ad-byte-code-fset-regexp + (let* ((constant-reference + (format "[%s-%s]" + (char-to-string byte-constant) + (char-to-string (+ byte-constant (1- byte-constant-limit))))) + (constant2-reference + ;; \0 makes it necessary to use concat instead of format in 18.57: + (concat (char-to-string byte-constant2) "[\0-\377][\0-\377]")) + (fset-opcode (char-to-string byte-fset))) + (concat "\\(" constant-reference "\\|" constant2-reference "\\)" + "\\(" constant-reference "\\|" constant2-reference "\\)" + fset-opcode))) + +(defun ad-find-fset-in-byte-code (code constants start) + ;;"Finds the first two-constant fset operation in CODE after START. + ;;Returns a three element list consisting of the name of the defined + ;;function, its code (both taken from the CONSTANTS vector), and an + ;;advanced start index." + (let ((start + ;; The odd case that this regexp matches something that isn't an + ;; actual fset operation is handled by additional tests and a + ;; condition handler in ad-scan-byte-code-for-fsets: + (string-match ad-byte-code-fset-regexp code start)) + name-index code-index) + (cond (start + (cond ((= (aref code start) byte-constant2) + (setq name-index + (+ (aref code (setq start (1+ start))) + (* (aref code (setq start (1+ start))) 256))) + (setq start (1+ start))) + (t (setq name-index (- (aref code start) byte-constant)) + (setq start (1+ start)))) + (cond ((= (aref code start) byte-constant2) + (setq code-index + (+ (aref code (setq start (1+ start))) + (* (aref code (setq start (1+ start))) 256))) + (setq start (1+ start))) + (t (setq code-index (- (aref code start) byte-constant)) + (setq start (1+ start)))) + (list (aref constants name-index) + (aref constants code-index) + ;; start points to fset opcode: + start)) + (t nil)))) + +(defun ad-scan-byte-code-for-fsets (ad-code ad-constants) + ;; In case anything in here goes wrong we reset `byte-code' to its real + ;; identity. In particular, the handler of the condition-case uses + ;; `byte-code', so it better be the real one if we have an error: + (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)) + (condition-case ignore-errors + (let ((fset-args '(0 0 0))) + (while (setq fset-args (ad-find-fset-in-byte-code + ad-code ad-constants + (car (cdr (cdr fset-args))))) + (if (and (symbolp (car fset-args)) + (fboundp (car fset-args)) + (eq (symbol-function (car fset-args)) + (car (cdr fset-args)))) + ;; We've found an fset that was executed during this call + ;; to byte-code, and whose definition is still eq to the + ;; current definition of the defined function: + (let ((ad-defined-function (car fset-args))) + (run-hooks 'ad-definition-hooks)))) + ;; Everything worked fine, readvise `byte-code': + (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code))) + (error nil))) + +;; CAUTION: Don't try this at home!! Changing `byte-code' is a +;; pretty suicidal activity. +;; To allow v19 forward advice we cannot advise `byte-code' as a subr as +;; we did for `defun' etc., because `ad-subr-args' of the advised +;; `byte-code' would shield references to `ad-subr-args' in the body of +;; v18 compiled advised subrs such as `defun', and, more importantly, the +;; changed version of `byte-code' has to be as small and efficient as +;; possible because it is used in every call to a compiled function. +;; Hence, we previously saved its original definition and redefine it as +;; the following function - yuck: + +;; The arguments will scope around the body of every byte-compiled +;; function, hence they have to be obscure enough to not be equal to any +;; global or argument variable referenced by any compiled function: +(defun ad-advised-byte-code-definition (ad-cOdE ad-cOnStAnTs ad-dEpTh) + "Modified version of `byte-code' subr used by the advice package. +`byte-code' has been modified to allow automatic activation of forward +advice for functions that are defined in byte-compiled files generated +by jwz's byte-compiler (as standardly used in v19s). +See `ad-real-byte-code' for original documentation." + (prog1 (ad-real-byte-code ad-cOdE ad-cOnStAnTs ad-dEpTh) + (if load-in-progress + (ad-scan-byte-code-for-fsets ad-cOdE ad-cOnStAnTs)))) + +(ad-real-byte-codify 'ad-advised-byte-code-definition) + +;; ad-advised-byte-code cannot be defined with `defun', because that would +;; use `byte-code' for its body --> major disaster if forward advice is +;; enabled and this file gets loaded: +(ad-real-fset + 'ad-advised-byte-code (symbol-function 'ad-advised-byte-code-definition)) + +(defun ad-recover-byte-code () + "Recovers the real `byte-code' functionality." + (interactive) + (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code))) + +;; Make sure this is usable even if `byte-code' is screwed up: +(ad-real-byte-codify 'ad-recover-byte-code) + +;; Store original stack sizes because we might have to change them: +(defvar ad-orig-max-lisp-eval-depth max-lisp-eval-depth) +(defvar ad-orig-max-specpdl-size max-specpdl-size) + +(defun ad-adjust-stack-sizes (&optional reset) + "Increases stack sizes for the advised `byte-code' function. +When called with a prefix argument the stack sizes will be reset +to their original values. Calling this function should only be necessary +if you get stack overflows because you run highly recursive v18 compiled +code in a v19 Emacs with definition hooks enabled." + (interactive "P") + (cond (reset + (setq max-lisp-eval-depth ad-orig-max-lisp-eval-depth) + (setq max-specpdl-size ad-orig-max-specpdl-size)) + (t ;; The redefined `byte-code' needs more execution stack + ;; (5 cells per function invocation) and variable stack + ;; (3 vars per function invocation): + (setq max-lisp-eval-depth (* ad-orig-max-lisp-eval-depth 3)) + (setq max-specpdl-size + (+ ad-orig-max-specpdl-size (* (/ max-lisp-eval-depth 5) 3)))))) + +(defun ad-enable-definition-hooks () + ;;"Enables definition hooks by redefining definition primitives. + ;;Activates the advice of defun/defmacro/fset and possibly redefines + ;;`byte-code' if a v19 byte-compiler is used. Redefining these primitives + ;;might lead to problems. Use `ad-disable-definition-hooks' or + ;;`ad-stop-advice' in such a case to establish a safe state." + (ad-dolist (definer '(defun defmacro fset defalias define-function)) + (ad-enable-advice definer 'after 'ad-definition-hooks) + (ad-activate definer 'compile)) + (cond (ad-use-jwz-byte-compiler + (ad-real-byte-codify 'ad-advised-byte-code) + (ad-real-byte-codify 'ad-scan-byte-code-for-fsets) + ;; Now redefine byte-code... + (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)) + ;; Only increase stack sizes in v18s, even though old-fashioned + ;; v18 byte-code might be run in a v19, in which case one can call + ;; `ad-adjust-stack-sizes' interactively if stacks become too small: + (if (not ad-emacs19-p) + (ad-adjust-stack-sizes))))) + +(defun ad-disable-definition-hooks () + ;;"Disables definition hooks by resetting definition primitives." + (ad-recover-byte-code) + (ad-dolist (definer '(defun defmacro fset defalias define-function)) + (ad-disable-advice definer 'after 'ad-definition-hooks) + (ad-update definer)) + (if (not ad-emacs19-p) + (ad-adjust-stack-sizes 'reset))) + +(ad-real-byte-codify 'ad-disable-definition-hooks) + + +;; @@ Starting, stopping and recovering from the advice package magic: +;; =================================================================== + +;;;###autoload +(defun ad-start-advice () + "Redefines some primitives to start the advice magic. +If `ad-activate-on-definition' is t then advice information will +automatically get activated whenever an advised function gets defined or +redefined. This will enable goodies such as forward advice and +automatically enable function definition hooks. If its value is nil but +the value of `ad-enable-definition-hooks' is t then definition hooks +will be enabled without having automatic advice activation, otherwise +function definition hooks will be disabled too. If definition hooks are +enabled then functions stored in `ad-definition-hooks' are run whenever +a function gets defined or redefined." + (interactive) + (ad-enable-advice 'documentation 'after 'ad-advised-docstring) + (ad-activate 'documentation 'compile) + (if (or ad-activate-on-definition + ad-enable-definition-hooks) + (ad-enable-definition-hooks) + (ad-disable-definition-hooks)) + (setq ad-definition-hooks + (if ad-activate-on-definition + (if (memq 'ad-activate-defined-function ad-definition-hooks) + ad-definition-hooks + (cons 'ad-activate-defined-function ad-definition-hooks)) + (delq 'ad-activate-defined-function ad-definition-hooks)))) + +(defun ad-stop-advice () + "Undefines some primitives to stop the advice magic. +This can also be used to recover from advice related emergencies." + (interactive) + (ad-recover-byte-code) + (ad-disable-advice 'documentation 'after 'ad-advised-docstring) + (ad-update 'documentation) + (ad-disable-definition-hooks) + (setq ad-definition-hooks + (delq 'ad-activate-defined-function ad-definition-hooks))) + +(ad-real-byte-codify 'ad-stop-advice) + +(defun ad-recover-normality () + "Undoes all advice related redefinitions and unadvises everything. +Use only in REAL emergencies." + (interactive) + (ad-recover-byte-code) + (ad-recover-all) + (setq ad-advised-functions nil)) + +(ad-real-byte-codify 'ad-recover-normality) + +(if (and ad-start-advice-on-load + ;; ...but only if we are compiled: + (ad-compiled-p (symbol-function 'ad-execute-defadvices))) + (ad-start-advice)) + +(provide 'advice) + +;;; advice.el ends here