guile18/test-suite/tests/hooks.test

   1 ;;;; hooks.test --- tests guile's hooks implementation  -*- scheme -*-
   2 ;;;; Copyright (C) 1999, 2001, 2006 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 2.1 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                          (add-hook! x bad-proc)))
  56                      (pass-if-exception "illegal hook"
  57                        exception:wrong-type-arg
  58                        (add-hook! '(foo) proc1)))
  59    (pass-if "run-hook"
  60             (let ((x (make-hook 1)))
  61               (add-hook! x proc1)
  62               (add-hook! x proc2)
  63               (run-hook x 1)
  64               #t))
  65   (with-test-prefix "run-hook"
  66                     (pass-if-exception "bad hook"
  67                       exception:wrong-type-arg
  68                       (let ((x (cons 'a 'b)))
  69                         (run-hook x 1)))
  70                     (pass-if-exception "too many args"
  71                       exception:wrong-num-hook-args
  72                       (let ((x (make-hook 1)))
  73                         (add-hook! x proc1)
  74                         (add-hook! x proc2)
  75                         (run-hook x 1 2)))
  76
  77                     (pass-if
  78                      "destructive procs"
  79                      (let ((x (make-hook 1))
  80                            (dest-proc1 (lambda (x)
  81                                          (set-car! x
  82                                                    'i-sunk-your-battleship)))
  83                            (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
  84                            (val '(a-game-of battleship)))
  85                        (add-hook! x dest-proc1)
  86                        (add-hook! x dest-proc2 #t)
  87                        (run-hook x val)
  88                        (and (eq? (car val) 'i-sunk-your-battleship)
  89                             (eq? (cdr val) 'no-way!)))))
  90
  91   (with-test-prefix "remove-hook!"
  92                     (pass-if ""
  93                              (let ((x (make-hook 1)))
  94                                (add-hook! x proc1)
  95                                (add-hook! x proc2)
  96                                (remove-hook! x proc1)
  97                                (not (memq proc1 (hook->list x)))))
  98                     ; Maybe it should error, but this is probably
  99                     ; more convienient
 100                     (pass-if "empty hook"
 101                       (let ((x (make-hook 1)))
 102                         (remove-hook! x proc1)
 103                         #t)))
 104   (pass-if "hook->list"
 105            (let ((x (make-hook 1)))
 106              (add-hook! x proc1)
 107              (add-hook! x proc2)
 108              (and (memq proc1 (hook->list x))
 109                   (memq proc2 (hook->list x))
 110                   #t)))
 111   (pass-if "reset-hook!"
 112            (let ((x (make-hook 1)))
 113              (add-hook! x proc1)
 114              (add-hook! x proc2)
 115              (reset-hook! x)
 116              (null? (hook->list x))))
 117   (with-test-prefix "reset-hook!"
 118                     (pass-if "empty hook"
 119                              (let ((x (make-hook 1)))
 120                                (reset-hook! x)
 121                                #t))
 122                     (pass-if-exception "bad hook"
 123                       exception:wrong-type-arg
 124                       (reset-hook! '(a b))))))