Changeset 11993 in project
- Timestamp:
- 09/25/08 02:30:13 (12 years ago)
- Location:
- release/3/uri-generic/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/uri-generic/trunk/uri-generic.scm
r11869 r11993 5 5 ;; Based on the Haskell URI library by Graham Klyne <gk@ninebynine.org>. 6 6 ;; 7 ;; Copyright 2008 Ivan Raikov .7 ;; Copyright 2008 Ivan Raikov, Peter Bex. 8 8 ;; 9 9 ;; … … 55 55 uri? uri-auth uri-authority uri-scheme uri-path uri-query 56 56 uri-fragment uri-host uri-port uri-username uri-password 57 absolute-uri uri->string uri->list uri-char-list-escape 58 uri-char-list->string uri-string->char-list 57 absolute-uri uri->string uri->list 59 58 uri-relative-to uri-relative-from 59 uri-decode-string uri-encode-string 60 60 uri-normalize-case uri-normalize-path-segments)) 61 61 … … 117 117 (define (ipv-future-char? c) (char-set-contains? char-set:ipv-future c)) 118 118 119 (define (pct-e scaped? c) (match c ((#\% h1 h2) #t) (else #f)))119 (define (pct-encoded? c) (match c ((#\% h1 h2) #t) (else #f))) 120 120 121 121 … … 124 124 (define (uchar extras) 125 125 (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras)))) 126 (lambda (c) (or (pct-e scaped? c) (unreserved-char? c)126 (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 127 127 (char-set-contains? char-set:sub-delims c) 128 128 (char-set-contains? extras-set c) )))) … … 131 131 (define (schar extras) 132 132 (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras)))) 133 (lambda (c) (or (pct-e scaped? c) (unreserved-char? c)133 (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 134 134 (char-set-contains? extras-set c) )))) 135 135 … … 205 205 ;; Returns a 'pct-encoded' sequence of octets. 206 206 ;; 207 (define (pct-e scape lst)207 (define (pct-encode lst) 208 208 (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i))))) 209 209 (reverse (fold (lambda (x ax) … … 212 212 (cons `(#\% ,h1 ,h2) ax))) 213 213 (list) lst))) 214 214 215 215 216 ;; RFC3986, section 2.2 … … 230 231 (define char-set:unreserved 231 232 (char-set-union char-set:letter+digit (string->char-set "-_.~"))) 233 232 234 233 235 … … 242 244 243 245 (define (uri s) 244 (let ((s (if (string? s) (uri-string-> char-list s) s)))246 (let ((s (if (string? s) (uri-string->normalized-char-list s) s))) 245 247 (match (scheme s) 246 248 ((us rst) … … 489 491 (define reg-name 490 492 (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 491 (pct-e scaped? c)493 (pct-encoded? c) 492 494 (char-set-contains? char-set:sub-delims c) )))) 493 495 … … 546 548 (define (path-abs s) 547 549 (match s 548 ((#\/ . rst) (match (path-rootless rst) 549 ((() rst) (list (list #\/) rst)) 550 ((lst rst) (list (cons (cons #\/ (car lst)) (cdr lst)) rst)) 551 (else #f))) 550 ((#\/) (list (list (list #\/)) (list))) 551 ((#\/ . rst) (match (path-rootless rst) 552 ((() rst) (list (list (list #\/)) rst)) 553 ((lst rst) (list (cons (cons #\/ (car lst)) (cdr lst)) rst)) 554 (else #f))) 552 555 (else #f))) 553 556 … … 607 610 608 611 (define (uri-reference s) 609 (let ((s (if (string? s) (uri-string-> char-list s) s)))612 (let ((s (if (string? s) (uri-string->normalized-char-list s) s))) 610 613 (or (uri s) (relative-ref s)))) 611 614 … … 629 632 query: (and uq (filter-map query->string uq)) 630 633 fragment: (and uf (uri-char-list->string uf)))))) 634 631 635 (define (relative-part s) 632 636 (match s … … 643 647 644 648 (define (absolute-uri s) 645 (let ((s (if (string? s) (uri-string-> char-list s) s)))649 (let ((s (if (string? s) (uri-string->normalized-char-list s) s))) 646 650 (match (scheme s) 647 651 ((us rst) … … 700 704 701 705 702 ;; Escape sequence handling703 704 (define ( uri-char-list-escape p enc str)706 ;; Percent encoding and decoding 707 708 (define (char-list-encode p enc str) 705 709 (reverse 706 710 (fold (lambda (c ax) 707 (if (not (p c)) (let* ((os (enc c)) (cs (map pct-escape os))) 708 (append (reverse cs) ax)) 711 (if (p c) (let* ((os (enc c)) 712 (cs (map pct-encode os))) 713 (append (concatenate (reverse cs)) ax)) 709 714 (cons c ax))) 710 715 (list) str))) 716 717 (define (integer->octets i) 718 (let loop ((i i) (lst (list))) 719 (if (zero? i) lst 720 (loop (quotient i 256) (cons (modulo i 256) lst))))) 721 722 723 (define (uri-encode-string str) 724 (let ((clst (uri-string->char-list str))) 725 (uri-char-list->string 726 (char-list-encode reserved-char? (compose integer->octets char->integer) clst)))) 727 728 729 (define (octets->integer lst) 730 (let loop ((i 0) (m 1) (lst (reverse lst))) 731 (if (null? lst) i 732 (loop (+ i (* (car lst) m)) (* m 256) (cdr lst))))) 733 734 (define (pct-decode c) 735 (match c 736 ((#\% h1 h2) (integer->char (octet-decode h1 h2))) 737 (else c))) 738 739 (define (hex-digit-char->integer c) 740 (case c 741 ((#\1) 1) 742 ((#\2) 2) 743 ((#\3) 3) 744 ((#\4) 4) 745 ((#\5) 5) 746 ((#\6) 6) 747 ((#\7) 7) 748 ((#\8) 8) 749 ((#\9) 9) 750 ((#\A) 10) 751 ((#\B) 11) 752 ((#\C) 12) 753 ((#\D) 13) 754 ((#\E) 14) 755 ((#\F) 15) 756 (else (error 'hex-digit-char->integer "invalid hex char " c)))) 757 758 (define (octet-decode h1 h2) 759 (+ (* 16 (hex-digit-char->integer h1)) (hex-digit-char->integer h2))) 760 761 (define (uri-decode-string str) 762 (let loop ((clst (uri-string->char-list str)) (p (list)) (nlst (list))) 763 (if (null? clst) 764 (uri-char-list->string (reverse nlst)) 765 (match (car clst) 766 ((and c (? char?)) 767 (if (null? p) (loop (cdr clst) p (cons c nlst)) 768 (let ((pc (integer->char (octets->integer (reverse p))))) 769 (loop (cdr clst) (list) (cons* c pc nlst))))) 770 ((#\% h1 h2) 771 (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst)) 772 (else (error 'uri-decode-string "invalid URI string " str)))))) 773 774 (define (uri-string->normalized-char-list str) 775 (let ((clst (uri-string->char-list str))) 776 (map (lambda (c) (if (pct-encoded? c) 777 (let ((e (pct-decode c))) 778 (if (unreserved-char? e) e c)) c)) 779 clst))) 780 781 711 782 712 783 ;; Convert a URI character list to a string -
release/3/uri-generic/trunk/uri-generic.setup
r11885 r11993 21 21 22 22 ;; Assoc list with properties for your extension: 23 '((version 1. 7)23 '((version 1.8) 24 24 (documentation "uri-generic.html") 25 25 ,@(if has-exports? `((exports "uri-generic.exports")) (list)) ))
Note: See TracChangeset
for help on using the changeset viewer.