Changeset 12600 in project


Ignore:
Timestamp:
11/26/08 21:19:56 (11 years ago)
Author:
sjamaan
Message:

Merge and backport latest changes from uri-generic release 4 into release 3

Location:
release/3/uri-generic/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/uri-generic/trunk

  • release/3/uri-generic/trunk/tests/run.scm

    r12364 r12600  
    11(require-extension srfi-1)
    2 (require-extension uri-generic)
     2(load "../uri-generic.scm")
     3
    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/3/uri-generic/trunk/uri-generic.scm

    r12384 r12600  
    5252 (inline)
    5353 (lambda-lift)
    54  (export uri-reference
    55          uri? uri-auth uri-authority uri-scheme uri-path uri-query
    56          uri-fragment uri-host uri-port uri-username uri-password
    57          absolute-uri uri->string uri->list
    58          uri-relative-to uri-relative-from
    59          uri-decode-string uri-encode-string
    60          uri-normalize-case uri-normalize-path-segments))
     54 (export uri-reference update-uri update-authority
     55         uri? uri-auth uri-authority uri-scheme uri-path uri-query
     56         uri-fragment uri-host uri-port uri-username uri-password
     57         authority? authority-host authority-port
     58         authority-username authority-password
     59         
     60         absolute-uri uri->string uri->list
     61         uri-relative-to uri-relative-from
     62         uri-decode-string uri-encode-string
     63         uri-normalize-case uri-normalize-path-segments))
    6164
    6265(cond-expand
     
    104107  (let ((auth (URI-authority x)))
    105108    (and auth (URIAuth-password auth))))
     109
     110(define authority? URIAuth?)
     111(define authority-host URIAuth-host)
     112(define authority-port URIAuth-port)
     113(define authority-username URIAuth-username)
     114(define authority-password URIAuth-password)
     115
     116(define update-authority
     117  (let ((unset (list 'unset)))
     118    (lambda (auth #!key (host unset) (port unset) (username unset) (password unset))
     119      (make-URIAuth host: (if (eq? host unset) (URIAuth-host auth) host)
     120                    port: (if (eq? port unset) (URIAuth-port auth) port)
     121                    username: (if (eq? username unset) (URIAuth-username auth) username)
     122                    password: (if (eq? password unset) (URIAuth-password auth) password)))))
     123
     124(define update-uri
     125  (let ((unset (list 'unset)))
     126   (lambda (uri . key/values)
     127     (apply
     128      (lambda (#!key
     129               (scheme (URI-scheme uri)) (path (URI-path uri))
     130               (query (URI-query uri)) (fragment (URI-fragment uri))
     131               (auth unset) (authority unset))
     132        (let* ((base-auth (or
     133                           (cond
     134                            ((not (eq? unset auth)) auth)
     135                            ((not (eq? unset authority)) authority)
     136                            (else (URI-authority uri)))
     137                           (make-URIAuth)))
     138               (updated-auth (apply update-authority base-auth key/values))
     139               (final-auth (if (equal? (make-URIAuth) updated-auth)
     140                               #f
     141                               updated-auth)))
     142          (make-URI scheme: scheme path: path query: query fragment: fragment
     143                    authority: final-auth))) key/values))))
    106144
    107145;; Character classes
     
    253291                                               (else (list #f rst)))))
    254292                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    255                                   path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
     293                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->alist uq))
    256294                                  fragment: (and uf (uri-char-list->string uf)))))
    257295         (else #f))))
     
    262300                         ((up rst)  (path-abempty rst)))
    263301                        (list ua up rst)))
    264          (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list #f s))))
     302         (else (match-let (((up rst) (or (path-abs s) (path-rootless s) (list '() s))))
    265303                          (list #f up rst)))))
    266304
     
    587625(define query-part (many (schar ":@/?!$'()*+,;")))
    588626
    589 (define (query->string s)
     627;; Convert an internal parser representation of a query to an alist
     628;; of symbol-string pairs
     629(define (query->alist s)
    590630  (match (query-part s)
    591631         ((p1 (#\= . rst))  (match (query-part rst)
    592                                    ((p2 _) `(,(uri-char-list->string p1) . ,(uri-char-list->string p2)))
     632                                   ((p2 _) `(,(string->symbol (uri-char-list->string p1)) . ,(uri-char-list->string p2)))
    593633                                   (else #f)))
    594          ((p1 ())   `(,(uri-char-list->string p1)))
     634         ((p1 ())   `(,(string->symbol (uri-char-list->string p1)) . #t))
    595635         (else #f)))
    596636 
     
    630670                                         (else (list #f rst)))))
    631671                   (make-URI scheme: #f authority: ua path: (map uri-char-list->string up)
    632                              query: (and uq (filter-map query->string uq))
     672                             query: (and uq (filter-map query->alist uq))
    633673                             fragment: (and uf (uri-char-list->string uf))))))
    634674
     
    654694                                              (else (list #f rst)))))
    655695                        (make-URI scheme: (string->symbol (list->string us)) authority: ua
    656                                   path: (map uri-char-list->string up) query: (and uq (filter-map query->string uq))
     696                                  path: (map uri-char-list->string up) query: (and uq (filter-map query->alist uq))
    657697                                  fragment: #f)))
    658698           (error 'absolute-uri "no scheme found in URI string"))))
     
    674714                 "")
    675715             (string-concatenate path)
    676              (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) "&"))) "")
     716             (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) "&"))) "")
    677717             (if fragment (string-append  "#" fragment) "")))
    678718           (else #f))))
Note: See TracChangeset for help on using the changeset viewer.