Changeset 12001 in project


Ignore:
Timestamp:
09/25/08 21:45:33 (12 years ago)
Author:
sjamaan
Message:

Merge changes in release 3

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

Legend:

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

  • release/4/uri-generic/trunk/uri-generic.scm

    r11882 r12001  
    44;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
    55;;
    6 ;; Copyright 2008 Ivan Raikov.
     6;; Copyright 2008 Ivan Raikov, Peter Bex.
    77;;
    88;;
     
    3939
    4040(module uri-generic
    41  (uri-reference
    42   uri? uri-auth uri-authority uri-scheme uri-path uri-query
    43   uri-fragment uri-host uri-port uri-username uri-password
    44   absolute-uri uri->string uri->list uri-char-list-escape
    45   uri-char-list->string uri-string->char-list
    46   uri-relative-to uri-relative-from
    47   uri-normalize-case uri-normalize-path-segments)
     41  (uri-reference
     42   uri? uri-auth uri-authority uri-scheme uri-path uri-query
     43   uri-fragment uri-host uri-port uri-username uri-password
     44   absolute-uri uri->string uri->list
     45   uri-relative-to uri-relative-from
     46   uri-decode-string uri-encode-string
     47   uri-normalize-case uri-normalize-path-segments)
    4848
    4949(import chicken scheme extras data-structures)
     
    109109(define (ipv-future-char? c)  (char-set-contains? char-set:ipv-future c))
    110110
    111 (define (pct-escaped? c)      (match c ((#\% h1 h2) #t) (else #f)))
     111(define (pct-encoded? c)      (match c ((#\% h1 h2) #t) (else #f)))
    112112
    113113
     
    116116(define (uchar extras)
    117117  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    118     (lambda (c) (or (pct-escaped? c) (unreserved-char? c)
     118    (lambda (c) (or (pct-encoded? c) (unreserved-char? c)
    119119                    (char-set-contains? char-set:sub-delims c)
    120120                    (char-set-contains? extras-set c) ))))
     
    123123(define (schar extras)
    124124  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    125     (lambda (c) (or (pct-escaped? c)  (unreserved-char? c)
     125    (lambda (c) (or (pct-encoded? c)  (unreserved-char? c)
    126126                    (char-set-contains? extras-set c) ))))
    127127                 
     
    197197;; Returns a 'pct-encoded' sequence of octets.
    198198;;
    199 (define (pct-escape lst)
     199(define (pct-encode lst)
    200200  (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
    201201  (reverse (fold (lambda (x ax)
     
    204204                     (cons `(#\% ,h1 ,h2)  ax)))
    205205                 (list) lst)))
     206
    206207 
    207208;; RFC3986, section 2.2
     
    222223(define char-set:unreserved
    223224  (char-set-union char-set:letter+digit (string->char-set "-_.~")))
     225
    224226
    225227
     
    234236
    235237(define (uri s)
    236   (let ((s (if (string? s) (uri-string->char-list s) s)))
     238  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    237239    (match (scheme s)
    238240           ((us rst)
     
    481483(define reg-name
    482484  (count-min-max 0 255 (lambda (c) (or (unreserved-char? c)
    483                                        (pct-escaped? c)
     485                                       (pct-encoded? c)
    484486                                       (char-set-contains? char-set:sub-delims c) ))))
    485487
     
    538540(define (path-abs s)
    539541  (match s
    540          ((#\/ . rst)  (match (path-rootless rst)
    541                               ((() rst)  (list  (list #\/)  rst))
    542                               ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
    543                               (else #f)))
     542         ((#\/)          (list (list (list #\/))  (list)))
     543         ((#\/ . rst)    (match (path-rootless rst)
     544                                ((() rst)  (list  (list (list #\/))  rst))
     545                                ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
     546                                (else #f)))
    544547         (else #f)))
    545548
     
    599602
    600603(define (uri-reference s)
    601   (let ((s (if (string? s) (uri-string->char-list s) s)))
     604  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    602605    (or (uri s) (relative-ref s))))
    603606
     
    621624                             query: (and uq (filter-map query->string uq))
    622625                             fragment: (and uf (uri-char-list->string uf))))))
     626
    623627(define (relative-part s)
    624628  (match s
     
    635639
    636640(define (absolute-uri s)
    637   (let ((s (if (string? s) (uri-string->char-list s) s)))
     641  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    638642    (match (scheme s)
    639643           ((us rst) 
     
    692696                         
    693697
    694 ;;  Escape sequence handling
    695 
    696 (define (uri-char-list-escape p enc str)
     698;;  Percent encoding and decoding
     699
     700(define (char-list-encode p enc str)
    697701  (reverse
    698702   (fold (lambda (c ax)
    699            (if (not (p c)) (let* ((os (enc c))  (cs (map pct-escape os)))
    700                              (append (reverse cs) ax))
     703           (if (p c) (let* ((os (enc c)) 
     704                            (cs (map pct-encode os)))
     705                       (append (concatenate (reverse cs)) ax))
    701706               (cons c ax)))
    702707         (list) str)))
     708
     709(define (integer->octets i)
     710  (let loop ((i i) (lst (list)))
     711    (if (zero? i) lst
     712        (loop (quotient i 256) (cons (modulo i 256) lst)))))
     713
     714
     715(define (uri-encode-string str)
     716  (let ((clst (uri-string->char-list str)))
     717    (uri-char-list->string
     718     (char-list-encode reserved-char? (compose integer->octets char->integer) clst))))
     719
     720
     721(define (octets->integer lst)
     722  (let loop ((i 0) (m 1) (lst (reverse lst)))
     723    (if (null? lst) i
     724        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
     725
     726(define (pct-decode c)
     727  (match c
     728         ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
     729         (else c)))
     730
     731(define (hex-digit-char->integer c)
     732  (case c
     733         ((#\1)  1)
     734         ((#\2)  2)
     735         ((#\3)  3)
     736         ((#\4)  4)
     737         ((#\5)  5)
     738         ((#\6)  6)
     739         ((#\7)  7)
     740         ((#\8)  8)
     741         ((#\9)  9)
     742         ((#\A)  10)
     743         ((#\B)  11)
     744         ((#\C)  12)
     745         ((#\D)  13)
     746         ((#\E)  14)
     747         ((#\F)  15)
     748         (else  (error 'hex-digit-char->integer "invalid hex char " c))))
     749
     750(define (octet-decode h1 h2)
     751  (+ (* 16 (hex-digit-char->integer h1)) (hex-digit-char->integer h2)))
     752
     753(define (uri-decode-string str)
     754  (let loop ((clst (uri-string->char-list str)) (p (list))  (nlst (list)))
     755    (if (null? clst)
     756        (uri-char-list->string (reverse nlst))
     757        (match (car clst)
     758               ((and c (? char?)) 
     759                (if (null? p) (loop (cdr clst) p (cons c nlst))
     760                    (let ((pc (integer->char (octets->integer (reverse p)))))
     761                      (loop (cdr clst) (list) (cons* c pc nlst)))))
     762               ((#\% h1 h2) 
     763                (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst))
     764               (else (error 'uri-decode-string "invalid URI string " str))))))
     765   
     766(define (uri-string->normalized-char-list str)
     767  (let ((clst (uri-string->char-list str)))
     768    (map (lambda (c) (if (pct-encoded? c)
     769                         (let ((e (pct-decode c)))
     770                           (if (unreserved-char? e) e c)) c))
     771         clst)))
     772                         
     773
    703774
    704775;; Convert a URI character list to a string
  • release/4/uri-generic/trunk/uri-generic.setup

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