suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

better url decoding

Browse Source 
svn: r1814
This commit is contained in:
Jay McCarthy 2006-01-12 15:25:21 +00:00
parent 8012ebb396
commit 5426be858d
1 changed files with 14 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/web-server/util.ss
View File

@ -5,7 +5,8 @@
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "errortrace-lib.ss" "errortrace")) (lib "errortrace-lib.ss" "errortrace")
(lib "uri-codec.ss" "net"))
(require "response-structs.ss" (require "response-structs.ss"
"request-structs.ss") "request-structs.ss")
@ -283,29 +284,15 @@
(define-struct (invalid-%-suffix servlet-error) (chars)) (define-struct (invalid-%-suffix servlet-error) (chars))
(define-struct (incomplete-%-suffix invalid-%-suffix) ()) (define-struct (incomplete-%-suffix invalid-%-suffix) ())
(define (translate-escapes raw) (define (translate-escapes raw)
(list->string (let ([raw (uri-decode raw)])
(let loop ((chars (string->list raw))) (list->string
(if (null? chars) null (let loop ((chars (string->list raw)))
(let ((first (car chars)) (if (null? chars) null
(rest (cdr chars))) (let ((first (car chars))
(let-values (((this rest) (rest (cdr chars)))
(cond (let-values (((this rest)
((char=? first #\+) (cond
(values #\space rest)) ((char=? first #\+)
((char=? first #\%) (values #\space rest))
; MF: I rewrote this code so that Spidey could eliminate all checks. (else (values first rest)))))
; I am more confident this way that this hairy expression doesn't barf. (cons this (loop rest))))))))))
(if (pair? rest)
(let ([rest-rest (cdr rest)])
(if (pair? rest-rest)
(values (integer->char
(or (string->number (string (car rest) (car rest-rest)) 16)
(raise (make-invalid-%-suffix
(if (string->number (string (car rest)) 16)
(car rest-rest)
(car rest))))))
(cdr rest-rest))
(raise (make-incomplete-%-suffix rest))))
(raise (make-incomplete-%-suffix rest))))
(else (values first rest)))))
(cons this (loop rest)))))))))