Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
140 lines (119 sloc) 4.86 KB
;;;============================================================================
;;; File: "url.scm"
;;; Copyright (c) 2011 by Marc Feeley, All Rights Reserved.
;;;============================================================================
(##namespace ("url#"))
(##include "~~lib/gambit#.scm")
(##include "url#.scm")
(declare
(standard-bindings)
(extended-bindings)
(block)
(fixnum)
(not safe)
)
;;;============================================================================
;; Encoding and decoding of x-www-form-urlencoded data.
(define (url-encode str #!optional (start 0) (end (string-length str)) (space-to-plus? #f))
(define chunk-length 1024)
(define (hex n)
(string-ref "0123456789ABCDEF" (bitwise-and n 15)))
(define (encode-chunk len i end)
(if (< i end)
(let ((c (string-ref str i)))
(if (or (and (char>=? c #\a) (char<=? c #\z))
(and (char>=? c #\A) (char<=? c #\Z))
(and (char>=? c #\0) (char<=? c #\9))
(char=? c #\-)
(char=? c #\_)
(char=? c #\.)
(char=? c #\!)
(char=? c #\~)
(char=? c #\*)
(char=? c #\')
(char=? c #\()
(char=? c #\))
(and (char=? c #\space) space-to-plus?))
(let ((result (encode-chunk (+ len 1) (+ i 1) end)))
(string-set!
result
len
(if (and (char=? c #\space) space-to-plus?) #\+ c))
result)
(let ((result (encode-chunk (+ len 3) (+ i 1) end)))
(let ((n (char->integer c)))
(string-set! result (+ len 0) #\%)
(string-set! result (+ len 1) (hex (arithmetic-shift n -4)))
(string-set! result (+ len 2) (hex n))
result))))
(make-string len)))
(let loop ((i start) (chunks '()))
(let ((span (min (- end i) chunk-length)))
(if (= span 0)
(##append-strings ;; apply string-append
(reverse chunks))
(let* ((next-i (+ i span))
(chunk (encode-chunk 0 i next-i)))
(loop next-i (cons chunk chunks)))))))
(define (url-decode str #!optional (start 0) (end (string-length str)) (plus-to-space? #f))
(define chunk-length 1024)
(define (hex? c)
(cond ((and (char>=? c #\0) (char<=? c #\9))
(- (char->integer c) (char->integer #\0)))
((and (char>=? c #\a) (char<=? c #\f))
(+ 10 (- (char->integer c) (char->integer #\a))))
((and (char>=? c #\A) (char<=? c #\F))
(+ 10 (- (char->integer c) (char->integer #\A))))
(else
#f)))
(define (decode len i end)
(if (and (< i end)
(< len chunk-length))
(let ((c (string-ref str i)))
(cond ((or (and (char>=? c #\a) (char<=? c #\z))
(and (char>=? c #\A) (char<=? c #\Z))
(and (char>=? c #\0) (char<=? c #\9))
(char=? c #\-)
(char=? c #\_)
(char=? c #\.)
(char=? c #\!)
(char=? c #\~)
(char=? c #\*)
(char=? c #\')
(char=? c #\()
(char=? c #\))
(and (char=? c #\+) plus-to-space?))
(let ((result (decode (+ len 1) (+ i 1) end)))
(and result
(begin
(string-set!
(cdr result)
len
(if (and (char=? c #\+) plus-to-space?) #\space c))
result))))
((char=? c #\%)
(if (< (+ i 2) end)
(let* ((a (hex? (string-ref str (+ i 1))))
(b (hex? (string-ref str (+ i 2)))))
(and a
b
(let ((result (decode (+ len 1) (+ i 3) end)))
(and result
(begin
(string-set! (cdr result)
len
(integer->char
(+ (arithmetic-shift a 4) b)))
result)))))
#f))
(else
#f)))
(cons i (make-string len))))
(let loop ((i start) (chunks '()))
(if (< i end)
(let ((x (decode 0 i end)))
(and x
(loop (car x) (cons (cdr x) chunks))))
(##append-strings ;; apply string-append
(reverse chunks)))))
;;;============================================================================
Something went wrong with that request. Please try again.