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))))))
128