Changeset 12582 in project


Ignore:
Timestamp:
11/23/08 23:16:02 (13 years ago)
Author:
sjamaan
Message:

Add update-uri and update-auth procedures, change representation of query lists, fix a few small bugs discovered by adding more testcases

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

Legend:

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

    r12363 r12582  
    11(require-extension srfi-1)
    2 (require-extension uri-generic)
     2(load "../uri-generic.scm")
     3(import uri-generic)
    34(require-extension test)
    45
     
    99100    (,base "" "http://a/b/c/d;p?q")
    100101    ("" ,base "http://a/b/c/d;p?q")
     102    (,base "http:" "http:")
    101103    ))
    102104
     
    164166                  (test (sprintf "~S -> ~S" (second p) expected) expected decoded)))
    165167            encode/decode-cases))
     168
     169(define update-cases
     170  '(("/foo" (path: ("/bar")) "/bar")
     171    ("/foo" (host: "localhost") "//localhost/foo")
     172    ("http://foo" (query: ((a . "b") (c . #t) (d . "e"))) "http://foo?a=b&c&d=e")
     173    ("http://foo" (host: #f) "http:")
     174    ("http://foo" (authority: #f) "http:")))
     175
     176(test-group "update-uri test"
     177  (for-each (lambda (p)
     178              (let ((expected (uri-reference (third p)))
     179                    (updated (apply update-uri (uri-reference (first p)) (second p))))
     180                  (test (sprintf "~S * ~S -> ~S" (first p) (second p) (third p)) expected updated)))
     181            update-cases))
  • release/4/uri-generic/trunk/uri-generic.scm

    r12383 r12582  
    3838;;
    3939
     40(provide 'uri-generic)
     41
    4042(module uri-generic
    41   (uri-reference
     43  (uri-reference update-uri update-authority
    4244   uri? uri-auth uri-authority uri-scheme uri-path uri-query
    4345   uri-fragment uri-host uri-port uri-username uri-password
     
    9698  (let ((auth (URI-authority x)))
    9799    (and auth (URIAuth-password auth))))
     100
     101(define update-authority update-URIAuth)
     102
     103(define update-uri
     104  (let ((unset (list 'unset)))
     105   (lambda (uri . key/values)
     106     (apply
     107      (lambda (#!key
     108               (scheme (URI-scheme uri)) (path (URI-path uri))
     109               (query (URI-query uri)) (fragment (URI-fragment uri))
     110               (auth unset) (authority unset))
     111        (let* ((base-auth (or
     112                           (cond
     113                            ((not (eq? unset auth)) auth)
     114                            ((not (eq? unset authority)) authority)
     115                            (else (URI-authority uri)))
     116                           (make-URIAuth)))
     117               (updated-auth (apply update-authority base-auth key/values))
     118               (final-auth (if (equal? (make-URIAuth) updated-auth)
     119                               #f
     120                               updated-auth)))
     121          (make-URI scheme: scheme path: path query: query fragment: fragment
     122                    authority: final-auth))) key/values))))
    98123
    99124;; Character classes
     
    245270                                               (else (list #f rst)))))
    246271                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    247                                   path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
     272                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->alist uq))
    248273                                  fragment: (and uf (uri-char-list->string uf)))))
    249274         (else #f))))
     
    254279                         ((up rst)  (path-abempty rst)))
    255280                        (list ua up rst)))
    256          (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list #f s))))
     281         (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list '() s))))
    257282                          (list #f up rst)))))
    258283
     
    579604(define query-part (many (schar ":@/?!$'()*+,;")))
    580605
    581 (define (query->string s)
     606;; Convert an internal parser representation of a query to an alist
     607;; of symbol-string pairs
     608(define (query->alist s)
    582609  (match (query-part s)
    583610         ((p1 (#\= . rst))  (match (query-part rst)
    584                                    ((p2 _) `(,(uri-char-list->string p1) . ,(uri-char-list->string p2)))
     611                                   ((p2 _) `(,(string->symbol (uri-char-list->string p1)) . ,(uri-char-list->string p2)))
    585612                                   (else #f)))
    586          ((p1 ())   `(,(uri-char-list->string p1)))
     613         ((p1 ())   `(,(string->symbol (uri-char-list->string p1)) . #t))
    587614         (else #f)))
    588615 
     
    622649                                         (else (list #f rst)))))
    623650                   (make-URI scheme: #f authority: ua path: (map uri-char-list->string up)
    624                              query: (and uq (filter-map query->string uq))
     651                             query: (and uq (filter-map query->alist uq))
    625652                             fragment: (and uf (uri-char-list->string uf))))))
    626653
     
    646673                                              (else (list #f rst)))))
    647674                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    648                                   path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
     675                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->alist uq))
    649676                                  fragment: #f)))
    650677           (error 'absolute-uri "no scheme found in URI string"))))
     
    666693                 "")
    667694             (string-concatenate path)
    668              (if (and query (not (null? query))) (string-concatenate (cons "?" (intersperse (map (lambda (p) (if (null? (cdr p)) (car p) (conc (car p) "=" (cdr p)))) query) "&"))) "")
     695             (if (and query (not (null? query))) (string-concatenate (cons "?" (intersperse (map (lambda (p) (if (eq? (cdr p) #t) (symbol->string (car p)) (conc (car p) "=" (cdr p)))) query) "&"))) "")
    669696             (if fragment (string-append  "#" fragment) "")))
    670697           (else #f))))
Note: See TracChangeset for help on using the changeset viewer.