1 ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
2 ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;;;; This program is free software; you can redistribute it and/or modify
5 ;;;; it under the terms of the GNU General Public License as published by
6 ;;;; the Free Software Foundation; either version 2, or (at your option)
7 ;;;; any later version.
9 ;;;; This program 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
12 ;;;; GNU General Public License for more details.
14 ;;;; You should have received a copy of the GNU General Public License
15 ;;;; along with this software; see the file COPYING. If not, write to
16 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
17 ;;;; Boston, MA 02111-1307 USA
19 ;;;; As a special exception, the Free Software Foundation gives permission
20 ;;;; for additional uses of the text contained in its release of GUILE.
22 ;;;; The exception is that, if you link the GUILE library with other files
23 ;;;; to produce an executable, this does not by itself cause the
24 ;;;; resulting executable to be covered by the GNU General Public License.
25 ;;;; Your use of that executable is in no way restricted on account of
26 ;;;; linking the GUILE library code into it.
28 ;;;; This exception does not however invalidate any other reasons why
29 ;;;; the executable file might be covered by the GNU General Public License.
31 ;;;; This exception applies only to the code released by the
32 ;;;; Free Software Foundation under the name GUILE. If you copy
33 ;;;; code from other Free Software Foundation releases into a copy of
34 ;;;; GUILE, as the General Public License permits, the exception does
35 ;;;; not apply to the code that you add in this way. To avoid misleading
36 ;;;; anyone as to the status of such modified files, you must delete
37 ;;;; this exception notice from them.
39 ;;;; If you write modifications of your own for GUILE, it is your choice
40 ;;;; whether to permit this exception to apply to your modifications.
41 ;;;; If you do not wish that, delete this exception notice.
47 ;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead
48 ;; of a misc-error? If so, the tests should be changed to expect failure.
49 (define exception:wrong-num-hook-args
50 (cons 'misc-error "Hook .* requires .* arguments"))
56 (let ((proc1 (lambda (x) (+ x 1)))
57 (proc2 (lambda (x) (- x 1)))
58 (bad-proc (lambda (x y) #t)))
59 (with-test-prefix "hooks"
65 (let ((x (make-hook 1)))
70 (with-test-prefix "add-hook!"
72 (let ((x (make-hook 1)))
74 (add-hook! x proc2 #t)
75 (eq? (cadr (hook->list x))
77 (pass-if-exception "illegal proc"
78 exception:wrong-type-arg
79 (let ((x (make-hook 1)))
80 (add-hook! x bad-proc)))
81 (pass-if-exception "illegal hook"
82 exception:wrong-type-arg
83 (add-hook! '(foo) proc1)))
85 (let ((x (make-hook 1)))
90 (with-test-prefix "run-hook"
91 (pass-if-exception "bad hook"
92 exception:wrong-type-arg
93 (let ((x (cons 'a 'b)))
95 (pass-if-exception "too many args"
96 exception:wrong-num-hook-args
97 (let ((x (make-hook 1)))
104 (let ((x (make-hook 1))
105 (dest-proc1 (lambda (x)
107 'i-sunk-your-battleship)))
108 (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
109 (val '(a-game-of battleship)))
110 (add-hook! x dest-proc1)
111 (add-hook! x dest-proc2 #t)
113 (and (eq? (car val) 'i-sunk-your-battleship)
114 (eq? (cdr val) 'no-way!)))))
116 (with-test-prefix "remove-hook!"
118 (let ((x (make-hook 1)))
121 (remove-hook! x proc1)
122 (not (memq proc1 (hook->list x)))))
123 ; Maybe it should error, but this is probably
125 (pass-if "empty hook"
126 (let ((x (make-hook 1)))
127 (remove-hook! x proc1)
129 (pass-if "hook->list"
130 (let ((x (make-hook 1)))
133 (and (memq proc1 (hook->list x))
134 (memq proc2 (hook->list x))
136 (pass-if "reset-hook!"
137 (let ((x (make-hook 1)))
141 (null? (hook->list x))))
142 (with-test-prefix "reset-hook!"
143 (pass-if "empty hook"
144 (let ((x (make-hook 1)))
147 (pass-if-exception "bad hook"
148 exception:wrong-type-arg
149 (reset-hook! '(a b))))))