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

use irregex for route matching (per Peter Bex)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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.