test-suite/tests/hooks.test

   1 ;;;; hooks.test --- tests guile's hooks implementation  -*- scheme -*-
   2 ;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010 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 (define-module (test-suite test-hooks)
  19   #:use-module (test-suite lib))
  20
  21 ;;;
  22 ;;; miscellaneous
  23 ;;;
  24
  25 ;; FIXME:  Maybe a standard wrong-num-arg exception should be thrown instead
  26 ;; of a misc-error?  If so, the tests should be changed to expect failure.
  27 (define exception:wrong-num-hook-args
  28   (cons 'misc-error "Hook .* requires .* arguments"))
  29
  30 ;;;
  31 ;;; {The tests}
  32 ;;;
  33
  34 (let  ((proc1 (lambda (x) (+ x 1)))
  35        (proc2 (lambda (x) (- x 1)))
  36        (bad-proc (lambda (x y) #t)))
  37   (with-test-prefix "hooks"
  38    (pass-if "make-hook"
  39      (make-hook 1)
  40      #t)
  41
  42    (pass-if "add-hook!"
  43      (let ((x (make-hook 1)))
  44        (add-hook! x proc1)
  45        (add-hook! x proc2)
  46        #t))
  47
  48    (with-test-prefix "add-hook!"
  49                      (pass-if "append"
  50                               (let ((x (make-hook 1)))
  51                                 (add-hook! x proc1)
  52                                 (add-hook! x proc2 #t)
  53                                 (eq? (cadr (hook->list x))
  54                                      proc2)))
  55                      (pass-if-exception "illegal proc"
  56                        exception:wrong-type-arg
  57                        (let ((x (make-hook 1)))
  58                          (add-hook! x bad-proc)))
  59                      (pass-if-exception "illegal hook"
  60                        exception:wrong-type-arg
  61                        (add-hook! '(foo) proc1)))
  62    (pass-if "run-hook"
  63             (let ((x (make-hook 1)))
  64               (add-hook! x proc1)
  65               (add-hook! x proc2)
  66               (run-hook x 1)
  67               #t))
  68   (with-test-prefix "run-hook"
  69                     (pass-if-exception "bad hook"
  70                       exception:wrong-type-arg
  71                       (let ((x (cons 'a 'b)))
  72                         (run-hook x 1)))
  73                     (pass-if-exception "too many args"
  74                       exception:wrong-num-hook-args
  75                       (let ((x (make-hook 1)))
  76                         (add-hook! x proc1)
  77                         (add-hook! x proc2)
  78                         (run-hook x 1 2)))
  79
  80                     (pass-if
  81                      "destructive procs"
  82                      (let ((x (make-hook 1))
  83                            (dest-proc1 (lambda (x)
  84                                          (set-car! x
  85                                                    'i-sunk-your-battleship)))
  86                            (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
  87                            (val '(a-game-of battleship)))
  88                        (add-hook! x dest-proc1)
  89                        (add-hook! x dest-proc2 #t)
  90                        (run-hook x val)
  91                        (and (eq? (car val) 'i-sunk-your-battleship)
  92                             (eq? (cdr val) 'no-way!)))))
  93
  94   (with-test-prefix "remove-hook!"
  95                     (pass-if ""
  96                              (let ((x (make-hook 1)))
  97                                (add-hook! x proc1)
  98                                (add-hook! x proc2)
  99                                (remove-hook! x proc1)
 100                                (not (memq proc1 (hook->list x)))))
 101                     ; Maybe it should error, but this is probably
 102                     ; more convienient
 103                     (pass-if "empty hook"
 104                       (let ((x (make-hook 1)))
 105                         (remove-hook! x proc1)
 106                         #t)))
 107   (pass-if "hook->list"
 108            (let ((x (make-hook 1)))
 109              (add-hook! x proc1)
 110              (add-hook! x proc2)
 111              (and (memq proc1 (hook->list x))
 112                   (memq proc2 (hook->list x))
 113                   #t)))
 114   (pass-if "reset-hook!"
 115            (let ((x (make-hook 1)))
 116              (add-hook! x proc1)
 117              (add-hook! x proc2)
 118              (reset-hook! x)
 119              (null? (hook->list x))))
 120   (with-test-prefix "reset-hook!"
 121                     (pass-if "empty hook"
 122                              (let ((x (make-hook 1)))
 123                                (reset-hook! x)
 124                                #t))
 125                     (pass-if-exception "bad hook"
 126                       exception:wrong-type-arg
 127                       (reset-hook! '(a b))))))