1; uri.ss 2; 3; Copyright (c) 2010 Higepon(Taro Minowa) <higepon@users.sourceforge.jp> 4; 5; 6; Redistribution and use in source and binary forms, with or without 7; modification, are permitted provided that the following conditions 8; are met: 9; 10; 1. Redistributions of source code must retain the above copyright 11; notice, this list of conditions and the following disclaimer. 12; 13; 2. Redistributions in binary form must reproduce the above copyright 14; notice, this list of conditions and the following disclaimer in the 15; documentation and/or other materials provided with the distribution. 16; 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 21; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 22; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 23; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 24; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 25; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 26; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28; 29(library (uri) 30 (export uri-encode uri-decode) 31 (import (rnrs)) 32 33;; This library is undocumented. APIs is subject to change without notice. 34 35;; http://tips.lisp-users.org/scheme/ 36(define uri-unreserved-char-sv? 37 (let ((unreserved-char-svs (map char->integer 38 (string->list 39 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-._‾")))) 40 (lambda (sv) 41 (and (memv sv unreserved-char-svs) #t)))) 42 43(define (uri-encode str) 44 (let ((svs (bytevector->u8-list (string->utf8 str)))) 45 (call-with-string-output-port 46 (lambda (p) 47 (for-each 48 (lambda (sv) 49 (cond ((uri-unreserved-char-sv? sv) 50 (display (integer->char sv) (current-error-port)) 51 (newline (current-error-port)) 52 (display (integer->char sv) p)) 53 (else 54 (display "%" p) 55 (when (< sv 16) 56 (display "0" p)) 57 (display (number->string sv 16) p)))) 58 svs))))) 59 60(define (uri-decode str) 61 (define digit->integer 62 (lambda (c) 63 (cond 64 ((char<=? #\0 c #\9) (- (char->integer c) (char->integer #\0))) 65 ((char<=? #\a c #\f) (+ 10 (- (char->integer c) (char->integer #\a)))) 66 ((char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A)))) 67 (else #f)))) 68 (define percent-filter 69 (lambda (in out err) 70 (let loop ((c (peek-char in))) 71 (and (not (eof-object? c)) (char=? c #\%) 72 (let* ((cp (get-char in)) (c1 (get-char in)) (c2 (get-char in))) 73 (cond 74 ((eof-object? c1) (put-char err cp)) 75 ((eof-object? c2) (put-char err cp) (put-char err c1)) 76 (else 77 (let ((i1 (digit->integer c1)) (i2 (digit->integer c2))) 78 (cond 79 ((and i1 i2) 80 (put-u8 out (+ (* 16 (digit->integer c1)) (digit->integer c2))) 81 (loop (peek-char in))) 82 (else 83 (put-char err cp) 84 (put-char err c1) 85 (put-char err c2))))))))))) 86 (define filter 87 (lambda (in out) 88 (let loop ((c (peek-char in))) 89 (when (not (eof-object? c)) 90 (if (char=? c #\%) 91 (put-string out 92 (bytevector->string 93 (call-with-bytevector-output-port 94 (lambda (op) (percent-filter in op out))) 95 (make-transcoder (utf-8-codec)))) 96 (let ((c (get-char in))) 97 (cond 98 ((char=? c #\+) (put-char out #\space)) 99 (else (put-char out c))))) 100 (loop (peek-char in)))))) 101 (call-with-port (open-string-input-port str) 102 (lambda (in) 103 (call-with-string-output-port 104 (lambda (out) (filter in out)))))) 105) 106