Changeset 16104 in project


Ignore:
Timestamp:
09/28/09 21:01:46 (10 years ago)
Author:
Moritz Heidkamp
Message:

use irregex for route matching (per Peter Bex)

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

Legend:

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

    r16094 r16104  
    1111                                ("/bar" (get "nested")))
    1212                               (post "ha!")))])
    13 
    1413    (test-assert (lset= '(get post) (map car routes)))
    1514
     
    2221                          (map car (alist-ref 'post routes)))))))
    2322
    24 
    2523(test-group "basic matching"
    2624
    2725  (test "this is the body"
    28         ((uri-match 'get "/" (make-routes '((get "this is the body"))))))
     26        ((uri-match 'get "/" (make-routes '(("/" (get "this is the body")))))))
    2927
    3028  (test "against the path of a uri-reference" "something!"
    3129        ((uri-match 'get (uri-reference "http://foo/bar") (make-routes '(("/bar" (get "something!")))))))
    3230
    33   (test-assert (not (uri-match 'get "/" (make-routes '((post "won't reach me"))))))
     31  (test-assert (not (uri-match 'get "/" (make-routes '(("/" (post "won't reach me")))))))
    3432
    3533  (test-group "with nesting"
     
    4745     
    4846      (test-assert (string= "105" ((uri-match 'get "/foo/10/5" routes))))
     47      (test-assert (not (uri-match 'get "/foo/bar/10" routes)))))
     48 
     49  (test-group "with irregex capture groups"
     50    (let ([routes (make-routes
     51                   `(("/foo" ((seq "/" (submatch (+ num)))
     52                              ((seq "/" (submatch (+ num)))
     53                               (get ,string-append))))))])
     54      (test-assert (string= "105" ((uri-match 'get "/foo/10/5" routes))))
     55      (test-assert (not (uri-match 'get "/foo/bar/10" routes)))))
     56 
     57  (test-group "with irregex named capture groups"
     58    (let ([routes (make-routes
     59                   `(("/foo" ((seq "/" (submatch (+ num)))
     60                              ((seq "/" (or (submatch-named b (+ num))
     61                                            (submatch-named c (+ alpha))))
     62                               (get ,(lambda (a #!key (b "b") (c "c"))
     63                                       (string-append a b c))))))))])
     64      (test "105c" ((uri-match 'get "/foo/10/5" routes)))
     65      (test "10bx" ((uri-match 'get "/foo/10/x" routes)))
    4966      (test-assert (not (uri-match 'get "/foo/bar/10" routes))))))
    5067
     
    5269(test-group "matcher"
    5370         
    54   (let ([matcher (make-uri-matcher '((get "is") ("/this" (post "it") ("/or" (put "what?")))))])
     71  (let ([matcher (make-uri-matcher '(("/" (get "is")) ("/this" (post "it") ("/or" (put "what?")))))])
    5572
    5673    (test-assert (equal? "is" ((matcher 'get "/"))))
  • release/4/uri-match/trunk/uri-match.scm

    r16096 r16104  
    2020
    2121(import chicken scheme)
    22 (use uri-common srfi-1 srfi-13 data-structures regex)
     22(use uri-common srfi-1 srfi-13 data-structures)
     23(require-library regex)
     24(import irregex)
    2325
     26(define (maybe-string->sre obj) ;; Remove when irregex is updated in chicken
     27  (if (string? obj) (string->sre obj) obj))
    2428
    2529;; Transforms something like this:
     
    3741;;
    3842(define (make-routes routes #!optional (path ""))
    39   (if (null? routes) '()
    40       (let* ([method-or-path (caar routes)]
    41              [body-or-routes (cdar routes)]
    42              [result (make-routes (cdr routes) path)])
     43  (let ((path (maybe-string->sre path)))
     44    (if (null? routes) '()
     45        (let* ([method-or-path (caar routes)]
     46               [body-or-routes (cdar routes)]
     47               [result (make-routes (cdr routes) path)])
    4348       
    44         (if (symbol? method-or-path)
    45             (let ([method (string->symbol (string-downcase (symbol->string method-or-path)))])
    46               (alist-update! method (append (alist-ref method result eq? '())
    47                                             (list (cons (if (string= path "") "/" path) body-or-routes))) result))
    48             (fold (lambda (e r)
    49                     (let ([method (car e)]
    50                           [routes (cdr e)])
    51                       (alist-update! method (append routes (alist-ref method result eq? '())) r)))
    52                   result (make-routes body-or-routes (conc path method-or-path)))))))
     49          (if (symbol? method-or-path)
     50              (let ([method (string->symbol (string-downcase (symbol->string method-or-path)))])
     51                (alist-update! method (append (alist-ref method result eq? '())
     52                                              (list (cons (irregex path) body-or-routes))) result))
     53              (let ((subpath (maybe-string->sre method-or-path)))
     54                (fold (lambda (e r)
     55                        (let ([method (car e)]
     56                              [routes (cdr e)])
     57                          (alist-update! method (append routes (alist-ref method result eq? '())) r)))
     58                      result (make-routes body-or-routes `(seq ,path ,subpath)))))))))
    5359
     60;; TODO: Get rid of the irregex argument, once irregex 0.8 is imported.
     61;; This includes a procedure to extract the named submatches from the matchdata.
     62;; We also have irregex-match-num-submatches, which is currently not exported.
     63(define (apply-with-matches proc irregex matchdata)
     64  (let ((positional (map (lambda (i)
     65                           (irregex-match-substring matchdata i))
     66                         (iota (irregex-submatches irregex) 1)))
     67        (named (fold (lambda (n args)
     68                       (let ((str (irregex-match-substring matchdata (car n))))
     69                         (if str
     70                             (cons (string->keyword (symbol->string (car n)))
     71                                   (cons str args))
     72                             args)))
     73                          '()
     74                          (irregex-names irregex))))
     75    (apply proc (append positional named))))
    5476
    5577;; Matches a given HTTP method and path (or uri-path, respectively) in
     
    6183    (let find ([routes (alist-ref method routes)])
    6284      (and routes (not (null? routes))
    63            (let ([matches (string-match (caar routes) path)])
     85           (let ([matches (irregex-match (caar routes) path)])
    6486             (if matches
    6587                 (let ([body (cadar routes)])
    6688                   (if (procedure? body)
    67                        (lambda () (apply body (cdr matches)))
     89                       (lambda () (apply-with-matches body (caar routes) matches))
    6890                       (lambda () body)))
    6991                 (find (cdr routes))))))))
Note: See TracChangeset for help on using the changeset viewer.