| 1 | ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- |
| 2 | |
| 3 | ;; Copyright (C) 2012-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
| 6 | ;; Keywords: extensions, lisp, tools |
| 7 | ;; Package: emacs |
| 8 | |
| 9 | ;; This program is free software; you can redistribute it and/or modify |
| 10 | ;; it under the terms of the GNU General Public License as published by |
| 11 | ;; the Free Software Foundation, either version 3 of the License, or |
| 12 | ;; (at your option) any later version. |
| 13 | |
| 14 | ;; This program is distributed in the hope that it will be useful, |
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 17 | ;; GNU General Public License for more details. |
| 18 | |
| 19 | ;; You should have received a copy of the GNU General Public License |
| 20 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. |
| 21 | |
| 22 | ;;; Commentary: |
| 23 | |
| 24 | ;; This package lets you add behavior (which we call "piece of advice") to |
| 25 | ;; existing functions, like the old `advice.el' package, but with much fewer |
| 26 | ;; bells and whistles. It comes in 2 parts: |
| 27 | ;; |
| 28 | ;; - The first part lets you add/remove functions, similarly to |
| 29 | ;; add/remove-hook, from any "place" (i.e. as accepted by `setf') that |
| 30 | ;; holds a function. |
| 31 | ;; This part provides mainly 2 macros: `add-function' and `remove-function'. |
| 32 | ;; |
| 33 | ;; - The second part provides `advice-add' and `advice-remove' which are |
| 34 | ;; refined version of the previous macros specially tailored for the case |
| 35 | ;; where the place that we want to modify is a `symbol-function'. |
| 36 | |
| 37 | ;;; Code: |
| 38 | |
| 39 | ;;;; Lightweight advice/hook |
| 40 | (defvar advice--where-alist |
| 41 | '((:around . (apply function main args)) |
| 42 | (:before . (progn |
| 43 | (apply function args) |
| 44 | (apply main args))) |
| 45 | (:after . (prog1 (apply main args) |
| 46 | (apply function args))) |
| 47 | (:override . (apply function args)) |
| 48 | (:after-until . (or (apply main args) (apply function args))) |
| 49 | (:after-while . (and (apply main args) (apply function args))) |
| 50 | (:before-until . (or (apply function args) (apply main args))) |
| 51 | (:before-while . (and (apply function args) (apply main args))) |
| 52 | (:filter-args . (apply main (apply function args))) |
| 53 | (:filter-return . (funcall function (apply main args)))) |
| 54 | "List of descriptions of how to add a function.") |
| 55 | |
| 56 | (setq advice--where-alist |
| 57 | (mapcar #'(lambda (tem) |
| 58 | (cons (car tem) |
| 59 | (eval `(lambda (function main) |
| 60 | (lambda (&rest args) |
| 61 | ,(cdr tem)))))) |
| 62 | advice--where-alist)) |
| 63 | |
| 64 | (defun advice--p (object) |
| 65 | (when (funcall (@ (guile) procedure?) object) |
| 66 | (funcall (@ (guile) procedure-property) object 'advice))) |
| 67 | |
| 68 | (defun advice--car (f) |
| 69 | (when (funcall (@ (guile) procedure?) f) |
| 70 | (funcall (@ (guile) procedure-property) f 'advice-car))) |
| 71 | |
| 72 | (defun advice--cdr (f) |
| 73 | (when (funcall (@ (guile) procedure?) f) |
| 74 | (funcall (@ (guile) procedure-property) f 'advice-cdr))) |
| 75 | |
| 76 | (defun advice--props (f) |
| 77 | (when (funcall (@ (guile) procedure?) f) |
| 78 | (funcall (@ (guile) procedure-property) f 'advice-props))) |
| 79 | |
| 80 | (defun advice--cd*r (f) |
| 81 | (while (advice--p f) |
| 82 | (setq f (advice--cdr f))) |
| 83 | f) |
| 84 | |
| 85 | (defun advice--make-docstring (function) |
| 86 | "Build the raw docstring for FUNCTION, presumably advised." |
| 87 | (let* ((flist (indirect-function function)) |
| 88 | (docfun nil) |
| 89 | (docstring nil)) |
| 90 | (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) |
| 91 | (while (advice--p flist) |
| 92 | (let ((bytecode (aref flist 1)) |
| 93 | (doc (aref flist 4)) |
| 94 | (where nil)) |
| 95 | ;; Hack attack! For advices installed before calling |
| 96 | ;; Snarf-documentation, the integer offset into the DOC file will not |
| 97 | ;; be installed in the "core unadvised function" but in the advice |
| 98 | ;; object instead! So here we try to undo the damage. |
| 99 | (if (integerp doc) (setq docfun flist)) |
| 100 | (dolist (elem advice--where-alist) |
| 101 | (if (eq bytecode (cdr elem)) (setq where (car elem)))) |
| 102 | (setq docstring |
| 103 | (concat |
| 104 | docstring |
| 105 | (propertize (format "%s advice: " where) |
| 106 | 'face 'warning) |
| 107 | (let ((fun (advice--car flist))) |
| 108 | (if (symbolp fun) (format "`%S'" fun) |
| 109 | (let* ((name (cdr (assq 'name (advice--props flist)))) |
| 110 | (doc (documentation fun t)) |
| 111 | (usage (help-split-fundoc doc function))) |
| 112 | (if usage (setq doc (cdr usage))) |
| 113 | (if name |
| 114 | (if doc |
| 115 | (format "%s\n%s" name doc) |
| 116 | (format "%s" name)) |
| 117 | (or doc "No documentation"))))) |
| 118 | "\n"))) |
| 119 | (setq flist (advice--cdr flist))) |
| 120 | (if docstring (setq docstring (concat docstring "\n"))) |
| 121 | (unless docfun (setq docfun flist)) |
| 122 | (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops. |
| 123 | (documentation docfun t))) |
| 124 | (usage (help-split-fundoc origdoc function))) |
| 125 | (setq usage (if (null usage) |
| 126 | (let ((arglist (help-function-arglist flist))) |
| 127 | (format "%S" (help-make-usage function arglist))) |
| 128 | (setq origdoc (cdr usage)) (car usage))) |
| 129 | (help-add-fundoc-usage (concat docstring origdoc) usage)))) |
| 130 | |
| 131 | (defun advice-eval-interactive-spec (spec) |
| 132 | "Evaluate the interactive spec SPEC." |
| 133 | (cond |
| 134 | ((stringp spec) |
| 135 | ;; There's no direct access to the C code (in call-interactively) that |
| 136 | ;; processes those specs, but that shouldn't stop us, should it? |
| 137 | ;; FIXME: Despite appearances, this is not faithful: SPEC and |
| 138 | ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t |
| 139 | ;; command-history (and maybe a few other details). |
| 140 | (call-interactively `(lambda (&rest args) (interactive ,spec) args))) |
| 141 | ;; ((functionp spec) (funcall spec)) |
| 142 | (t (eval spec)))) |
| 143 | |
| 144 | (defun advice--interactive-form (function) |
| 145 | ;; Like `interactive-form' but tries to avoid autoloading functions. |
| 146 | (when (commandp function) |
| 147 | (if (not (and (symbolp function) (autoloadp (indirect-function function)))) |
| 148 | (interactive-form function) |
| 149 | `(interactive (advice-eval-interactive-spec |
| 150 | (cadr (interactive-form ',function))))))) |
| 151 | |
| 152 | (defun advice--make-interactive-form (function main) |
| 153 | ;; TODO: make it so that interactive spec can be a constant which |
| 154 | ;; dynamically checks the advice--car/cdr to do its job. |
| 155 | ;; For that, advice-eval-interactive-spec needs to be more faithful. |
| 156 | (let* ((iff (advice--interactive-form function)) |
| 157 | (ifm (advice--interactive-form main)) |
| 158 | (fspec (cadr iff))) |
| 159 | (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? |
| 160 | (setq fspec (nth 1 fspec))) |
| 161 | (if (functionp fspec) |
| 162 | `(funcall ',fspec ',(cadr ifm)) |
| 163 | (cadr (or iff ifm))))) |
| 164 | |
| 165 | (defun advice--make-1 (type make-wrapper function main props) |
| 166 | "Build a function value that adds FUNCTION to MAIN." |
| 167 | (let ((adv-sig (gethash main advertised-signature-table)) |
| 168 | (advice |
| 169 | (funcall make-wrapper function main))) |
| 170 | (funcall (@ (guile) set-procedure-property!) |
| 171 | advice 'advice-type type) |
| 172 | (funcall (@ (guile) set-procedure-property!) |
| 173 | advice 'advice-car function) |
| 174 | (funcall (@ (guile) set-procedure-property!) |
| 175 | advice 'advice-cdr main) |
| 176 | (funcall (@ (guile) set-procedure-property!) |
| 177 | advice 'advice-props props) |
| 178 | (when (or (commandp function) (commandp main)) |
| 179 | (funcall (@ (guile) set-procedure-property!) |
| 180 | advice |
| 181 | 'interactive-form |
| 182 | (advice--make-interactive-form function main))) |
| 183 | (when adv-sig (puthash advice adv-sig advertised-signature-table)) |
| 184 | advice)) |
| 185 | |
| 186 | (defun advice--make (where function main props) |
| 187 | "Build a function value that adds FUNCTION to MAIN at WHERE. |
| 188 | WHERE is a symbol to select an entry in `advice--where-alist'." |
| 189 | (let ((fd (or (cdr (assq 'depth props)) 0)) |
| 190 | (md (if (advice--p main) |
| 191 | (or (cdr (assq 'depth (advice--props main))) 0)))) |
| 192 | (if (and md (> fd md)) |
| 193 | ;; `function' should go deeper. |
| 194 | (let ((rest (advice--make where function (advice--cdr main) props))) |
| 195 | (advice--make-1 (aref main 1) (aref main 3) |
| 196 | (advice--car main) rest (advice--props main))) |
| 197 | (let ((desc (assq where advice--where-alist))) |
| 198 | (unless desc (error "Unknown add-function location `%S'" where)) |
| 199 | (advice--make-1 (car desc) (cdr desc) |
| 200 | function main props))))) |
| 201 | |
| 202 | (defun advice--member-p (function use-name definition) |
| 203 | (let ((found nil)) |
| 204 | (while (and (not found) (advice--p definition)) |
| 205 | (if (if (eq use-name :use-both) |
| 206 | (or (equal function |
| 207 | (cdr (assq 'name (advice--props definition)))) |
| 208 | (equal function (advice--car definition))) |
| 209 | (equal function (if use-name |
| 210 | (cdr (assq 'name (advice--props definition))) |
| 211 | (advice--car definition)))) |
| 212 | (setq found definition) |
| 213 | (setq definition (advice--cdr definition)))) |
| 214 | found)) |
| 215 | |
| 216 | (defun advice--tweak (flist tweaker) |
| 217 | (if (not (advice--p flist)) |
| 218 | (funcall tweaker nil flist nil) |
| 219 | (let ((first (advice--car flist)) |
| 220 | (rest (advice--cdr flist)) |
| 221 | (props (advice--props flist))) |
| 222 | (let ((val (funcall tweaker first rest props))) |
| 223 | (if val (car val) |
| 224 | (let ((nrest (advice--tweak rest tweaker))) |
| 225 | (if (eq rest nrest) flist |
| 226 | (advice--make-1 (aref flist 1) (aref flist 3) |
| 227 | first nrest props)))))))) |
| 228 | |
| 229 | ;;;###autoload |
| 230 | (defun advice--remove-function (flist function) |
| 231 | (advice--tweak flist |
| 232 | (lambda (first rest props) |
| 233 | (cond ((not first) rest) |
| 234 | ((or (equal function first) |
| 235 | (equal function (cdr (assq 'name props)))) |
| 236 | (list (advice--remove-function rest function))))))) |
| 237 | |
| 238 | (defvar advice--buffer-local-function-sample nil |
| 239 | "keeps an example of the special \"run the default value\" functions. |
| 240 | These functions play the same role as t in buffer-local hooks, and to recognize |
| 241 | them, we keep a sample here against which to compare. Each instance is |
| 242 | different, but `function-equal' will hopefully ignore those differences.") |
| 243 | |
| 244 | (defun advice--set-buffer-local (var val) |
| 245 | (if (function-equal val advice--buffer-local-function-sample) |
| 246 | (kill-local-variable var) |
| 247 | (set (make-local-variable var) val))) |
| 248 | |
| 249 | ;;;###autoload |
| 250 | (defun advice--buffer-local (var) |
| 251 | "Buffer-local value of VAR, presumed to contain a function." |
| 252 | (declare (gv-setter advice--set-buffer-local)) |
| 253 | (if (local-variable-p var) (symbol-value var) |
| 254 | (setq advice--buffer-local-function-sample |
| 255 | ;; This function acts like the t special value in buffer-local hooks. |
| 256 | (lambda (&rest args) (apply (default-value var) args))))) |
| 257 | |
| 258 | (eval-and-compile |
| 259 | (defun advice--normalize-place (place) |
| 260 | (cond ((eq 'local (car-safe place)) `(advice--buffer-local ,@(cdr place))) |
| 261 | ((eq 'var (car-safe place)) (nth 1 place)) |
| 262 | ((symbolp place) `(default-value ',place)) |
| 263 | (t place)))) |
| 264 | |
| 265 | ;;;###autoload |
| 266 | (defmacro add-function (where place function &optional props) |
| 267 | ;; TODO: |
| 268 | ;; - maybe let `where' specify some kind of predicate and use it |
| 269 | ;; to implement things like mode-local or eieio-defmethod. |
| 270 | ;; Of course, that only makes sense if the predicates of all advices can |
| 271 | ;; be combined and made more efficient. |
| 272 | ;; :before is like a normal add-hook on a normal hook. |
| 273 | ;; :before-while is like add-hook on run-hook-with-args-until-failure. |
| 274 | ;; :before-until is like add-hook on run-hook-with-args-until-success. |
| 275 | ;; Same with :after-* but for (add-hook ... 'append). |
| 276 | "Add a piece of advice on the function stored at PLACE. |
| 277 | FUNCTION describes the code to add. WHERE describes where to add it. |
| 278 | WHERE can be explained by showing the resulting new function, as the |
| 279 | result of combining FUNCTION and the previous value of PLACE, which we |
| 280 | call OLDFUN here: |
| 281 | `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) |
| 282 | `:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) |
| 283 | `:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) |
| 284 | `:override' (lambda (&rest r) (apply FUNCTION r)) |
| 285 | `:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) |
| 286 | `:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) |
| 287 | `:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) |
| 288 | `:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) |
| 289 | `:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) |
| 290 | `:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) |
| 291 | If FUNCTION was already added, do nothing. |
| 292 | PROPS is an alist of additional properties, among which the following have |
| 293 | a special meaning: |
| 294 | - `name': a string or symbol. It can be used to refer to this piece of advice. |
| 295 | - `depth': a number indicating a preference w.r.t ordering. |
| 296 | The default depth is 0. By convention, a depth of 100 means that |
| 297 | the advice should be innermost (i.e. at the end of the list), |
| 298 | whereas a depth of -100 means that the advice should be outermost. |
| 299 | |
| 300 | If PLACE is a symbol, its `default-value' will be affected. |
| 301 | Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. |
| 302 | Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR. |
| 303 | |
| 304 | If one of FUNCTION or OLDFUN is interactive, then the resulting function |
| 305 | is also interactive. There are 3 cases: |
| 306 | - FUNCTION is not interactive: the interactive spec of OLDFUN is used. |
| 307 | - The interactive spec of FUNCTION is itself a function: it should take one |
| 308 | argument (the interactive spec of OLDFUN, which it can pass to |
| 309 | `advice-eval-interactive-spec') and return the list of arguments to use. |
| 310 | - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." |
| 311 | (declare (debug t)) ;;(indent 2) |
| 312 | `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) |
| 313 | ,function ,props)) |
| 314 | |
| 315 | ;;;###autoload |
| 316 | (defun advice--add-function (where ref function props) |
| 317 | (let* ((name (cdr (assq 'name props))) |
| 318 | (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) |
| 319 | (when a |
| 320 | ;; The advice is already present. Remove the old one, first. |
| 321 | (setf (gv-deref ref) |
| 322 | (advice--remove-function (gv-deref ref) |
| 323 | (or name (advice--car a))))) |
| 324 | (setf (gv-deref ref) |
| 325 | (advice--make where function (gv-deref ref) props)))) |
| 326 | |
| 327 | ;;;###autoload |
| 328 | (defmacro remove-function (place function) |
| 329 | "Remove the FUNCTION piece of advice from PLACE. |
| 330 | If FUNCTION was not added to PLACE, do nothing. |
| 331 | Instead of FUNCTION being the actual function, it can also be the `name' |
| 332 | of the piece of advice." |
| 333 | (declare (debug t)) |
| 334 | (gv-letplace (getter setter) (advice--normalize-place place) |
| 335 | (macroexp-let2 nil new `(advice--remove-function ,getter ,function) |
| 336 | `(unless (eq ,new ,getter) ,(funcall setter new))))) |
| 337 | |
| 338 | (defun advice-function-mapc (f function-def) |
| 339 | "Apply F to every advice function in FUNCTION-DEF. |
| 340 | F is called with two arguments: the function that was added, and the |
| 341 | properties alist that was specified when it was added." |
| 342 | (while (advice--p function-def) |
| 343 | (funcall f (advice--car function-def) (advice--props function-def)) |
| 344 | (setq function-def (advice--cdr function-def)))) |
| 345 | |
| 346 | (defun advice-function-member-p (advice function-def) |
| 347 | "Return non-nil if ADVICE is already in FUNCTION-DEF. |
| 348 | Instead of ADVICE being the actual function, it can also be the `name' |
| 349 | of the piece of advice." |
| 350 | (advice--member-p advice :use-both function-def)) |
| 351 | |
| 352 | ;;;; Specific application of add-function to `symbol-function' for advice. |
| 353 | |
| 354 | (defun advice--subst-main (old new) |
| 355 | (advice--tweak old |
| 356 | (lambda (first _rest _props) (if (not first) new)))) |
| 357 | |
| 358 | (defun advice--normalize (symbol def) |
| 359 | (cond |
| 360 | ((special-form-p def) |
| 361 | ;; Not worth the trouble trying to handle this, I think. |
| 362 | (error "Advice impossible: %S is a special form" symbol)) |
| 363 | ((and (symbolp def) (macrop def)) |
| 364 | (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r)))))) |
| 365 | (put symbol 'advice--saved-rewrite (cons def (cdr newval))) |
| 366 | newval)) |
| 367 | ;; `f' might be a pure (hence read-only) cons! |
| 368 | ((and (eq 'macro (car-safe def)) |
| 369 | (not (ignore-errors (setcdr def (cdr def)) t))) |
| 370 | (cons 'macro (cdr def))) |
| 371 | (t def))) |
| 372 | |
| 373 | (defsubst advice--strip-macro (x) |
| 374 | (if (eq 'macro (car-safe x)) (cdr x) x)) |
| 375 | |
| 376 | (defun advice--symbol-function (symbol) |
| 377 | ;; The value conceptually stored in `symbol-function' is split into two |
| 378 | ;; parts: |
| 379 | ;; - the normal function definition. |
| 380 | ;; - the list of advice applied to it. |
| 381 | ;; `advice--symbol-function' is intended to return the second part (i.e. the |
| 382 | ;; list of advice, which includes a hole at the end which typically holds the |
| 383 | ;; first part, but this function doesn't care much which value is found |
| 384 | ;; there). |
| 385 | ;; In the "normal" state both parts are combined into a single value stored |
| 386 | ;; in the "function slot" of the symbol. But the way they are combined is |
| 387 | ;; different depending on whether the definition is a function or a macro. |
| 388 | ;; Also if the function definition is nil (i.e. unbound) or is an autoload, |
| 389 | ;; the second part is stashed away temporarily in the `advice--pending' |
| 390 | ;; symbol property. |
| 391 | (or (get symbol 'advice--pending) |
| 392 | (advice--strip-macro (symbol-function symbol)))) |
| 393 | |
| 394 | (defun advice--defalias-fset (fsetfun symbol newdef) |
| 395 | (unless fsetfun (setq fsetfun #'fset)) |
| 396 | (when (get symbol 'advice--saved-rewrite) |
| 397 | (put symbol 'advice--saved-rewrite nil)) |
| 398 | (setq newdef (advice--normalize symbol newdef)) |
| 399 | (let ((oldadv (advice--symbol-function symbol))) |
| 400 | (if (and newdef (not (autoloadp newdef))) |
| 401 | (let* ((snewdef (advice--strip-macro newdef)) |
| 402 | (snewadv (advice--subst-main oldadv snewdef))) |
| 403 | (put symbol 'advice--pending nil) |
| 404 | (funcall fsetfun symbol |
| 405 | (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))) |
| 406 | (unless (eq oldadv (get symbol 'advice--pending)) |
| 407 | (put symbol 'advice--pending (advice--subst-main oldadv nil))) |
| 408 | (funcall fsetfun symbol newdef)))) |
| 409 | |
| 410 | ;;;###autoload |
| 411 | (defun advice-add (symbol where function &optional props) |
| 412 | "Like `add-function' but for the function named SYMBOL. |
| 413 | Contrary to `add-function', this will properly handle the cases where SYMBOL |
| 414 | is defined as a macro, alias, command, ..." |
| 415 | ;; TODO: |
| 416 | ;; - record the advice location, to display in describe-function. |
| 417 | ;; - change all defadvice in lisp/**/*.el. |
| 418 | ;; - obsolete advice.el. |
| 419 | (let* ((f (symbol-function symbol)) |
| 420 | (nf (advice--normalize symbol f))) |
| 421 | (unless (eq f nf) (fset symbol nf)) |
| 422 | (add-function where (cond |
| 423 | ((eq (car-safe nf) 'macro) (cdr nf)) |
| 424 | ;; Reasons to delay installation of the advice: |
| 425 | ;; - If the function is not yet defined, installing |
| 426 | ;; the advice would affect `fboundp'ness. |
| 427 | ;; - the symbol-function slot of an autoloaded |
| 428 | ;; function is not itself a function value. |
| 429 | ;; - `autoload' does nothing if the function is |
| 430 | ;; not an autoload or undefined. |
| 431 | ((or (not nf) (autoloadp nf)) |
| 432 | (get symbol 'advice--pending)) |
| 433 | (t (symbol-function symbol))) |
| 434 | function props) |
| 435 | (put symbol 'function-documentation `(advice--make-docstring ',symbol)) |
| 436 | (add-function :around (get symbol 'defalias-fset-function) |
| 437 | #'advice--defalias-fset)) |
| 438 | nil) |
| 439 | |
| 440 | ;;;###autoload |
| 441 | (defun advice-remove (symbol function) |
| 442 | "Like `remove-function' but for the function named SYMBOL. |
| 443 | Contrary to `remove-function', this also works when SYMBOL is a macro |
| 444 | or an autoload and it preserves `fboundp'. |
| 445 | Instead of the actual function to remove, FUNCTION can also be the `name' |
| 446 | of the piece of advice." |
| 447 | (let ((f (symbol-function symbol))) |
| 448 | (remove-function (cond ;This is `advice--symbol-function' but as a "place". |
| 449 | ((get symbol 'advice--pending) |
| 450 | (get symbol 'advice--pending)) |
| 451 | ((eq (car-safe f) 'macro) (cdr f)) |
| 452 | (t (symbol-function symbol))) |
| 453 | function) |
| 454 | (unless (advice--p (advice--symbol-function symbol)) |
| 455 | (remove-function (get symbol 'defalias-fset-function) |
| 456 | #'advice--defalias-fset) |
| 457 | (let ((asr (get symbol 'advice--saved-rewrite))) |
| 458 | (and asr (eq (cdr-safe (symbol-function symbol)) |
| 459 | (cdr asr)) |
| 460 | (fset symbol (car (get symbol 'advice--saved-rewrite))))))) |
| 461 | nil) |
| 462 | |
| 463 | (defun advice-mapc (fun symbol) |
| 464 | "Apply FUN to every advice function in SYMBOL. |
| 465 | FUN is called with a two arguments: the function that was added, and the |
| 466 | properties alist that was specified when it was added." |
| 467 | (advice-function-mapc fun (advice--symbol-function symbol))) |
| 468 | |
| 469 | ;;;###autoload |
| 470 | (defun advice-member-p (advice symbol) |
| 471 | "Return non-nil if ADVICE has been added to SYMBOL. |
| 472 | Instead of ADVICE being the actual function, it can also be the `name' |
| 473 | of the piece of advice." |
| 474 | (advice-function-member-p advice (advice--symbol-function symbol))) |
| 475 | |
| 476 | ;; When code is advised, called-interactively-p needs to be taught to skip |
| 477 | ;; the advising frames. |
| 478 | ;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p |
| 479 | ;; done from the advised function if the deepest advice is an around advice! |
| 480 | ;; In other cases (calls from an advice or calls from the advised function when |
| 481 | ;; the deepest advice is not an around advice), it should hopefully get |
| 482 | ;; it right. |
| 483 | (add-hook 'called-interactively-p-functions |
| 484 | #'advice--called-interactively-skip) |
| 485 | (defun advice--called-interactively-skip (origi frame1 frame2) |
| 486 | (let* ((i origi) |
| 487 | (get-next-frame |
| 488 | (lambda () |
| 489 | (setq frame1 frame2) |
| 490 | (setq frame2 (backtrace-frame i #'called-interactively-p)) |
| 491 | ;; (message "Advice Frame %d = %S" i frame2) |
| 492 | (setq i (1+ i))))) |
| 493 | (when (and (eq (nth 1 frame2) 'apply) |
| 494 | (progn |
| 495 | (funcall get-next-frame) |
| 496 | (advice--p (indirect-function (nth 1 frame2))))) |
| 497 | (funcall get-next-frame) |
| 498 | ;; If we now have the symbol, this was the head advice and |
| 499 | ;; we're done. |
| 500 | (while (advice--p (nth 1 frame1)) |
| 501 | ;; This was an inner advice called from some earlier advice. |
| 502 | ;; The stack frames look different depending on the particular |
| 503 | ;; kind of the earlier advice. |
| 504 | (let ((inneradvice (nth 1 frame1))) |
| 505 | (if (and (eq (nth 1 frame2) 'apply) |
| 506 | (progn |
| 507 | (funcall get-next-frame) |
| 508 | (advice--p (indirect-function |
| 509 | (nth 1 frame2))))) |
| 510 | ;; The earlier advice was something like a before/after |
| 511 | ;; advice where the "next" code is called directly by the |
| 512 | ;; advice--p object. |
| 513 | (funcall get-next-frame) |
| 514 | ;; It's apparently an around advice, where the "next" is |
| 515 | ;; called by the body of the advice in any way it sees fit, |
| 516 | ;; so we need to skip the frames of that body. |
| 517 | (while |
| 518 | (progn |
| 519 | (funcall get-next-frame) |
| 520 | (not (and (eq (nth 1 frame2) 'apply) |
| 521 | (eq (nth 3 frame2) inneradvice))))) |
| 522 | (funcall get-next-frame) |
| 523 | (funcall get-next-frame)))) |
| 524 | (- i origi 1)))) |
| 525 | |
| 526 | |
| 527 | (provide 'nadvice) |
| 528 | ;;; nadvice.el ends here |