Changeset 14596 in project


Ignore:
Timestamp:
05/12/09 06:03:39 (10 years ago)
Author:
Ivan Raikov
Message:

improvements to uri->string

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

Legend:

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

    r13445 r14596  
    5555   char-set:uri-reserved char-set:uri-unreserved)
    5656
    57 (import chicken scheme extras data-structures)
     57(import chicken scheme extras data-structures ports)
    5858 
    5959(require-extension matchable defstruct srfi-1 srfi-4 srfi-13 srfi-14)
     
    732732;;
    733733
     734
     735
    734736(define (uri->string uri . rest)
    735737   (let-optionals rest ((userinfomap (lambda (u pw) (string-append u ":******" ))))
    736738    (match uri
    737739           (($ URI scheme authority path query fragment)
    738             (string-append
    739              ((lambda (x) (or (and x (string-append (->string x) ":")) ""))  scheme)
    740              (if authority
    741                  (string-append (uri-auth->string authority userinfomap))
    742                  "")
    743              (path->string path)
    744              (if query (string-append "?" query) "")
    745              (if fragment (string-append  "#" fragment) "")))
     740            (with-output-to-string
     741              (lambda ()
     742                (display-fragments
     743                 `(,(and scheme (list scheme ":"))
     744                   ,(match authority
     745                           (($ URIAuth username password (and host (? string?)) port)
     746                            (list "//" (and username (list (userinfomap username password) "@"))
     747                                  host (and port (list ":" port))))
     748                           (else #f))
     749                   ,(path->string path)
     750                   ,(and query (list "?" query))
     751                   ,(and fragment (list  "#" fragment)))))))
    746752           (else #f))))
    747753
    748 (define (uri-auth->string uri-auth userinfomap)
    749   (match uri-auth
    750          (($ URIAuth username password host port)
    751           (string-append "//" (if username
    752                                   ((lambda (x) (or (and x (string-append x "@")) ""))
    753                                    (userinfomap username password)) "")
    754                          host ((lambda (x) (or (and x (string-append ":" (->string x))) ""))
    755                                port)))
    756          (else #f)))
     754(define (display-fragments b)
     755  (let loop ((fragments b))
     756    (cond
     757      ((null? fragments) (begin))
     758      ((not (car fragments))
     759       (loop (cdr fragments) ))
     760      ((null? (car fragments))
     761       (loop (cdr fragments) ))
     762      ((pair? (car fragments))
     763       (begin (loop (car fragments))
     764              (loop (cdr fragments) )))
     765      (else
     766       (display (car fragments))
     767       (loop (cdr fragments) )))))
     768
    757769                         
    758770(define (path->string path)
     
    10241036
    10251037(define (uri-normalize-case uri)
    1026   (let* ((normalized-uri (uri-reference (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
     1038  (let* ((normalized-uri (uri-reference
     1039                          (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
    10271040         (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
    10281041         (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
  • release/4/uri-generic/trunk/uri-generic.setup

    r13247 r14596  
    1313
    1414  ;; Assoc list with properties for your extension:
    15   '((version 2.1)
     15  '((version 2.2)
    1616    (documentation "uri-generic.html")))
Note: See TracChangeset for help on using the changeset viewer.