source: project/release/4/uri-dispatch/trunk/tests/run.scm @ 15218

Last change on this file since 15218 was 15218, checked in by certainty, 11 years ago

added more tests

File size: 5.0 KB
Line 
1;;; run.scm ---
2;;
3;; Filename: run.scm
4;; Description:
5;; Author: David Krentzlin <david@lisp-unleashed.de>
6;; Maintainer:
7;; Created: Mi Jul 15 19:33:46 2009 (CEST)
8;; Version: $Id$
9;; Version:
10;; Last-Updated: Mi Jul 15 20:42:39 2009 (CEST)
11;;           By: David Krentzlin <david@lisp-unleashed.de>
12;;     Update #: 31
13;; URL:
14;; Keywords:
15;; Compatibility:
16;;
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;;
19;;; Commentary:
20;;
21;;
22;;
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24;;
25;;; Change log:
26;;
27;;
28;; RCS $Log$
29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30;;
31;; Copyright (c) <year> David Krentzlin <david@lisp-unleashed.de>
32;;
33;;   Permission is hereby granted, free of charge, to any person
34;;   obtaining a copy of this software and associated documentation
35;;   files (the "Software"), to deal in the Software without
36;;   restriction, including without limitation the rights to use,
37;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
38;;   copies of the Software, and to permit persons to whom the
39;;   Software is furnished to do so, subject to the following
40;;   conditions:
41;;
42;;   The above copyright notice and this permission notice shall be
43;;   included in all copies or substantial portions of the Software.
44;;
45;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
46;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
47;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
48;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
49;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
50;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
51;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
52;;   OTHER DEALINGS IN THE SOFTWARE.
53;;
54;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55;;
56;;; Code:
57(use test uri-common)
58(load "../uri-dispatch.scm")
59(import uri-dispatch)
60
61(module test-module
62  (test1 test2 echo)
63  (import scheme chicken)
64
65  (define (echo . args) args)
66  (define (test1 . args) #t)
67  (define (test2 . args) #t))
68
69(define (test3 . args) #t)
70(define (echo2 . args) args)
71
72
73(test-begin "uri-dispatch")
74
75(test "find procedure in module"
76      #t
77      (let ((uri (uri-reference "http://example.com/test-module/test1")))
78        (dispatch-uri uri)))
79
80(test "find procedure outside module"
81      #t
82      (let ((uri (uri-reference "http://example.com/test3")))
83        (dispatch-uri uri)))
84
85(test "find procedure outside module (negative)"
86      'dispatch-error
87      (let ((uri (uri-reference "http://example.com/nonexistent")))
88        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
89          (dispatch-uri uri))))
90
91(test "find procedure in module (negative)"
92      'dispatch-error
93      (let ((uri (uri-reference "http://example.com/nomod/nonexistent")))
94        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
95          (dispatch-uri uri))))
96
97
98(test "whitelist procedure outside module (negative)"
99      'dispatch-error
100      (let ((uri (uri-reference "http://example.com/test3")))
101        (parameterize ((dispatch-error (lambda args 'dispatch-error))
102                       (enable-checks #t))
103          (dispatch-uri uri))))
104
105(test "whitelist module (negative)"
106      'dispatch-error
107      (let ((uri (uri-reference "http://example.com/test-module/test1")))
108        (parameterize ((dispatch-error (lambda args 'dispatch-error))
109                       (enable-checks #t))
110          (dispatch-uri uri))))
111
112(test "whitelist procedure outside module (positive)"
113      #t
114      (let ((uri (uri-reference "http://example.com/test3")))
115        (parameterize ((dispatch-error (lambda args 'dispatch-error))
116                       (enable-checks #t))
117          (whitelist! '(test3))
118          (dispatch-uri uri))))
119
120(test "whitelist procedure inside module (positive)"
121      #t
122      (let ((uri (uri-reference "http://example.com/test-module/test1")))
123        (parameterize ((dispatch-error (lambda args 'dispatch-error))
124                       (enable-checks #t))
125          (whitelist! '((module test-module)))
126          (dispatch-uri uri))))
127     
128(test "default-dispatch-target"
129      #t
130      (let ((uri (uri-reference "http://example.com")))
131        (parameterize ((default-dispatch-target (lambda args  #t)))
132          (dispatch-uri uri))))
133
134(test "dispatch-error"
135      'custom-error
136      (let ((uri (uri-reference "http://example.com/i/dont/exist")))
137        (parameterize ((dispatch-error (lambda  args 'custom-error)))
138          (dispatch-uri uri))))
139
140(test "pass arguments (in module)"
141      (list "this" "is" "a" "test")
142      (let ((uri (uri-reference "http://example.com/test-module/echo/this/is/a/test")))
143        (dispatch-uri uri)))
144
145(test "pass arguments"
146      (list "this" "is" "a" "test")
147      (let ((uri (uri-reference "http://example.com/echo2/this/is/a/test")))
148        (dispatch-uri uri)))
149
150(test-end "uri-dispatch")
151
152
153
154
155
156;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157;;; run.scm ends here
Note: See TracBrowser for help on using the repository browser.