Changeset 18096 in project


Ignore:
Timestamp:
05/16/10 15:05:32 (9 years ago)
Author:
syn
Message:

allow continuation of matching process and get rid of call/cc

Location:
release/4/uri-match/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-match/trunk/tests/run.scm

    r16318 r18096  
    3636    (test-group "with procedure body"
    3737      (test 'something
    38         ((uri-match 'GET "/me" (make-routes `(((/ "me") (GET ,(lambda () 'something))))))))
     38        ((uri-match 'GET "/me" (make-routes `(((/ "me") (GET ,(lambda (c) 'something))))))))
    3939
    4040      (test 100 ((uri-match 'GET "/numbers/100"
    41                             (make-routes `(((/ "numbers" "(\\d+)") (GET ,(lambda (n) (string->number n)))))))))))
     41                            (make-routes `(((/ "numbers" "(\\d+)") (GET ,(lambda (c n) (string->number n)))))))))))
    4242
    4343  (test-group "with capture groups"
    44     (let ([routes (make-routes `(((/ "foo") ((/ "(\\d+)") ((/ "(\\d+)") (GET ,string-append))))))])
     44    (let ([routes (make-routes `(((/ "foo") ((/ "(\\d+)") ((/ "(\\d+)") (GET ,(lambda (c . args) (apply string-append args))))))))])
    4545     
    4646      (test "105" ((uri-match 'GET "/foo/10/5" routes)))
     
    5151                   `(((/ "foo") ((/ (submatch (+ num)))
    5252                                 ((/ (submatch (+ num)))
    53                                   (GET ,string-append))))))])
     53                                  (GET ,(lambda (c . args) (apply string-append args))))))))])
    5454
    5555      (test "105" ((uri-match 'GET "/foo/10/5" routes)))
     
    6161                                 ((/ (or (submatch-named b (+ num))
    6262                                         (submatch-named c (+ alpha))))
    63                                   (GET ,(lambda (a #!key (b "b") (c "c"))
     63                                  (GET ,(lambda (cont a #!key (b "b") (c "c"))
    6464                                          (string-append a b c))))))))])
    6565      (test "105c" ((uri-match 'GET "/foo/10/5" routes)))
     
    9090                                    ((/ "some")
    9191                                     ((/ "nested") (GET "I'm nested!")
    92                                       ((/ "route" "(.+)" "(.+)") (GET ,(lambda (x y)
     92                                      ((/ "route" "(.+)" "(.+)") (GET ,(lambda (c x y)
    9393                                                                         (format "I am the ~A and ~A!" x y)))))))))))
    9494
     
    9696    (test "I'm nested!" ((match 'GET "/some/nested")))
    9797    (test "I am the alpha and omega!" ((match 'GET (uri-reference "http://localhost/some/nested/route/alpha/omega"))))))
     98
     99(test-group "continuing matching"
     100  (let ((match (make-uri-matcher `(((/ (submatch (+ any)))
     101                                    (PUT ,(lambda (continue arg)
     102                                            (if (string=? "foo" arg)
     103                                                'this-is-foo
     104                                                (continue))))
     105                                    (PUT ,(lambda (continue arg)
     106                                            (if (string=? "sparta" arg)
     107                                                'this-is-spartaaaa
     108                                                (continue)))))))))
     109
     110    (test 'this-is-foo ((match 'PUT "/foo")))
     111    (test 'this-is-spartaaaa ((match 'PUT "/sparta")))
     112    (test-assert (not ((match 'PUT "/nothing"))))))
  • release/4/uri-match/trunk/uri-match.scm

    r18095 r18096  
    6262                    result (make-routes body-or-routes (append path subpath))))))))
    6363
     64(define (irregex-match->args irregex matchdata args)
     65  (let ((positional (map (lambda (i)
     66                           (irregex-match-substring matchdata i))
     67                         (iota (irregex-submatches irregex) 1)))
     68        (named (fold (lambda (n args)
     69                       (let ((str (irregex-match-substring matchdata (car n))))
     70                         (if str
     71                             (cons (string->keyword (symbol->string (car n)))
     72                                   (cons str args))
     73                             args)))
     74                     '()
     75                     (irregex-names irregex))))
     76    (append positional args named)))
     77
    6478;; TODO: Get rid of the irregexen argument, once irregex 0.8 is imported.
    6579;; This includes a procedure to extract the named submatches from the matchdata.
    6680;; We also have irregex-match-num-submatches, which is currently not exported.
    67 (define (apply-with-matches proc irregexen matches)
    68   (apply proc (fold-right (lambda (irregex matchdata args)
    69                             (let ((positional (map (lambda (i)
    70                                                      (irregex-match-substring matchdata i))
    71                                                    (iota (irregex-submatches irregex) 1)))
    72                                   (named (fold (lambda (n args)
    73                                                  (let ((str (irregex-match-substring matchdata (car n))))
    74                                                    (if str
    75                                                        (cons (string->keyword (symbol->string (car n)))
    76                                                              (cons str args))
    77                                                        args)))
    78                                                '()
    79                                                (irregex-names irregex))))
    80                               (append positional args named))) '() irregexen matches)))
     81(define (apply-with-matches proc next irregexen matches)
     82  (apply proc (cons next (fold-right irregex-match->args '() irregexen matches))))
    8183
    8284;; Matches a given HTTP method and path (or uri-path, respectively) in
     
    8688(define (uri-match method uri routes)
    8789  (let ((path (cdr (uri-path (if (uri-reference? uri) uri (uri-reference uri))))))
    88     (call/cc (lambda (return)
    89                (let find ((routes (alist-ref method routes)))
    90                  (and routes (not (null? routes))
    91                       (let ((route (car routes)))
    92                         (and (= (length (car route)) (length path))
    93                              (let ((matches (map irregex-match (car route) path))) ""
    94                                   (and (every identity matches)
    95                                        (return (let ((body (cadr route)))
    96                                                  (if (procedure? body)
    97                                                      (lambda () (apply-with-matches body (car route) matches))
    98                                                      (lambda () body)))))))
    99                         (find (cdr routes)))))))))
     90    (let find ((routes (alist-ref method routes)))
     91      (and routes (pair? routes)
     92           (let ((route (car routes))
     93                 (next  (lambda () (find (cdr routes)))))
     94             (or (and (= (length (car route)) (length path))
     95                      (let ((matches (map irregex-match (car route) path)))
     96                        (and (every identity matches)
     97                             (let ((body (cadr route)))
     98                               (if (procedure? body)
     99                                   (lambda () (apply-with-matches body
     100                                                                  (lambda () (and-let* ((next (next))) (next)))
     101                                                                  (car route)
     102                                                                  matches))
     103                                   (lambda () body))))))
     104                 (next)))))))
    100105
    101106
Note: See TracChangeset for help on using the changeset viewer.