* lisp/emacs-lisp/advice.el (ad-preactivate-advice): Adjust the cleanup to
the use of nadvice.el. * lisp/emacs-lisp/nadvice.el (advice--tweak): Make it possible for `tweak' to return an explicit nil. (advice--remove-function): Change accordingly. * test/automated/advice-tests.el: Split up. Add advice-test-preactivate.
This commit is contained in:
Stefan Monnier
parent
ef8214345b
commit
cb9c0a53bc
5 changed files with 121 additions and 99 deletions
|
|
@ -1,5 +1,12 @@
|
|||
2013-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/nadvice.el (advice--tweak): Make it possible for `tweak'
|
||||
to return an explicit nil.
|
||||
(advice--remove-function): Change accordingly.
|
||||
|
||||
* emacs-lisp/advice.el (ad-preactivate-advice): Adjust the cleanup to
|
||||
the use of nadvice.el.
|
||||
|
||||
* progmodes/which-func.el (which-function): Silence imenu errors
|
||||
(bug#13433).
|
||||
|
||||
|
|
|
|||
|
|
@ -2866,10 +2866,8 @@ advised definition from scratch."
|
|||
|
||||
(defun ad-preactivate-advice (function advice class position)
|
||||
"Preactivate FUNCTION and returns the constructed cache."
|
||||
(let* ((function-defined-p (fboundp function))
|
||||
(old-definition
|
||||
(if function-defined-p
|
||||
(symbol-function function)))
|
||||
(let* ((advicefunname (ad-get-advice-info-field function 'advicefunname))
|
||||
(old-advice (symbol-function advicefunname))
|
||||
(old-advice-info (ad-copy-advice-info function))
|
||||
(ad-advised-functions ad-advised-functions))
|
||||
(unwind-protect
|
||||
|
|
@ -2883,10 +2881,9 @@ advised definition from scratch."
|
|||
(list (ad-get-cache-definition function)
|
||||
(ad-get-cache-id function))))
|
||||
(ad-set-advice-info function old-advice-info)
|
||||
;; Don't `fset' function to nil if it was previously unbound:
|
||||
(if function-defined-p
|
||||
(fset function old-definition)
|
||||
(fmakunbound function)))))
|
||||
(advice-remove function advicefunname)
|
||||
(fset advicefunname old-advice)
|
||||
(if old-advice (advice-add function :around advicefunname)))))
|
||||
|
||||
|
||||
;; @@ Activation and definition handling:
|
||||
|
|
|
|||
|
|
@ -173,20 +173,21 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
|
|||
(let ((first (advice--car flist))
|
||||
(rest (advice--cdr flist))
|
||||
(props (advice--props flist)))
|
||||
(or (funcall tweaker first rest props)
|
||||
(let ((val (funcall tweaker first rest props)))
|
||||
(if val (car val)
|
||||
(let ((nrest (advice--tweak rest tweaker)))
|
||||
(if (eq rest nrest) flist
|
||||
(advice--make-1 (aref flist 1) (aref flist 3)
|
||||
first nrest props)))))))
|
||||
first nrest props))))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun advice--remove-function (flist function)
|
||||
(advice--tweak flist
|
||||
(lambda (first rest props)
|
||||
(if (or (not first)
|
||||
(equal function first)
|
||||
(cond ((not first) rest)
|
||||
((or (equal function first)
|
||||
(equal function (cdr (assq 'name props))))
|
||||
rest))))
|
||||
(list rest))))))
|
||||
|
||||
(defvar advice--buffer-local-function-sample nil)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
2013-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/advice-tests.el: Split up. Add advice-test-preactivate.
|
||||
|
||||
2013-01-14 Glenn Morris <rgm@gnu.org>
|
||||
|
||||
* automated/compile-tests.el (compile-tests--test-regexps-data):
|
||||
|
|
|
|||
|
|
@ -21,99 +21,112 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(ert-deftest advice-tests ()
|
||||
(ert-deftest advice-tests-nadvice ()
|
||||
"Test nadvice code."
|
||||
(defun sm-test1 (x) (+ x 4))
|
||||
(should (equal (sm-test1 6) 10))
|
||||
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 50))
|
||||
(defun sm-test1 (x) (+ x 14))
|
||||
(should (equal (sm-test1 6) 100))
|
||||
(should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
|
||||
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 20))
|
||||
(should (equal (get 'sm-test1 'defalias-fset-function) nil))
|
||||
|
||||
(advice-add 'sm-test3 :around
|
||||
(lambda (f &rest args) `(toto ,(apply f args)))
|
||||
'((name . wrap-with-toto)))
|
||||
(defmacro sm-test3 (x) `(call-test3 ,x))
|
||||
(should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))))
|
||||
|
||||
(ert-deftest advice-tests-advice ()
|
||||
"Test advice code."
|
||||
(with-temp-buffer
|
||||
(defun sm-test1 (x) (+ x 4))
|
||||
(should (equal (sm-test1 6) 10))
|
||||
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 50))
|
||||
(defun sm-test1 (x) (+ x 14))
|
||||
(should (equal (sm-test1 6) 100))
|
||||
(should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
|
||||
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 20))
|
||||
(should (equal (null (get 'sm-test1 'defalias-fset-function)) t))
|
||||
(defun sm-test2 (x) (+ x 4))
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(defadvice sm-test2 (around sm-test activate)
|
||||
ad-do-it (setq ad-return-value (* ad-return-value 5)))
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(ad-deactivate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(defun sm-test2 (x) (+ x 14))
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
|
||||
(ad-remove-advice 'sm-test2 'around 'sm-test)
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 20))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
|
||||
|
||||
(defun sm-test2 (x) (+ x 4))
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(defadvice sm-test2 (around sm-test activate)
|
||||
ad-do-it (setq ad-return-value (* ad-return-value 5)))
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(ad-deactivate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(defun sm-test2 (x) (+ x 14))
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
|
||||
(ad-remove-advice 'sm-test2 'around 'sm-test)
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 20))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
|
||||
(defadvice sm-test4 (around wrap-with-toto activate)
|
||||
ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
|
||||
(defmacro sm-test4 (x) `(call-test4 ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
|
||||
(defmacro sm-test4 (x) `(call-testq ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
|
||||
|
||||
(advice-add 'sm-test3 :around
|
||||
(lambda (f &rest args) `(toto ,(apply f args)))
|
||||
'((name . wrap-with-toto)))
|
||||
(defmacro sm-test3 (x) `(call-test3 ,x))
|
||||
(should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))
|
||||
;; This used to signal an error (bug#12858).
|
||||
(autoload 'sm-test6 "foo")
|
||||
(defadvice sm-test6 (around test activate)
|
||||
ad-do-it))
|
||||
|
||||
(defadvice sm-test4 (around wrap-with-toto activate)
|
||||
ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
|
||||
(defmacro sm-test4 (x) `(call-test4 ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
|
||||
(defmacro sm-test4 (x) `(call-testq ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
|
||||
(ert-deftest advice-tests-combination ()
|
||||
"Combining old style and new style advices."
|
||||
(defun sm-test5 (x) (+ x 4))
|
||||
(should (equal (sm-test5 6) 10))
|
||||
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(defadvice sm-test5 (around test activate)
|
||||
ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
|
||||
(should (equal (sm-test5 5) 45.1))
|
||||
(ad-deactivate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(ad-activate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50.1))
|
||||
(defun sm-test5 (x) (+ x 14))
|
||||
(should (equal (sm-test5 6) 100.1))
|
||||
(advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 20.1)))
|
||||
|
||||
;; Combining old style and new style advices.
|
||||
(defun sm-test5 (x) (+ x 4))
|
||||
(should (equal (sm-test5 6) 10))
|
||||
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(defadvice sm-test5 (around test activate)
|
||||
ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
|
||||
(should (equal (sm-test5 5) 45.1))
|
||||
(ad-deactivate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(ad-activate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50.1))
|
||||
(defun sm-test5 (x) (+ x 14))
|
||||
(should (equal (sm-test5 6) 100.1))
|
||||
(advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 20.1))
|
||||
(ert-deftest advice-test-called-interactively-p ()
|
||||
"Check interaction between advice and called-interactively-p."
|
||||
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(list (cons 1 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (sm-test7) '((1 . nil) 11)))
|
||||
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
|
||||
(let ((smi 7))
|
||||
(advice-add 'sm-test7 :before
|
||||
(lambda (&rest args)
|
||||
(setq smi (called-interactively-p))))
|
||||
(should (equal (list (sm-test7) smi)
|
||||
'(((1 . nil) 11) nil)))
|
||||
(should (equal (list (call-interactively 'sm-test7) smi)
|
||||
'(((1 . t) 11) t))))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(cons (cons 2 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
|
||||
|
||||
;; This used to signal an error (bug#12858).
|
||||
(autoload 'sm-test6 "foo")
|
||||
(defadvice sm-test6 (around test activate)
|
||||
ad-do-it)
|
||||
(ert-deftest advice-test-interactive ()
|
||||
"Check handling of interactive spec."
|
||||
(defun sm-test8 (a) (interactive "p") a)
|
||||
(defadvice sm-test8 (before adv1 activate) nil)
|
||||
(defadvice sm-test8 (before adv2 activate) (interactive "P") nil)
|
||||
(should (equal (interactive-form 'sm-test8) '(interactive "P"))))
|
||||
|
||||
;; Check interaction between advice and called-interactively-p.
|
||||
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(list (cons 1 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (sm-test7) '((1 . nil) 11)))
|
||||
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
|
||||
(let ((smi 7))
|
||||
(advice-add 'sm-test7 :before
|
||||
(lambda (&rest args)
|
||||
(setq smi (called-interactively-p))))
|
||||
(should (equal (list (sm-test7) smi)
|
||||
'(((1 . nil) 11) nil)))
|
||||
(should (equal (list (call-interactively 'sm-test7) smi)
|
||||
'(((1 . t) 11) t))))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(cons (cons 2 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))
|
||||
|
||||
;; Check handling of interactive spec.
|
||||
(defun sm-test8 (a) (interactive "p") a)
|
||||
(defadvice sm-test8 (before adv1 activate) nil)
|
||||
(defadvice sm-test8 (before adv2 activate) (interactive "P") nil)
|
||||
(should (equal (interactive-form 'sm-test8) '(interactive "P")))
|
||||
))
|
||||
(ert-deftest advice-test-preactivate ()
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
|
||||
(defun sm-test9 (a) (interactive "p") a)
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
|
||||
(defadvice sm-test9 (before adv1 pre act protect compile) nil)
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) nil))
|
||||
(defadvice sm-test9 (before adv2 pre act protect compile)
|
||||
(interactive "P") nil)
|
||||
(should (equal (interactive-form 'sm-test9) '(interactive "P"))))
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue