test-suite/tests/hooks.test

   1 ;;;; hooks.test --- tests guile's hooks implementation  -*- scheme -*-
   2 ;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 3 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 ;;;
  19 ;;; miscellaneous
  20 ;;;
  21
  22 ;; FIXME:  Maybe a standard wrong-num-arg exception should be thrown instead
  23 ;; of a misc-error?  If so, the tests should be changed to expect failure.
  24 (define exception:wrong-num-hook-args
  25   (cons 'misc-error "Hook .* requires .* arguments"))
  26
  27 ;;;
  28 ;;; {The tests}
  29 ;;;
  30
  31 (let  ((proc1 (lambda (x) (+ x 1)))
  32        (proc2 (lambda (x) (- x 1)))
  33        (bad-proc (lambda (x y) #t)))
  34   (with-test-prefix "hooks"
  35    (pass-if "make-hook"
  36      (make-hook 1)
  37      #t)
  38
  39    (pass-if "add-hook!"
  40      (let ((x (make-hook 1)))
  41        (add-hook! x proc1)
  42        (add-hook! x proc2)
  43        #t))
  44
  45    (with-test-prefix "add-hook!"
  46                      (pass-if "append"
  47                               (let ((x (make-hook 1)))
  48                                 (add-hook! x proc1)
  49                                 (add-hook! x proc2 #t)
  50                                 (eq? (cadr (hook->list x))
  51                                      proc2)))
  52                      (pass-if-exception "illegal proc"
  53                        exception:wrong-type-arg
  54                        (let ((x (make-hook 1)))
  55                          ;; Currently fails to raise an exception
  56                          ;; because we can't usefully get any arity
  57                          ;; information out of interpreted procedures. A
  58                          ;; FIXME I guess.
  59                          (throw 'unresolved)
  60                          (add-hook! x bad-proc)))
  61                      (pass-if-exception "illegal hook"
  62                        exception:wrong-type-arg
  63                        (add-hook! '(foo) proc1)))
  64    (pass-if "run-hook"
  65             (let ((x (make-hook 1)))
  66               (add-hook! x proc1)
  67               (add-hook! x proc2)
  68               (run-hook x 1)
  69               #t))
  70   (with-test-prefix "run-hook"
  71                     (pass-if-exception "bad hook"
  72                       exception:wrong-type-arg
  73                       (let ((x (cons 'a 'b)))
  74                         (run-hook x 1)))
  75                     (pass-if-exception "too many args"
  76                       exception:wrong-num-hook-args
  77                       (let ((x (make-hook 1)))
  78                         (add-hook! x proc1)
  79                         (add-hook! x proc2)
  80                         (run-hook x 1 2)))
  81
  82                     (pass-if
  83                      "destructive procs"
  84                      (let ((x (make-hook 1))
  85                            (dest-proc1 (lambda (x)
  86                                          (set-car! x
  87                                                    'i-sunk-your-battleship)))
  88                            (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
  89                            (val '(a-game-of battleship)))
  90                        (add-hook! x dest-proc1)
  91                        (add-hook! x dest-proc2 #t)
  92                        (run-hook x val)
  93                        (and (eq? (car val) 'i-sunk-your-battleship)
  94                             (eq? (cdr val) 'no-way!)))))
  95
  96   (with-test-prefix "remove-hook!"
  97                     (pass-if ""
  98                              (let ((x (make-hook 1)))
  99                                (add-hook! x proc1)
 100                                (add-hook! x proc2)
 101                                (remove-hook! x proc1)
 102                                (not (memq proc1 (hook->list x)))))
 103                     ; Maybe it should error, but this is probably
 104                     ; more convienient
 105                     (pass-if "empty hook"
 106                       (let ((x (make-hook 1)))
 107                         (remove-hook! x proc1)
 108                         #t)))
 109   (pass-if "hook->list"
 110            (let ((x (make-hook 1)))
 111              (add-hook! x proc1)
 112              (add-hook! x proc2)
 113              (and (memq proc1 (hook->list x))
 114                   (memq proc2 (hook->list x))
 115                   #t)))
 116   (pass-if "reset-hook!"
 117            (let ((x (make-hook 1)))
 118              (add-hook! x proc1)
 119              (add-hook! x proc2)
 120              (reset-hook! x)
 121              (null? (hook->list x))))
 122   (with-test-prefix "reset-hook!"
 123                     (pass-if "empty hook"
 124                              (let ((x (make-hook 1)))
 125                                (reset-hook! x)
 126                                #t))
 127                     (pass-if-exception "bad hook"
 128                       exception:wrong-type-arg
 129                       (reset-hook! '(a b))))))