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