Changeset 12001 in project
- Timestamp:
- 09/25/08 21:45:33 (12 years ago)
- Location:
- release/4/uri-generic/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/uri-generic/trunk
- Property svn:mergeinfo changed
/release/3/uri-generic/trunk merged: 11993
- Property svn:mergeinfo changed
-
release/4/uri-generic/trunk/uri-generic.scm
r11882 r12001 4 4 ;; Based on the Haskell URI library by Graham Klyne <gk@ninebynine.org>. 5 5 ;; 6 ;; Copyright 2008 Ivan Raikov .6 ;; Copyright 2008 Ivan Raikov, Peter Bex. 7 7 ;; 8 8 ;; … … 39 39 40 40 (module uri-generic 41 (uri-reference42 uri? uri-auth uri-authority uri-scheme uri-path uri-query43 uri-fragment uri-host uri-port uri-username uri-password44 absolute-uri uri->string uri->list uri-char-list-escape45 uri-char-list->string uri-string->char-list46 uri-relative-to uri-relative-from47 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) 48 48 49 49 (import chicken scheme extras data-structures) … … 109 109 (define (ipv-future-char? c) (char-set-contains? char-set:ipv-future c)) 110 110 111 (define (pct-e scaped? c) (match c ((#\% h1 h2) #t) (else #f)))111 (define (pct-encoded? c) (match c ((#\% h1 h2) #t) (else #f))) 112 112 113 113 … … 116 116 (define (uchar extras) 117 117 (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras)))) 118 (lambda (c) (or (pct-e scaped? c) (unreserved-char? c)118 (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 119 119 (char-set-contains? char-set:sub-delims c) 120 120 (char-set-contains? extras-set c) )))) … … 123 123 (define (schar extras) 124 124 (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras)))) 125 (lambda (c) (or (pct-e scaped? c) (unreserved-char? c)125 (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 126 126 (char-set-contains? extras-set c) )))) 127 127 … … 197 197 ;; Returns a 'pct-encoded' sequence of octets. 198 198 ;; 199 (define (pct-e scape lst)199 (define (pct-encode lst) 200 200 (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i))))) 201 201 (reverse (fold (lambda (x ax) … … 204 204 (cons `(#\% ,h1 ,h2) ax))) 205 205 (list) lst))) 206 206 207 207 208 ;; RFC3986, section 2.2 … … 222 223 (define char-set:unreserved 223 224 (char-set-union char-set:letter+digit (string->char-set "-_.~"))) 225 224 226 225 227 … … 234 236 235 237 (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))) 237 239 (match (scheme s) 238 240 ((us rst) … … 481 483 (define reg-name 482 484 (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 483 (pct-e scaped? c)485 (pct-encoded? c) 484 486 (char-set-contains? char-set:sub-delims c) )))) 485 487 … … 538 540 (define (path-abs s) 539 541 (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))) 544 547 (else #f))) 545 548 … … 599 602 600 603 (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))) 602 605 (or (uri s) (relative-ref s)))) 603 606 … … 621 624 query: (and uq (filter-map query->string uq)) 622 625 fragment: (and uf (uri-char-list->string uf)))))) 626 623 627 (define (relative-part s) 624 628 (match s … … 635 639 636 640 (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))) 638 642 (match (scheme s) 639 643 ((us rst) … … 692 696 693 697 694 ;; Escape sequence handling695 696 (define ( uri-char-list-escape p enc str)698 ;; Percent encoding and decoding 699 700 (define (char-list-encode p enc str) 697 701 (reverse 698 702 (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)) 701 706 (cons c ax))) 702 707 (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 703 774 704 775 ;; Convert a URI character list to a string -
release/4/uri-generic/trunk/uri-generic.setup
r11823 r12001 13 13 14 14 ;; Assoc list with properties for your extension: 15 '((version 1. 5)15 '((version 1.8) 16 16 (documentation "uri-generic.html")))
Note: See TracChangeset
for help on using the changeset viewer.