* lisp/emacs-lisp/nadvice.el: Add buffer-local support to add-function.

(advice--buffer-local-function-sample): New var.
(advice--set-buffer-local, advice--buffer-local): New functions.
(add-function, remove-function): Use them.
This commit is contained in:
Stefan Monnier 2012-11-14 22:20:49 -05:00
parent 875ce3a7c5
commit a61428c42d
3 changed files with 38 additions and 5 deletions

View file

@ -1,3 +1,10 @@
2012-11-15 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/nadvice.el: Add buffer-local support to add-function.
(advice--buffer-local-function-sample): New var.
(advice--set-buffer-local, advice--buffer-local): New functions.
(add-function, remove-function): Use them.
2012-11-15 Drew Adams <drew.adams@oracle.com> 2012-11-15 Drew Adams <drew.adams@oracle.com>
* imenu.el (imenu--split-submenus): Use imenu--subalist-p (bug#12717). * imenu.el (imenu--split-submenus): Use imenu--subalist-p (bug#12717).

View file

@ -267,7 +267,7 @@ including `cl-block' and `cl-eval-when'.
;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
;;;;;; "cl-macs" "cl-macs.el" "c7ad09a74a1d2969406e7e2aaf3812fc") ;;;;;; "cl-macs" "cl-macs.el" "887ee7c4b9eb5766c6483d27e84aac21")
;;; Generated autoloads from cl-macs.el ;;; Generated autoloads from cl-macs.el
(autoload 'cl--compiler-macro-list* "cl-macs" "\ (autoload 'cl--compiler-macro-list* "cl-macs" "\

View file

@ -182,17 +182,31 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
(advice--make-1 (aref flist 1) (aref flist 3) (advice--make-1 (aref flist 1) (aref flist 3)
first nrest props))))))) first nrest props)))))))
(defvar advice--buffer-local-function-sample nil)
(defun advice--set-buffer-local (var val)
(if (function-equal val advice--buffer-local-function-sample)
(kill-local-variable var)
(set (make-local-variable var) val)))
;;;###autoload
(defun advice--buffer-local (var)
"Buffer-local value of VAR, presumed to contain a function."
(declare (gv-setter advice--set-buffer-local))
(if (local-variable-p var) (symbol-value var)
(setq advice--buffer-local-function-sample
(lambda (&rest args) (apply (default-value var) args)))))
;;;###autoload ;;;###autoload
(defmacro add-function (where place function &optional props) (defmacro add-function (where place function &optional props)
;; TODO: ;; TODO:
;; - provide something like `around' for interactive forms.
;; - provide some kind of buffer-local functionality at least when `place'
;; is a variable.
;; - obsolete with-wrapper-hook (mostly requires buffer-local support). ;; - obsolete with-wrapper-hook (mostly requires buffer-local support).
;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP
;; and tracing want to stay first. ;; and tracing want to stay first.
;; - maybe also let `where' specify some kind of predicate and use it ;; - maybe let `where' specify some kind of predicate and use it
;; to implement things like mode-local or eieio-defmethod. ;; to implement things like mode-local or eieio-defmethod.
;; Of course, that only makes sense if the predicates of all advices can
;; be combined and made more efficient.
;; :before is like a normal add-hook on a normal hook. ;; :before is like a normal add-hook on a normal hook.
;; :before-while is like add-hook on run-hook-with-args-until-failure. ;; :before-while is like add-hook on run-hook-with-args-until-failure.
;; :before-until is like add-hook on run-hook-with-args-until-success. ;; :before-until is like add-hook on run-hook-with-args-until-success.
@ -214,6 +228,10 @@ PROPS is an alist of additional properties, among which the following have
a special meaning: a special meaning:
- `name': a string or symbol. It can be used to refer to this piece of advice. - `name': a string or symbol. It can be used to refer to this piece of advice.
PLACE cannot be a simple variable. Instead it should either be
\(default-value 'VAR) or (local 'VAR) depending on whether FUNCTION
should be applied to VAR buffer-locally or globally.
If one of FUNCTION or OLDFUN is interactive, then the resulting function If one of FUNCTION or OLDFUN is interactive, then the resulting function
is also interactive. There are 3 cases: is also interactive. There are 3 cases:
- FUNCTION is not interactive: the interactive spec of OLDFUN is used. - FUNCTION is not interactive: the interactive spec of OLDFUN is used.
@ -222,6 +240,10 @@ is also interactive. There are 3 cases:
`advice-eval-interactive-spec') and return the list of arguments to use. `advice-eval-interactive-spec') and return the list of arguments to use.
- Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN."
(declare (debug t)) ;;(indent 2) (declare (debug t)) ;;(indent 2)
(cond ((eq 'local (car-safe place))
(setq place `(advice--buffer-local ,@(cdr place))))
((symbolp place)
(error "Use (default-value '%S) or (local '%S)" place place)))
`(advice--add-function ,where (gv-ref ,place) ,function ,props)) `(advice--add-function ,where (gv-ref ,place) ,function ,props))
;;;###autoload ;;;###autoload
@ -236,6 +258,10 @@ If FUNCTION was not added to PLACE, do nothing.
Instead of FUNCTION being the actual function, it can also be the `name' Instead of FUNCTION being the actual function, it can also be the `name'
of the piece of advice." of the piece of advice."
(declare (debug t)) (declare (debug t))
(cond ((eq 'local (car-safe place))
(setq place `(advice--buffer-local ,@(cdr place))))
((symbolp place)
(error "Use (default-value '%S) or (local '%S)" place place)))
(gv-letplace (getter setter) place (gv-letplace (getter setter) place
(macroexp-let2 nil new `(advice--remove-function ,getter ,function) (macroexp-let2 nil new `(advice--remove-function ,getter ,function)
`(unless (eq ,new ,getter) ,(funcall setter new))))) `(unless (eq ,new ,getter) ,(funcall setter new)))))