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