1;;;============================================================================ 2 3;;; File: "url.scm" 4 5;;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved. 6 7;;;============================================================================ 8 9(##namespace ("url#")) 10 11(##include "~~lib/gambit#.scm") 12 13(##include "url#.scm") 14 15(declare 16 (standard-bindings) 17 (extended-bindings) 18 (block) 19 (fixnum) 20 (not safe) 21) 22 23;;;============================================================================ 24 25;; Encoding and decoding of x-www-form-urlencoded data. 26 27(define (url-encode str #!optional (start 0) (end (string-length str)) (space-to-plus? #f)) 28 29 (define chunk-length 1024) 30 31 (define (hex n) 32 (string-ref "0123456789ABCDEF" (bitwise-and n 15))) 33 34 (define (encode-chunk len i end) 35 (if (< i end) 36 (let ((c (string-ref str i))) 37 (if (or (and (char>=? c #\a) (char<=? c #\z)) 38 (and (char>=? c #\A) (char<=? c #\Z)) 39 (and (char>=? c #\0) (char<=? c #\9)) 40 (char=? c #\-) 41 (char=? c #\_) 42 (char=? c #\.) 43 (char=? c #\!) 44 (char=? c #\~) 45 (char=? c #\*) 46 (char=? c #\') 47 (char=? c #\() 48 (char=? c #\)) 49 (and (char=? c #\space) space-to-plus?)) 50 (let ((result (encode-chunk (+ len 1) (+ i 1) end))) 51 (string-set! 52 result 53 len 54 (if (and (char=? c #\space) space-to-plus?) #\+ c)) 55 result) 56 (let ((result (encode-chunk (+ len 3) (+ i 1) end))) 57 (let ((n (char->integer c))) 58 (string-set! result (+ len 0) #\%) 59 (string-set! result (+ len 1) (hex (arithmetic-shift n -4))) 60 (string-set! result (+ len 2) (hex n)) 61 result)))) 62 (make-string len))) 63 64 (let loop ((i start) (chunks '())) 65 (let ((span (min (- end i) chunk-length))) 66 (if (= span 0) 67 (##append-strings ;; apply string-append 68 (reverse chunks)) 69 (let* ((next-i (+ i span)) 70 (chunk (encode-chunk 0 i next-i))) 71 (loop next-i (cons chunk chunks))))))) 72 73(define (url-decode str #!optional (start 0) (end (string-length str)) (plus-to-space? #f)) 74 75 (define chunk-length 1024) 76 77 (define (hex? c) 78 (cond ((and (char>=? c #\0) (char<=? c #\9)) 79 (- (char->integer c) (char->integer #\0))) 80 ((and (char>=? c #\a) (char<=? c #\f)) 81 (+ 10 (- (char->integer c) (char->integer #\a)))) 82 ((and (char>=? c #\A) (char<=? c #\F)) 83 (+ 10 (- (char->integer c) (char->integer #\A)))) 84 (else 85 #f))) 86 87 (define (decode len i end) 88 (if (and (< i end) 89 (< len chunk-length)) 90 (let ((c (string-ref str i))) 91 (cond ((or (and (char>=? c #\a) (char<=? c #\z)) 92 (and (char>=? c #\A) (char<=? c #\Z)) 93 (and (char>=? c #\0) (char<=? c #\9)) 94 (char=? c #\-) 95 (char=? c #\_) 96 (char=? c #\.) 97 (char=? c #\!) 98 (char=? c #\~) 99 (char=? c #\*) 100 (char=? c #\') 101 (char=? c #\() 102 (char=? c #\)) 103 (and (char=? c #\+) plus-to-space?)) 104 (let ((result (decode (+ len 1) (+ i 1) end))) 105 (and result 106 (begin 107 (string-set! 108 (cdr result) 109 len 110 (if (and (char=? c #\+) plus-to-space?) #\space c)) 111 result)))) 112 ((char=? c #\%) 113 (if (< (+ i 2) end) 114 (let* ((a (hex? (string-ref str (+ i 1)))) 115 (b (hex? (string-ref str (+ i 2))))) 116 (and a 117 b 118 (let ((result (decode (+ len 1) (+ i 3) end))) 119 (and result 120 (begin 121 (string-set! (cdr result) 122 len 123 (integer->char 124 (+ (arithmetic-shift a 4) b))) 125 result))))) 126 #f)) 127 (else 128 #f))) 129 (cons i (make-string len)))) 130 131 (let loop ((i start) (chunks '())) 132 (if (< i end) 133 (let ((x (decode 0 i end))) 134 (and x 135 (loop (car x) (cons (cdr x) chunks)))) 136 (##append-strings ;; apply string-append 137 (reverse chunks))))) 138 139;;;============================================================================ 140