Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-12 23:47:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Updating (chibi uri) to use new string-find return values, which

Browse source 
were changed to offsets rather than potentially #f.
Also consistently using string-cursor API rather than indexes.
Fixes issue #189.
This commit is contained in:
Alex Shinn 2013-07-21 14:01:36 +09:00
parent 16696d01b1
commit b6e2829b5d
3 changed files with 135 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

137
lib/chibi/uri.scm
View file

@ -33,7 +33,7 @@
(o (if (pair? o) (cdr o) '())) (o (if (pair? o) (cdr o) '()))
(query (if (pair? o) (car o) #f)) (query (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '())) (o (if (pair? o) (cdr o) '()))
(fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f))) (fragment (and (pair? o) (car o))))
(%make-uri scheme user host port path query fragment))) (%make-uri scheme user host port path query fragment)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -86,64 +86,82 @@
(define decode (if decode? uri-decode (lambda (x) x))) (define decode (if decode? uri-decode (lambda (x) x)))
(define decode-query (define decode-query
(if (and (pair? o) (pair? (cdr o)) (cadr o)) (if (and (pair? o) (pair? (cdr o)) (cadr o))
uri-query->alist (if decode? (lambda (q) (uri-query->alist q #t)) uri-query->alist)
decode)) decode))
(if (uri? str) (if (uri? str)
str str
(let* ((len (string-length str)) (let* ((start (string-cursor-start str))
(end (string-cursor-end str))
(colon0 (string-find str #\:)) (colon0 (string-find str #\:))
(colon (colon
(and (not (string-find str char-uri-scheme-unsafe? (and (string-cursor>=?
0 (or colon0 len))) (string-find str char-uri-scheme-unsafe? start colon0)
colon0)
(string-cursor<? colon0 end)
colon0))) colon0)))
(if (or (not colon) (zero? colon)) (if (string-cursor>=? colon end)
(and scheme (and scheme
(let* ((quest (string-find str #\? 0)) (let* ((quest (string-find str #\?))
(pound (string-find str #\# (or quest 0)))) (pound
(string-find
str
#\#
(if (string-cursor<? quest end) quest start))))
(make-uri scheme #f #f #f (make-uri scheme #f #f #f
(decode (substring str 0 (or quest pound len))) (decode
(and quest (substring-cursor
str start (if (< quest end) quest pound)))
(and (< quest end)
(decode-query (decode-query
(substring str (+ quest 1) (or pound len)))) (substring-cursor str (+ quest 1) pound)))
(and pound (and (< pound end)
(decode (substring str (+ pound 1) len)))))) (decode
(substring-cursor str (+ pound 1) end))))))
(let ((sc1 (+ colon 1)) (let ((sc1 (+ colon 1))
(scheme (string->symbol (scheme (string->symbol
(string-downcase-ascii (substring str 0 colon))))) (string-downcase-ascii
(if (= sc1 len) (substring-cursor str start colon)))))
(if (string-cursor>=? sc1 end)
(make-uri scheme) (make-uri scheme)
(if (or (>= (+ sc1 1) len) (if (or (string-cursor>=? (+ sc1 1) end)
(not (and (eqv? #\/ (string-ref str sc1)) (not
(eqv? #\/ (string-ref str (+ sc1 1)))))) (and (eqv? #\/ (string-cursor-ref str sc1))
(make-uri scheme #f #f #f (substring str sc1 len)) (eqv? #\/ (string-cursor-ref str (+ sc1 1))))))
(if (>= (+ sc1 2) len) (make-uri scheme #f #f #f (substring-cursor str sc1 end))
(if (string-cursor>=? (+ sc1 2) end)
(make-uri scheme #f "") (make-uri scheme #f "")
(let* ((sc2 (+ sc1 2)) (let* ((sc2 (+ sc1 2))
(slash (string-find str #\/ sc2)) (slash (string-find str #\/ sc2))
(sc3 (or slash len)) (at (string-find-right str #\@ sc2 slash))
(at (string-find-right str #\@ sc2 sc3)) (colon3
(colon3 (string-find str #\: (or at sc2) sc3)) (string-find
(quest (string-find str #\? sc3)) str #\: (if (> at sc2) at sc2) slash))
(pound (string-find str #\# (or quest sc3)))) (quest (string-find str #\? slash))
(pound
(string-find
str #\# (if (< quest end) quest slash))))
(%make-uri (%make-uri
scheme scheme
(and at (decode (substring str sc2 at))) (and (> at sc2)
(decode (substring-cursor str sc2 at)))
(decode (decode
(substring str (substring-cursor
(if at (+ at 1) sc2) str
(or colon3 sc3))) (if (> at sc2) (+ at 1) sc2)
(and colon3 (if (< colon3 slash) colon3 slash)))
(and (< colon3 slash)
(string->number (string->number
(substring str (+ colon3 1) sc3))) (substring-cursor str (+ colon3 1) slash)))
(and slash (and (< slash end)
(decode (decode
(substring str slash (or quest pound len)))) (substring-cursor
(and quest str slash (if (< quest end) quest pound))))
(and (< quest end)
(decode-query (decode-query
(substring str (+ quest 1) (substring-cursor str (+ quest 1) pound)))
(or pound len)))) (and (< pound end)
(and pound (decode
(decode (substring str (+ pound 1) len))) (substring-cursor str (+ pound 1) end)))
)))))))))) ))))))))))
;;> Parses a string and returns a new URI object. If the string does ;;> Parses a string and returns a new URI object. If the string does
@ -189,7 +207,7 @@
(define (collect str from to res) (define (collect str from to res)
(if (>= from to) (if (>= from to)
res res
(cons (substring str from to) res))) (cons (substring-cursor str from to) res)))
;;> \subsubsubsection{\scheme{(uri-encode str [plus?])}} ;;> \subsubsubsection{\scheme{(uri-encode str [plus?])}}
@ -209,17 +227,17 @@
(string-append "%0" hex) (string-append "%0" hex)
(string-append "%" hex)))) (string-append "%" hex))))
(let ((start 0) (let ((start 0)
(end (string-length str)) (end (string-cursor-end str))
(encode-1 (if (and (pair? o) (car o)) (encode-1 (if (and (pair? o) (car o))
encode-1-space encode-1-space
encode-1-normal))) encode-1-normal)))
(let lp ((from start) (to start) (res '())) (let lp ((from start) (to start) (res '()))
(if (>= to end) (if (string-cursor>=? to end)
(if (zero? from) (if (zero? from)
str str
(string-concatenate (reverse (collect str from to res)))) (string-concatenate (reverse (collect str from to res))))
(let* ((ch (string-ref str to)) (let* ((ch (string-cursor-ref str to))
(next (+ to 1))) (next (string-cursor-next str to)))
(if (uri-safe-char? ch) (if (uri-safe-char? ch)
(lp from next res) (lp from next res)
(lp next next (cons (encode-1 ch) (lp next next (cons (encode-1 ch)
@ -233,24 +251,24 @@
(define (uri-decode str . o) (define (uri-decode str . o)
(let ((space-as-plus? (and (pair? o) (car o))) (let ((space-as-plus? (and (pair? o) (car o)))
(start 0) (start (string-cursor-start str))
(end (string-length str))) (end (string-cursor-end str)))
(let lp ((from start) (to start) (res '())) (let lp ((from start) (to start) (res '()))
(if (>= to end) (if (string-cursor>=? to end)
(if (zero? from) (if (zero? from)
str str
(string-concatenate (reverse (collect str from to res)))) (string-concatenate (reverse (collect str from to res))))
(let* ((ch (string-ref str to)) (let* ((ch (string-cursor-ref str to))
(next (+ to 1))) (next (string-cursor-next str to)))
(cond (cond
((eqv? ch #\%) ((eqv? ch #\%)
(if (>= next end) (if (string-cursor>=? next end)
(lp next next (collect str from to res)) (lp next next (collect str from to res))
(let ((next2 (+ next 1))) (let ((next2 (string-cursor-next str next)))
(if (>= next2 end) (if (string-cursor>=? next2 end)
(lp next2 next2 (collect str from to res)) (lp next2 next2 (collect str from to res))
(let* ((next3 (+ next2 1)) (let* ((next3 (+ next2 1))
(hex (substring str next next3)) (hex (substring-cursor str next next3))
(i (string->number hex 16))) (i (string->number hex 16)))
(lp next3 next3 (cons (string (integer->char i)) (lp next3 next3 (cons (string (integer->char i))
(collect str from to res)))))))) (collect str from to res))))))))
@ -267,17 +285,18 @@
(define (uri-query->alist str . o) (define (uri-query->alist str . o)
(define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;))) (define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;)))
(let ((len (string-length str)) (let ((end (string-cursor-end str))
(plus? (and (pair? o) (car o)))) (plus? (and (pair? o) (car o))))
(let lp ((i 0) (res '())) (let lp ((i 0) (res '()))
(if (>= i len) (if (string-cursor>=? i end)
(reverse res) (reverse res)
(let* ((j (or (string-find str split-char? i) len)) (let* ((j (string-find str split-char? i))
(k (string-find str #\= i j)) (k (string-find str #\= i j))
(cell (if k (cell
(cons (uri-decode (substring str i k) plus?) (if (< k end)
(uri-decode (substring str (+ k 1) j) plus?)) (cons (uri-decode (substring-cursor str i k) plus?)
(cons (uri-decode (substring str i j) plus?) #f)))) (uri-decode (substring-cursor str (+ k 1) j) plus?))
(cons (uri-decode (substring-cursor str i j) plus?) #f))))
(lp (+ j 1) (cons cell res))))))) (lp (+ j 1) (cons cell res)))))))
;;> \subsubsubsection{\scheme{(uri-alist->query ls [plus?])}} ;;> \subsubsubsection{\scheme{(uri-alist->query ls [plus?])}}

1
tests/lib-tests.scm
View file

@ -17,6 +17,7 @@
(load "tests/scribble-tests.scm") (load "tests/scribble-tests.scm")
(load "tests/string-tests.scm") (load "tests/string-tests.scm")
(load "tests/iset-tests.scm") (load "tests/iset-tests.scm")
(load "tests/uri-tests.scm")
(cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f)) (cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f))
(cond-expand (cond-expand

56
tests/uri-tests.scm Normal file
View file

@ -0,0 +1,56 @@
(import (chibi) (chibi test) (chibi uri))
(test-begin "uri")
(test-assert (uri? (make-uri 'http)))
(test 'http (uri-scheme (make-uri 'http)))
(test "r" (uri-user (make-uri 'http "r")))
(test "google.com" (uri-host (make-uri 'http "r" "google.com")))
(test 80 (uri-port (make-uri 'http "r" "google.com" 80)))
(test "/search" (uri-path (make-uri 'http "r" "google.com" 80 "/search")))
(test "q=cats"
(uri-query (make-uri 'http "r" "google.com" 80 "/search" "q=cats")))
(test "recent"
(uri-fragment
(make-uri 'http "r" "google.com" 80 "/search" "q=cats" "recent")))
(let ((str "http://google.com"))
(test-assert (uri? (string->uri str)))
(test 'http (uri-scheme (string->uri str)))
(test "google.com" (uri-host (string->uri str)))
(test #f (uri-port (string->uri str)))
(test #f (uri-path (string->uri str)))
(test #f (uri-query (string->uri str)))
(test #f (uri-fragment (string->uri str))))
(let ((str "http://google.com/"))
(test-assert (uri? (string->uri str)))
(test 'http (uri-scheme (string->uri str)))
(test "google.com" (uri-host (string->uri str)))
(test #f (uri-port (string->uri str)))
(test "/" (uri-path (string->uri str)))
(test #f (uri-query (string->uri str)))
(test #f (uri-fragment (string->uri str))))
(let ((str "http://google.com:80/search?q=cats#recent"))
(test-assert (uri? (string->uri str)))
(test 'http (uri-scheme (string->uri str)))
(test "google.com" (uri-host (string->uri str)))
(test 80 (uri-port (string->uri str)))
(test "/search" (uri-path (string->uri str)))
(test "q=cats" (uri-query (string->uri str)))
(test "recent" (uri-fragment (string->uri str))))
(test "/%73" (uri-path (string->uri "http://google.com/%73")))
(test "/s" (uri-path (string->uri "http://google.com/%73" #t)))
(test "a=1&b=2;c=3"
(uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t)))
(test '(("a" . "1") ("b" . "2") ("c" . "3"))
(uri-query (string->uri "http://google.com/%73?a=1&b=2;c=3" #t #t)))
(test '(("a" . "1") ("b" . "2+2") ("c" . "3"))
(uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #f #t)))
(test '(("a" . "1") ("b" . "2 2") ("c" . "3"))
(uri-query (string->uri "http://google.com/%73?a=1&b=2+2;c=%33" #t #t)))
(test-end)