Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
106 lines (101 sloc) 4.19 KB
; uri.ss
;
; Copyright (c) 2010 Higepon(Taro Minowa) <higepon@users.sourceforge.jp>
;
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;
; 2. Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;
(library (uri)
(export uri-encode uri-decode)
(import (rnrs))
;; This library is undocumented. APIs is subject to change without notice.
;; http://tips.lisp-users.org/scheme/
(define uri-unreserved-char-sv?
(let ((unreserved-char-svs (map char->integer
(string->list
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-._‾"))))
(lambda (sv)
(and (memv sv unreserved-char-svs) #t))))
(define (uri-encode str)
(let ((svs (bytevector->u8-list (string->utf8 str))))
(call-with-string-output-port
(lambda (p)
(for-each
(lambda (sv)
(cond ((uri-unreserved-char-sv? sv)
(display (integer->char sv) (current-error-port))
(newline (current-error-port))
(display (integer->char sv) p))
(else
(display "%" p)
(when (< sv 16)
(display "0" p))
(display (number->string sv 16) p))))
svs)))))
(define (uri-decode str)
(define digit->integer
(lambda (c)
(cond
((char<=? #\0 c #\9) (- (char->integer c) (char->integer #\0)))
((char<=? #\a c #\f) (+ 10 (- (char->integer c) (char->integer #\a))))
((char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A))))
(else #f))))
(define percent-filter
(lambda (in out err)
(let loop ((c (peek-char in)))
(and (not (eof-object? c)) (char=? c #\%)
(let* ((cp (get-char in)) (c1 (get-char in)) (c2 (get-char in)))
(cond
((eof-object? c1) (put-char err cp))
((eof-object? c2) (put-char err cp) (put-char err c1))
(else
(let ((i1 (digit->integer c1)) (i2 (digit->integer c2)))
(cond
((and i1 i2)
(put-u8 out (+ (* 16 (digit->integer c1)) (digit->integer c2)))
(loop (peek-char in)))
(else
(put-char err cp)
(put-char err c1)
(put-char err c2)))))))))))
(define filter
(lambda (in out)
(let loop ((c (peek-char in)))
(when (not (eof-object? c))
(if (char=? c #\%)
(put-string out
(bytevector->string
(call-with-bytevector-output-port
(lambda (op) (percent-filter in op out)))
(make-transcoder (utf-8-codec))))
(let ((c (get-char in)))
(cond
((char=? c #\+) (put-char out #\space))
(else (put-char out c)))))
(loop (peek-char in))))))
(call-with-port (open-string-input-port str)
(lambda (in)
(call-with-string-output-port
(lambda (out) (filter in out))))))
)
Something went wrong with that request. Please try again.