Changeset 15340 in project

Timestamp:

08/06/09 20:40:50 (12 years ago)

Author:

certainty

Message:

fixed bug in procedure-resolver. fixed typo. minor adjustments

Location:

release/4/uri-dispatch/trunk

Files:

• tests/run.scm (modified) (2 diffs)
• uri-dispatch.scm (modified) (5 diffs)

release/4/uri-dispatch/trunk/tests/run.scm

@@ -8 +8 @@
 ;; Version: $Id$
 ;; Version: 
-;; Last-Updated: Mi Jul 15 20:52:05 2009 (CEST)
+;; Last-Updated: Do Aug  6 20:49:24 2009 (CEST)
 ;;           By: David Krentzlin <david@lisp-unleashed.de>
-;;     Update #: 33
+;;     Update #: 35
 ;; URL: 
 ;; Keywords: 
@@ -68 +68 @@
 (define (test3 . args) #t)
 (define (echo2 . args) args)
+
+(enable-checks #f)
 
 

release/4/uri-dispatch/trunk/uri-dispatch.scm

@@ -8 +8 @@
 ;; Version: $Id$
 ;; Version: 
-;; Last-Updated: Mi Jul 15 21:49:20 2009 (CEST)
+;; Last-Updated: Do Aug  6 20:57:50 2009 (CEST)
 ;;           By: David Krentzlin <david@lisp-unleashed.de>
-;;     Update #: 96
+;;     Update #: 117
 ;; URL: 
 ;; Keywords: 
@@ -61 +61 @@
    dispatch-uri)
   (import scheme chicken)
-  (require-library uri-common environments srfi-13)
-  (import (only uri-common uri-reference? uri-path)
+  (require-library uri-common environments srfi-13 extras)
+  (import extras
+          (only uri-common uri-reference? uri-path)
           (only srfi-13 string-append)
           (only environments environment-ref environment-has-binding?))
@@ -70 +71 @@
   (define module-whitelist  (list))
   (define dispatch-environment interaction-environment)
-  (define enable-checks (make-parameter #f))
+  (define enable-checks (make-parameter #t))
   (define default-dispatch-target (make-parameter (lambda args #f)))
 
   (define (dispatch-uri uri)
     (unless (uri-reference? uri)
-      (error "Supplied argument is must be an uri"))
+      (error "Supplied argument must be an uri"))
     (let ((path (cdr (uri-path uri))))
       (cond
@@ -81 +82 @@
         (apply (or (default-dispatch-target)
                    (dispatch-error)) '()))
-       ((= 1 (length path))
+       ((null? (cdr path))
         (if (equal? (car path) "")
             (apply (or (default-dispatch-target) (dispatch-error)) '())
             (let ((handler (handler-ref (string->symbol (car path)))))
               (if handler
-                  (handler (cdr path)))
-                  (apply (dispatch-error) path))))
+                  (apply handler (cdr path))
+                  (apply (dispatch-error) path)))))
        (else
         (let ((mod/proc (handler-ref (string->symbol (string-append (car path) "#" (cadr path))) (string->symbol (car path)))))
@@ -94 +95 @@
               (let ((handler (handler-ref (string->symbol (car path)))))
                 (if handler
-                    (handler (cdr path))
+                    (apply handler (cdr path))
                     (apply (dispatch-error) path)))))))))