LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - advice.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 63 797 7.9 %
Date: 2017-08-27 09:44:50 Functions: 22 126 17.5 %

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

Generated by: LCOV version 1.12