Commit cb9c0a53 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* 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.
parent ef821434
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)
......
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))
(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))))
(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))))
;; 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))
;; This used to signal an error (bug#12858).
(autoload 'sm-test6 "foo")
(defadvice sm-test6 (around test activate)
ad-do-it)
;; 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")))
))
(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))))
;; This used to signal an error (bug#12858).
(autoload 'sm-test6 "foo")
(defadvice sm-test6 (around test activate)
ad-do-it))
(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)))
(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))))
(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"))))
(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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment