test/automated/advice-tests.el

   1 ;;; advice-tests.el --- Test suite for the new advice thingy.
   2
   3 ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (require 'ert)
  25
  26 (ert-deftest advice-tests-nadvice ()
  27   "Test nadvice code."
  28   (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
  29   (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2)))
  30   (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
  31   (defun sm-test1 (x) (+ x 4))
  32   (should (equal (sm-test1 6) 20))
  33   (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2)))
  34   (should (equal (sm-test1 6) 10))
  35   (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
  36   (should (equal (sm-test1 6) 50))
  37   (defun sm-test1 (x) (+ x 14))
  38   (should (equal (sm-test1 6) 100))
  39   (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
  40   (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
  41   (should (equal (sm-test1 6) 20))
  42   (should (equal (get 'sm-test1 'defalias-fset-function) nil))
  43
  44   (advice-add 'sm-test3 :around
  45               (lambda (f &rest args) `(toto ,(apply f args)))
  46               '((name . wrap-with-toto)))
  47   (defmacro sm-test3 (x) `(call-test3 ,x))
  48   (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))))
  49
  50 (ert-deftest advice-tests-macroaliases ()
  51   "Test nadvice code on aliases to macros."
  52   (defmacro sm-test1 (a) `(list ',a))
  53   (defalias 'sm-test1-alias 'sm-test1)
  54   (should (equal (macroexpand '(sm-test1-alias 5)) '(list '5)))
  55   (advice-add 'sm-test1-alias :around
  56               (lambda (f &rest args) `(cons 1 ,(apply f args))))
  57   (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5))))
  58   (defmacro sm-test1 (a) `(list 0 ',a))
  59   (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5)))))
  60
  61
  62 (ert-deftest advice-tests-advice ()
  63   "Test advice code."
  64   (defun sm-test2 (x) (+ x 4))
  65   (should (equal (sm-test2 6) 10))
  66   (defadvice sm-test2 (around sm-test activate)
  67     ad-do-it (setq ad-return-value (* ad-return-value 5)))
  68   (should (equal (sm-test2 6) 50))
  69   (ad-deactivate 'sm-test2)
  70   (should (equal (sm-test2 6) 10))
  71   (ad-activate 'sm-test2)
  72   (should (equal (sm-test2 6) 50))
  73   (defun sm-test2 (x) (+ x 14))
  74   (should (equal (sm-test2 6) 100))
  75   (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
  76   (ad-remove-advice 'sm-test2 'around 'sm-test)
  77   (should (equal (sm-test2 6) 100))
  78   (ad-activate 'sm-test2)
  79   (should (equal (sm-test2 6) 20))
  80   (should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
  81
  82   (defadvice sm-test4 (around wrap-with-toto activate)
  83     ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
  84   (defmacro sm-test4 (x) `(call-test4 ,x))
  85   (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
  86   (defmacro sm-test4 (x) `(call-testq ,x))
  87   (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
  88
  89   ;; This used to signal an error (bug#12858).
  90   (autoload 'sm-test6 "foo")
  91   (defadvice sm-test6 (around test activate)
  92     ad-do-it))
  93
  94 (ert-deftest advice-tests-combination ()
  95   "Combining old style and new style advices."
  96   (defun sm-test5 (x) (+ x 4))
  97   (should (equal (sm-test5 6) 10))
  98   (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
  99   (should (equal (sm-test5 6) 50))
 100   (defadvice sm-test5 (around test activate)
 101     ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
 102   (should (equal (sm-test5 5) 45.1))
 103   (ad-deactivate 'sm-test5)
 104   (should (equal (sm-test5 6) 50))
 105   (ad-activate 'sm-test5)
 106   (should (equal (sm-test5 6) 50.1))
 107   (defun sm-test5 (x) (+ x 14))
 108   (should (equal (sm-test5 6) 100.1))
 109   (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
 110   (should (equal (sm-test5 6) 20.1)))
 111
 112 (ert-deftest advice-test-called-interactively-p ()
 113   "Check interaction between advice and called-interactively-p."
 114   (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
 115   (advice-add 'sm-test7 :around
 116               (lambda (f &rest args)
 117                 (list (cons 1 (called-interactively-p)) (apply f args))))
 118   (should (equal (sm-test7) '((1 . nil) 11)))
 119   (should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
 120   (let ((smi 7))
 121     (advice-add 'sm-test7 :before
 122                 (lambda (&rest args)
 123                   (setq smi (called-interactively-p))))
 124     (should (equal (list (sm-test7) smi)
 125                    '(((1 . nil) 11) nil)))
 126     (should (equal (list (call-interactively 'sm-test7) smi)
 127                    '(((1 . t) 11) t))))
 128   (advice-add 'sm-test7 :around
 129               (lambda (f &rest args)
 130                 (cons (cons 2 (called-interactively-p)) (apply f args))))
 131   (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
 132
 133 (ert-deftest advice-test-called-interactively-p-around ()
 134   "Check interaction between around advice and called-interactively-p.
 135
 136 This tests the currently broken case of the innermost advice to a
 137 function being an around advice."
 138   :expected-result :failed
 139   (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p)))
 140   (advice-add 'sm-test7.2 :around
 141               (lambda (f &rest args)
 142                 (list (cons 1 (called-interactively-p)) (apply f args))))
 143   (should (equal (sm-test7.2) '((1 . nil) (1 . nil))))
 144   (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t)))))
 145
 146 (ert-deftest advice-test-called-interactively-p-filter-args ()
 147   "Check interaction between filter-args advice and called-interactively-p."
 148   :expected-result :failed
 149   (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p)))
 150   (advice-add 'sm-test7.3 :filter-args #'list)
 151   (should (equal (sm-test7.3) '(1 . nil)))
 152   (should (equal (call-interactively 'sm-test7.3) '(1 . t))))
 153
 154 (ert-deftest advice-test-call-interactively ()
 155   "Check interaction between advice on call-interactively and called-interactively-p."
 156   (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
 157   (let ((old (symbol-function 'call-interactively)))
 158     (unwind-protect
 159         (progn
 160           (advice-add 'call-interactively :before #'ignore)
 161           (should (equal (sm-test7.4) '(1 . nil)))
 162           (should (equal (call-interactively 'sm-test7.4) '(1 . t))))
 163       (advice-remove 'call-interactively #'ignore)
 164       (should (eq (symbol-function 'call-interactively) old)))))
 165
 166 (ert-deftest advice-test-interactive ()
 167   "Check handling of interactive spec."
 168   (defun sm-test8 (a) (interactive "p") a)
 169   (defadvice sm-test8 (before adv1 activate) nil)
 170   (defadvice sm-test8 (before adv2 activate) (interactive "P") nil)
 171   (should (equal (interactive-form 'sm-test8) '(interactive "P"))))
 172
 173 (ert-deftest advice-test-preactivate ()
 174   (should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
 175   (defun sm-test9 (a) (interactive "p") a)
 176   (should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
 177   (defadvice sm-test9 (before adv1 pre act protect compile) nil)
 178   (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil))
 179   (defadvice sm-test9 (before adv2 pre act protect compile)
 180     (interactive "P") nil)
 181   (should (equal (interactive-form 'sm-test9) '(interactive "P"))))
 182
 183 (ert-deftest advice-test-multiples ()
 184   (let ((sm-test10 (lambda (a) (+ a 10)))
 185         (sm-advice (lambda (x) (if (consp x) (list (* 5 (car x))) (* 4 x)))))
 186     (should (equal (funcall sm-test10 5) 15))
 187     (add-function :filter-args (var sm-test10) sm-advice)
 188     (should (advice-function-member-p sm-advice sm-test10))
 189     (should (equal (funcall sm-test10 5) 35))
 190     (add-function :filter-return (var sm-test10) sm-advice)
 191     (should (equal (funcall sm-test10 5) 60))
 192     ;; Make sure we can add multiple times the same function, under the
 193     ;; condition that they have different `name' properties.
 194     (add-function :filter-args (var sm-test10) sm-advice '((name . "args")))
 195     (should (equal (funcall sm-test10 5) 140))
 196     (remove-function (var sm-test10) "args")
 197     (should (equal (funcall sm-test10 5) 60))
 198     (add-function :filter-args (var sm-test10) sm-advice '((name . "args")))
 199     (add-function :filter-return (var sm-test10) sm-advice '((name . "ret")))
 200     (should (equal (funcall sm-test10 5) 560))
 201     ;; Make sure that if we specify to remove a function that was added
 202     ;; multiple times, they are all removed, rather than removing only some
 203     ;; arbitrary subset of them.
 204     (remove-function (var sm-test10) sm-advice)
 205     (should (equal (funcall sm-test10 5) 15))))
 206
 207 ;; Local Variables:
 208 ;; no-byte-compile: t
 209 ;; End:
 210
 211 ;;; advice-tests.el ends here.