1 ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
2 ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
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.
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.
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
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"))
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"
40 (let ((x (make-hook 1)))
45 (with-test-prefix "add-hook!"
47 (let ((x (make-hook 1)))
49 (add-hook! x proc2 #t)
50 (eq? (cadr (hook->list x))
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)))
60 (let ((x (make-hook 1)))
65 (with-test-prefix "run-hook"
66 (pass-if-exception "bad hook"
67 exception:wrong-type-arg
68 (let ((x (cons 'a 'b)))
70 (pass-if-exception "too many args"
71 exception:wrong-num-hook-args
72 (let ((x (make-hook 1)))
79 (let ((x (make-hook 1))
80 (dest-proc1 (lambda (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)
88 (and (eq? (car val) 'i-sunk-your-battleship)
89 (eq? (cdr val) 'no-way!)))))
91 (with-test-prefix "remove-hook!"
93 (let ((x (make-hook 1)))
96 (remove-hook! x proc1)
97 (not (memq proc1 (hook->list x)))))
98 ; Maybe it should error, but this is probably
100 (pass-if "empty hook"
101 (let ((x (make-hook 1)))
102 (remove-hook! x proc1)
104 (pass-if "hook->list"
105 (let ((x (make-hook 1)))
108 (and (memq proc1 (hook->list x))
109 (memq proc2 (hook->list x))
111 (pass-if "reset-hook!"
112 (let ((x (make-hook 1)))
116 (null? (hook->list x))))
117 (with-test-prefix "reset-hook!"
118 (pass-if "empty hook"
119 (let ((x (make-hook 1)))
122 (pass-if-exception "bad hook"
123 exception:wrong-type-arg
124 (reset-hook! '(a b))))))