code.delx.au - gnu-emacs/blob - test/automated/advice-tests.el

   1 ;;; advice-tests.el --- Test suite for the new advice thingy.
   2
   3 ;; Copyright (C) 2012 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 (defvar advice-tests--data
  25   '(((defun sm-test1 (x) (+ x 4))
  26      (sm-test1 6) 10)
  27     ((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
  28      (sm-test1 6) 50)
  29     ((defun sm-test1 (x) (+ x 14))
  30      (sm-test1 6) 100)
  31     ((null (get 'sm-test1 'defalias-fset-function)) nil)
  32     ((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
  33      (sm-test1 6) 20)
  34     ((null (get 'sm-test1 'defalias-fset-function)) t)
  35
  36     ((defun sm-test2 (x) (+ x 4))
  37      (sm-test2 6) 10)
  38     ((defadvice sm-test2 (around sm-test activate)
  39        ad-do-it (setq ad-return-value (* ad-return-value 5)))
  40      (sm-test2 6) 50)
  41     ((ad-deactivate 'sm-test2)
  42      (sm-test2 6) 10)
  43     ((ad-activate 'sm-test2)
  44      (sm-test2 6) 50)
  45     ((defun sm-test2 (x) (+ x 14))
  46      (sm-test2 6) 100)
  47     ((null (get 'sm-test2 'defalias-fset-function)) nil)
  48     ((ad-remove-advice 'sm-test2 'around 'sm-test)
  49      (sm-test2 6) 100)
  50     ((ad-activate 'sm-test2)
  51      (sm-test2 6) 20)
  52     ((null (get 'sm-test2 'defalias-fset-function)) t)
  53
  54     ((advice-add 'sm-test3 :around
  55                  (lambda (f &rest args) `(toto ,(apply f args)))
  56                  '((name . wrap-with-toto)))
  57      (defmacro sm-test3 (x) `(call-test3 ,x))
  58      (macroexpand '(sm-test3 56)) (toto (call-test3 56)))
  59
  60     ((defadvice sm-test4 (around wrap-with-toto activate)
  61        ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
  62      (defmacro sm-test4 (x) `(call-test4 ,x))
  63      (macroexpand '(sm-test4 56)) (toto (call-test4 56)))
  64     ((defmacro sm-test4 (x) `(call-testq ,x))
  65      (macroexpand '(sm-test4 56)) (toto (call-testq 56)))
  66
  67     ;; Combining old style and new style advices.
  68     ((defun sm-test5 (x) (+ x 4))
  69      (sm-test5 6) 10)
  70     ((advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
  71      (sm-test5 6) 50)
  72     ((defadvice sm-test5 (around test activate)
  73        ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
  74      (sm-test5 5) 45.1)
  75     ((ad-deactivate 'sm-test5)
  76      (sm-test5 6) 50)
  77     ((ad-activate 'sm-test5)
  78      (sm-test5 6) 50.1)
  79     ((defun sm-test5 (x) (+ x 14))
  80      (sm-test5 6) 100.1)
  81     ((advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
  82      (sm-test5 6) 20.1)
  83     ))
  84
  85 (ert-deftest advice-tests ()
  86   "Test advice code."
  87   (with-temp-buffer
  88     (dolist (test advice-tests--data)
  89       (let ((res (eval `(progn ,@(butlast test)))))
  90         (should (equal (car (last test)) res))))))
  91
  92 ;; Local Variables:
  93 ;; no-byte-compile: t
  94 ;; End:
  95
  96 ;;; advice-tests.el ends here.