From bca86ef7a10d5f73ba6e5aeb82ab72b927606558 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 10 Oct 2001 04:52:37 +0000 Subject: [PATCH] The parser language developed for IMAIL has been replaced by the newer *PARSER facility. --- v7/src/runtime/runtime.pkg | 16 ++-- v7/src/runtime/url.scm | 158 +++++++++++++++++++++---------------- 2 files changed, 100 insertions(+), 74 deletions(-) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index d5bda88e7..011b21d65 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.378 2001/10/05 15:58:18 cph Exp $ +$Id: runtime.pkg,v 14.379 2001/10/10 04:52:37 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -3773,12 +3773,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA url:decode-substring url:encode-string url:encode-substring - url:rexp:escape - url:rexp:host - url:rexp:hostname - url:rexp:hostnumber - url:rexp:hostport - url:rexp:uchar - url:rexp:xchar + url:match:escape + url:match:host + url:match:hostname + url:match:hostnumber + url:match:uchar + url:match:xchar + url:parse:hostport url:string-encoded? url:substring-encoded?)) \ No newline at end of file diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index fd4126cf7..12c2f0f7d 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: url.scm,v 1.9 2001/10/05 15:57:43 cph Exp $ +$Id: url.scm,v 1.10 2001/10/10 04:52:12 cph Exp $ Copyright (c) 2000, 2001 Massachusetts Institute of Technology @@ -23,13 +23,14 @@ USA. ;;;; URL Encoding (declare (usual-integrations)) -(load-option 'REGULAR-EXPRESSION) +(load-option '*PARSER) (define url:char-set:safe (string->char-set "$-_.+")) (define url:char-set:extra (string->char-set "!*'(),")) (define url:char-set:national (string->char-set "{}|\\^~[]`")) (define url:char-set:punctuation (string->char-set "<>#%\"")) (define url:char-set:reserved (string->char-set ";/?:@&=")) +(define url:char-set:hex (string->char-set "0123456789abcdefABCDEF")) (define url:char-set:unreserved (char-set-union char-set:alphanumeric @@ -43,51 +44,66 @@ USA. (define url:char-set:escaped (char-set-invert url:char-set:unescaped)) -(define url:rexp:escape - (let ((char-set:hex (string->char-set "0123456789ABCDEFabcdef"))) - (rexp-sequence "%" char-set:hex char-set:hex))) - -(define url:rexp:uchar - (rexp-alternatives url:char-set:unreserved url:rexp:escape)) - -(define url:rexp:xchar - (rexp-alternatives url:char-set:unescaped url:rexp:escape)) - -(define url:rexp:hostname - (let ((tail - (rexp-optional - (rexp* - (char-set-union char-set:alphanumeric (string->char-set "-"))) - char-set:alphanumeric))) - (rexp-sequence (rexp* char-set:alphanumeric tail ".") - char-set:alphabetic - tail))) - -(define url:rexp:hostnumber - (let ((n (rexp+ char-set:numeric))) - (rexp-sequence n "." n "." n "." n))) - -(define url:rexp:host - (rexp-alternatives url:rexp:hostname url:rexp:hostnumber)) - -(define url:rexp:hostport - (rexp-sequence url:rexp:host (rexp-optional ":" (rexp+ char-set:numeric)))) +(define url:match:escape + (*matcher + (seq "%" + (char-set url:char-set:hex) + (char-set url:char-set:hex)))) + +(define url:match:uchar + (*matcher + (alt (char-set url:char-set:unreserved) + url:match:escape))) + +(define url:match:xchar + (*matcher + (alt (char-set url:char-set:unescaped) + url:match:escape))) + +(define url:parse:hostport + (*parser + (seq (match url:match:host) + (alt (map string->number + (seq (noise ":") + (match (+ (char-set char-set:numeric))))) + (values #f))))) + +(define url:match:host + (*matcher (alt url:match:hostname url:match:hostnumber))) + +(define url:match:hostname + (let ((match-tail + (*matcher + (* (alt (char-set char-set:alphanumeric) + (seq (+ #\-) + (char-set char-set:alphanumeric))))))) + (*matcher + (seq (* (seq (char-set char-set:alphanumeric) + match-tail + ".")) + (char-set char-set:alphabetic) + match-tail)))) + +(define url:match:hostnumber + (*matcher + (seq (+ (char-set char-set:numeric)) + "." + (+ (char-set char-set:numeric)) + "." + (+ (char-set char-set:numeric)) + "." + (+ (char-set char-set:numeric))))) (define (url:string-encoded? string) (url:substring-encoded? string 0 (string-length string))) -(define (url:encode-string string) - (url:encode-substring string 0 (string-length string))) - -(define (url:decode-string string) - (url:decode-substring string 0 (string-length string))) - (define url:substring-encoded? - (let ((pattern (rexp-compile (rexp* url:rexp:xchar)))) + (let ((matcher (*matcher (complete (* url:match:xchar))))) (lambda (string start end) - (let ((regs (re-substring-match pattern string start end))) - (and regs - (fix:= end (re-match-end-index 0 regs))))))) + (matcher (substring->parser-buffer string start end))))) + +(define (url:encode-string string) + (url:encode-substring string 0 (string-length string))) (define (url:encode-substring string start end) (let ((n-to-encode @@ -122,31 +138,41 @@ USA. (loop (fix:+ index 1) (fix:+ i 3)))) (substring-move! string start end encoded i)))) encoded)))) + +(define (url:decode-string string) + (url:decode-substring string 0 (string-length string))) (define (url:decode-substring string start end) - (let ((patt (rexp-compile url:rexp:escape))) - (let ((n-encoded - (let loop ((start start) (n-encoded 0)) - (let ((regs (re-substring-search-forward patt string start end))) - (if regs - (loop (re-match-end-index 0 regs) (fix:+ n-encoded 1)) - n-encoded))))) - (if (fix:= 0 n-encoded) - (substring string start end) - (let ((decoded - (make-string (fix:- (fix:- end start) (fix:* 2 n-encoded))))) - (let loop ((start start) (i 0)) - (let ((regs (re-substring-search-forward patt string start end))) - (if regs - (let ((index (re-match-start-index 0 regs))) + (let ((n-encoded + (let loop ((start start) (n-encoded 0)) + (let ((index (substring-find-next-char string start end #\%))) + (if index + (loop (fix:+ index 1) (fix:+ n-encoded 1)) + n-encoded)))) + (lose + (lambda () + (error "Malformed encoded URL string:" + (substring string start end))))) + (if (fix:= 0 n-encoded) + (substring string start end) + (let ((decoded + (make-string (fix:- (fix:- end start) (fix:* 2 n-encoded))))) + (let loop ((start start) (i 0)) + (let ((index (substring-find-next-char string start end #\%))) + (if index + (begin + (if (not (fix:<= (fix:+ index 3) end)) + (lose)) + (let ((k + (substring->number string + (fix:+ index 1) + (fix:+ index 3) + 16)) + (i* (fix:+ i (fix:- index start)))) + (if (not k) + (lose)) (substring-move! string start index decoded i) - (let ((i (fix:+ i (fix:- index start)))) - (vector-8b-set! - decoded i - (substring->number string - (fix:+ index 1) - (fix:+ index 3) - 16)) - (loop (fix:+ index 3) (fix:+ i 1)))) - (substring-move! string start end decoded i)))) - decoded))))) \ No newline at end of file + (vector-8b-set! decoded i* k) + (loop (fix:+ index 3) (fix:+ i* 1)))) + (substring-move! string start end decoded i)))) + decoded)))) \ No newline at end of file -- 2.25.1