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

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

replaced uri? with uri-reference?

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:52:05 2009 (CEST)
11;;           By: David Krentzlin <david@lisp-unleashed.de>
12;;     Update #: 33
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) <2009> 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 uri-dispatch)
58(import uri-dispatch)
59
60(module test-module
61  (test1 test2 echo)
62  (import scheme chicken)
63
64  (define (echo . args) args)
65  (define (test1 . args) #t)
66  (define (test2 . args) #t))
67
68(define (test3 . args) #t)
69(define (echo2 . args) args)
70
71
72(test-begin "uri-dispatch")
73
74(test "find procedure in module"
75      #t
76      (let ((uri (uri-reference "http://example.com/test-module/test1")))
77        (dispatch-uri uri)))
78
79(test "find procedure outside module"
80      #t
81      (let ((uri (uri-reference "http://example.com/test3")))
82        (dispatch-uri uri)))
83
84(test "find procedure outside module (negative)"
85      'dispatch-error
86      (let ((uri (uri-reference "http://example.com/nonexistent")))
87        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
88          (dispatch-uri uri))))
89
90(test "find procedure in module (negative)"
91      'dispatch-error
92      (let ((uri (uri-reference "http://example.com/nomod/nonexistent")))
93        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
94          (dispatch-uri uri))))
95
96
97(test "whitelist procedure outside module (negative)"
98      'dispatch-error
99      (let ((uri (uri-reference "http://example.com/test3")))
100        (parameterize ((dispatch-error (lambda args 'dispatch-error))
101                       (enable-checks #t))
102          (dispatch-uri uri))))
103
104(test "whitelist module (negative)"
105      'dispatch-error
106      (let ((uri (uri-reference "http://example.com/test-module/test1")))
107        (parameterize ((dispatch-error (lambda args 'dispatch-error))
108                       (enable-checks #t))
109          (dispatch-uri uri))))
110
111(test "whitelist procedure outside module (positive)"
112      #t
113      (let ((uri (uri-reference "http://example.com/test3")))
114        (parameterize ((dispatch-error (lambda args 'dispatch-error))
115                       (enable-checks #t))
116          (whitelist! '(test3))
117          (dispatch-uri uri))))
118
119(test "whitelist procedure inside module (positive)"
120      #t
121      (let ((uri (uri-reference "http://example.com/test-module/test1")))
122        (parameterize ((dispatch-error (lambda args 'dispatch-error))
123                       (enable-checks #t))
124          (whitelist! '((module test-module)))
125          (dispatch-uri uri))))
126     
127(test "default-dispatch-target"
128      #t
129      (let ((uri (uri-reference "http://example.com")))
130        (parameterize ((default-dispatch-target (lambda args  #t)))
131          (dispatch-uri uri))))
132
133(test "dispatch-error"
134      'custom-error
135      (let ((uri (uri-reference "http://example.com/i/dont/exist")))
136        (parameterize ((dispatch-error (lambda  args 'custom-error)))
137          (dispatch-uri uri))))
138
139(test "pass arguments (in module)"
140      (list "this" "is" "a" "test")
141      (let ((uri (uri-reference "http://example.com/test-module/echo/this/is/a/test")))
142        (dispatch-uri uri)))
143
144(test "pass arguments"
145      (list "this" "is" "a" "test")
146      (let ((uri (uri-reference "http://example.com/echo2/this/is/a/test")))
147        (dispatch-uri uri)))
148
149(test-end "uri-dispatch")
150
151
152
153
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;;; run.scm ends here
Note: See TracBrowser for help on using the repository browser.