Commit | Line | Data |
---|---|---|
fb372b0b MD |
1 | ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*- |
2 | ;;;; Copyright (C) 1999 Free Software Foundation, Inc. | |
3 | ;;;; | |
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. | |
8 | ;;;; | |
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. | |
13 | ;;;; | |
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 | |
18 | ;;;; | |
19 | ;;;; As a special exception, the Free Software Foundation gives permission | |
20 | ;;;; for additional uses of the text contained in its release of GUILE. | |
21 | ;;;; | |
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. | |
27 | ;;;; | |
28 | ;;;; This exception does not however invalidate any other reasons why | |
29 | ;;;; the executable file might be covered by the GNU General Public License. | |
30 | ;;;; | |
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. | |
38 | ;;;; | |
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. | |
42 | ||
43 | ;;; {Description} | |
44 | ;;; | |
45 | ;;; A test suite for hooks. I maybe should've split off some of the | |
46 | ;;; stuff (like with alists), but this is small enough that it | |
47 | ;;; probably isn't worth the hassle. A little note: in some places it | |
48 | ;;; catches all errors when it probably shouldn't, since there's only | |
49 | ;;; one error we consider correct. This is mostly because the | |
50 | ;;; add-hook! error in released guiles isn't really accurate | |
51 | ;;; This should be changed once a released version returns | |
52 | ;;; wrong-type-arg from add-hook! | |
53 | ||
54 | ;; {Utility stuff} | |
55 | ;; Evaluate form inside a catch; if it throws an error, return true | |
56 | ;; This is good for checking that errors are not ignored | |
57 | ||
58 | (define-macro (catch-error-returning-true error . form) | |
59 | `(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t))) | |
60 | ||
61 | ;; Evaluate form inside a catch; if it throws an error, return false | |
62 | ;; Good for making sure that errors don't occur | |
63 | ||
64 | (define-macro (catch-error-returning-false error . form) | |
65 | `(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f))) | |
66 | ||
67 | ;; pass-if-not: syntactic sugar | |
68 | ||
69 | (define-macro (pass-if-not string form) | |
70 | `(pass-if ,string (not ,form))) | |
71 | ||
72 | ;; {The tests} | |
fb372b0b | 73 | (let ((proc1 (lambda (x) (+ x 1))) |
57e7f270 DH |
74 | (proc2 (lambda (x) (- x 1))) |
75 | (bad-proc (lambda (x y) #t))) | |
76 | (with-test-prefix "hooks" | |
77 | (pass-if "make-hook" | |
78 | (catch-error-returning-false | |
79 | #t | |
80 | (define x (make-hook 1)))) | |
fb372b0b | 81 | |
57e7f270 DH |
82 | (pass-if "add-hook!" |
83 | (catch-error-returning-false | |
84 | #t | |
85 | (let ((x (make-hook 1))) | |
86 | (add-hook! x proc1) | |
87 | (add-hook! x proc2)))) | |
fb372b0b | 88 | |
57e7f270 DH |
89 | (with-test-prefix "add-hook!" |
90 | (pass-if "append" | |
91 | (let ((x (make-hook 1))) | |
92 | (add-hook! x proc1) | |
93 | (add-hook! x proc2 #t) | |
94 | (eq? (cadr (hook->list x)) | |
95 | proc2))) | |
96 | (pass-if "illegal proc" | |
97 | (catch-error-returning-true | |
98 | #t | |
99 | (let ((x (make-hook 1))) | |
100 | (add-hook! x bad-proc)))) | |
101 | (pass-if "illegal hook" | |
102 | (catch-error-returning-true | |
103 | 'wrong-type-arg | |
104 | (add-hook! '(foo) proc1)))) | |
105 | (pass-if "run-hook" | |
106 | (let ((x (make-hook 1))) | |
107 | (catch-error-returning-false #t | |
108 | (add-hook! x proc1) | |
109 | (add-hook! x proc2) | |
110 | (run-hook x 1)))) | |
111 | (with-test-prefix "run-hook" | |
112 | (pass-if "bad hook" | |
113 | (catch-error-returning-true | |
114 | #t | |
115 | (let ((x (cons 'a 'b))) | |
116 | (run-hook x 1)))) | |
117 | (pass-if "too many args" | |
118 | (let ((x (make-hook 1))) | |
119 | (catch-error-returning-true | |
120 | #t | |
121 | (add-hook! x proc1) | |
122 | (add-hook! x proc2) | |
123 | (run-hook x 1 2)))) | |
fb372b0b | 124 | |
57e7f270 DH |
125 | (pass-if |
126 | "destructive procs" | |
127 | (let ((x (make-hook 1)) | |
128 | (dest-proc1 (lambda (x) | |
129 | (set-car! x | |
130 | 'i-sunk-your-battleship))) | |
131 | (dest-proc2 (lambda (x) (set-cdr! x 'no-way!))) | |
132 | (val '(a-game-of battleship))) | |
133 | (add-hook! x dest-proc1) | |
134 | (add-hook! x dest-proc2 #t) | |
135 | (run-hook x val) | |
136 | (and (eq? (car val) 'i-sunk-your-battleship) | |
137 | (eq? (cdr val) 'no-way!))))) | |
fb372b0b | 138 | |
57e7f270 DH |
139 | (with-test-prefix "remove-hook!" |
140 | (pass-if "" | |
141 | (let ((x (make-hook 1))) | |
142 | (add-hook! x proc1) | |
143 | (add-hook! x proc2) | |
144 | (remove-hook! x proc1) | |
145 | (not (memq proc1 (hook->list x))))) | |
146 | ; Maybe it should error, but this is probably | |
147 | ; more convienient | |
148 | (pass-if "empty hook" | |
149 | (catch-error-returning-false | |
150 | #t | |
151 | (let ((x (make-hook 1))) | |
152 | (remove-hook! x proc1))))) | |
153 | (pass-if "hook->list" | |
154 | (let ((x (make-hook 1))) | |
155 | (add-hook! x proc1) | |
156 | (add-hook! x proc2) | |
5c96bc39 DH |
157 | (and (memq proc1 (hook->list x)) |
158 | (memq proc2 (hook->list x)) | |
159 | #t))) | |
57e7f270 DH |
160 | (pass-if "reset-hook!" |
161 | (let ((x (make-hook 1))) | |
162 | (add-hook! x proc1) | |
163 | (add-hook! x proc2) | |
164 | (reset-hook! x) | |
165 | (null? (hook->list x)))) | |
166 | (with-test-prefix "reset-hook!" | |
167 | (pass-if "empty hook" | |
168 | (let ((x (make-hook 1))) | |
5c96bc39 DH |
169 | (reset-hook! x) |
170 | #t)) | |
57e7f270 DH |
171 | (pass-if "bad hook" |
172 | (catch-error-returning-true | |
173 | #t | |
174 | (reset-hook! '(a b))))))) |