test-suite/tests/hooks.test

   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}
  73  (let  ((proc1 (lambda (x) (+ x 1)))
  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))))
  81
  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))))
  88
  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))))
 124
 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!)))))
 138
 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)
 157              (and (memq proc1 (hook->list x) )
 158                   (memq proc2 (hook->list x)))))
 159   (pass-if "reset-hook!"
 160            (let ((x (make-hook 1)))
 161              (add-hook! x proc1)
 162              (add-hook! x proc2)
 163              (reset-hook! x)
 164              (null? (hook->list x))))
 165   (with-test-prefix "reset-hook!"
 166                     (pass-if "empty hook"
 167                              (let ((x (make-hook 1)))
 168                                (reset-hook! x)))
 169                     (pass-if "bad hook"
 170                              (catch-error-returning-true
 171                               #t
 172                               (reset-hook! '(a b)))))))