Commit | Line | Data |
---|---|---|
fb372b0b | 1 | ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*- |
8ffcf6e7 | 2 | ;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010 Free Software Foundation, Inc. |
fb372b0b | 3 | ;;;; |
73be1d9e MV |
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 | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
fb372b0b | 8 | ;;;; |
73be1d9e | 9 | ;;;; This library is distributed in the hope that it will be useful, |
fb372b0b | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
fb372b0b | 13 | ;;;; |
73be1d9e MV |
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 | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
fb372b0b | 17 | |
8ffcf6e7 LC |
18 | (define-module (test-suite test-hooks) |
19 | #:use-module (test-suite lib)) | |
20 | ||
fb372b0b | 21 | ;;; |
6b4113af DH |
22 | ;;; miscellaneous |
23 | ;;; | |
fb372b0b | 24 | |
6b4113af DH |
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")) | |
fb372b0b | 29 | |
6b4113af DH |
30 | ;;; |
31 | ;;; {The tests} | |
32 | ;;; | |
fb372b0b | 33 | |
6b4113af | 34 | (let ((proc1 (lambda (x) (+ x 1))) |
57e7f270 DH |
35 | (proc2 (lambda (x) (- x 1))) |
36 | (bad-proc (lambda (x y) #t))) | |
37 | (with-test-prefix "hooks" | |
38 | (pass-if "make-hook" | |
6b4113af DH |
39 | (make-hook 1) |
40 | #t) | |
fb372b0b | 41 | |
57e7f270 | 42 | (pass-if "add-hook!" |
6b4113af DH |
43 | (let ((x (make-hook 1))) |
44 | (add-hook! x proc1) | |
45 | (add-hook! x proc2) | |
46 | #t)) | |
fb372b0b | 47 | |
57e7f270 DH |
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))) | |
6b4113af DH |
55 | (pass-if-exception "illegal proc" |
56 | exception:wrong-type-arg | |
57 | (let ((x (make-hook 1))) | |
4abb824c | 58 | (add-hook! x bad-proc))) |
6b4113af DH |
59 | (pass-if-exception "illegal hook" |
60 | exception:wrong-type-arg | |
61 | (add-hook! '(foo) proc1))) | |
57e7f270 DH |
62 | (pass-if "run-hook" |
63 | (let ((x (make-hook 1))) | |
6b4113af DH |
64 | (add-hook! x proc1) |
65 | (add-hook! x proc2) | |
66 | (run-hook x 1) | |
67 | #t)) | |
57e7f270 | 68 | (with-test-prefix "run-hook" |
6b4113af DH |
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))) | |
fb372b0b | 79 | |
57e7f270 DH |
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!))))) | |
fb372b0b | 93 | |
57e7f270 DH |
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" | |
6b4113af DH |
104 | (let ((x (make-hook 1))) |
105 | (remove-hook! x proc1) | |
106 | #t))) | |
57e7f270 DH |
107 | (pass-if "hook->list" |
108 | (let ((x (make-hook 1))) | |
109 | (add-hook! x proc1) | |
110 | (add-hook! x proc2) | |
5c96bc39 DH |
111 | (and (memq proc1 (hook->list x)) |
112 | (memq proc2 (hook->list x)) | |
113 | #t))) | |
57e7f270 DH |
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))) | |
5c96bc39 DH |
123 | (reset-hook! x) |
124 | #t)) | |
6b4113af DH |
125 | (pass-if-exception "bad hook" |
126 | exception:wrong-type-arg | |
127 | (reset-hook! '(a b)))))) |