\f
;;;; Decoder
-(define (decode-www-form-urlencoded octets start end)
- (let ((input (open-input-octets octets start end)))
- (port/set-coding input 'us-ascii)
- (port/set-line-ending input 'crlf)
+(define (decode-www-form-urlencoded string start end)
+ (guarantee 8-bit-string? string 'decode-www-form-urlencoded)
+ (let ((input (open-input-string string start end)))
(let loop ((data '()))
(let ((char (read-char input)))
(if (eof-object? char)
data)))))))))
(define (decode-segment input name?)
- (call-with-output-string
- (lambda (output)
- (let ((out
- (if name?
- (lambda (char)
- (write-char (if (fix:< (char->integer char) #x80)
- (char-downcase char)
- char)
- output))
- (lambda (char)
- (write-char char output))))
- (digit
- (lambda ()
- (let ((char (read-char input)))
- (if (eof-object? char)
- (error "Incomplete %-escape in HTML form data."))
- (or (char->digit char 16)
- (error "Illegal character in % escape:" char))))))
- (let loop ()
- (let ((char (read-char input)))
- (cond ((eof-object? char)
- (if name?
- (error
- "Improperly terminated name in HTML form data.")))
- ((or (char-unreserved? char)
- (char=? char #\newline))
- (out char)
- (loop))
- ((char=? char #\=)
- (if (not name?)
- (error "Char in illegal position in HTML form data:"
+ (let ((builder (string-builder)))
+ (let ((out
+ (if name?
+ (lambda (char)
+ (builder (if (fix:< (char->integer char) #x80)
+ (char-downcase char)
char)))
- ((or (char=? char #\&)
- (char=? char #\;))
- (if name?
- (error "Char in illegal position in HTML form data:"
- char)))
- ((char=? char #\+)
- (out #\space)
- (loop))
- ((char=? char #\%)
- (let ((d1 (digit)))
- (out (integer->char (+ (* 16 d1) (digit)))))
- (loop))
- (else
- (error "Illegal character in HTML form data:" char)))))))))
+ builder))
+ (digit
+ (lambda ()
+ (let ((char (read-char input)))
+ (if (eof-object? char)
+ (error "Incomplete %-escape in HTML form data."))
+ (or (char->digit char 16)
+ (error "Illegal character in % escape:" char))))))
+ (let loop ()
+ (let ((char (read-char input)))
+ (cond ((eof-object? char)
+ (if name?
+ (error
+ "Improperly terminated name in HTML form data.")))
+ ((char=? char #\return)
+ (if (not (eqv? (peek-char input) #\newline))
+ (out char))
+ (loop))
+ ((or (char-unreserved? char)
+ (char=? char #\newline))
+ (out char)
+ (loop))
+ ((char=? char #\=)
+ (if (not name?)
+ (error "Char in illegal position in HTML form data:"
+ char)))
+ ((or (char=? char #\&)
+ (char=? char #\;))
+ (if name?
+ (error "Char in illegal position in HTML form data:"
+ char)))
+ ((char=? char #\+)
+ (out #\space)
+ (loop))
+ ((char=? char #\%)
+ (let ((d1 (digit)))
+ (out (integer->char (fix:or (fix:lsh d1 4) (digit)))))
+ (loop))
+ (else
+ (error "Illegal character in HTML form data:" char))))))
+ (builder)))
\f
;;;; Encoder
(string? (cdr p))))
"HTML form data alist"
'encode-www-form-urlencoded)
- (call-with-output-octets
- (lambda (port)
- (port/set-coding port 'us-ascii)
- (port/set-line-ending port 'crlf)
- (let ((write-datum
- (lambda (datum)
- (encode-segment (symbol->string (car datum)) port)
- (write-char #\= port)
- (encode-segment (cdr datum) port))))
- (if (pair? data)
- (begin
- (write-datum (car data))
- (do ((data (cdr data) (cdr data)))
- ((not (pair? data)))
- (write-char #\& port)
- (write-datum (car data)))))))))
-
-(define (encode-segment string port)
- (let ((end (string-length string)))
- (do ((i 0 (fix:+ i 1)))
- ((not (fix:< i end)))
- (encode-octet (string-ref string i) port))))
-
-(define (encode-octet char port)
- (cond ((char-unreserved? char)
- (write-char char port))
- ((char=? char #\space)
- (write-char #\+ port))
- ((char=? char #\newline)
- (write-char #\return port)
- (write-char #\linefeed port))
- (else
- (let ((octet (char->integer char)))
- (write-char #\% port)
- (write-char (digit->char (fix:lsh (fix:and octet #xF0) -4) 16) port)
- (write-char (digit->char (fix:and octet #x0F) 16) port)))))
-
-(define (char-unreserved? char)
- (char-in-set? char char-set:unreserved))
-
-(define char-set:unreserved)
-
-(define (initialize-package!)
- (set! char-set:unreserved
- (char-set-difference char-set:ascii
- (char-set-union char-set:ctls
- (string->char-set " +%=&;"))))
- unspecific)
\ No newline at end of file
+ (let ((builder (string-builder)))
+
+ (define (write-datum datum)
+ (encode-segment (symbol->string (car datum)))
+ (builder #\=)
+ (encode-segment (cdr datum)))
+
+ (define (encode-segment string)
+ (let ((end (string-length string)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (encode-octet (string-ref string i)))))
+
+ (define (encode-octet char)
+ (cond ((char-unreserved? char)
+ (builder char))
+ ((char=? char #\space)
+ (builder #\+))
+ ((char=? char #\newline)
+ (builder #\return)
+ (builder #\linefeed))
+ (else
+ (let ((octet (char->integer char)))
+ (builder #\%)
+ (builder (digit->char (fix:lsh (fix:and octet #xF0) -4) 16))
+ (builder (digit->char (fix:and octet #x0F) 16))))))
+
+ (if (pair? data)
+ (begin
+ (write-datum (car data))
+ (do ((data (cdr data) (cdr data)))
+ ((not (pair? data)))
+ (write-char #\&)
+ (write-datum (car data)))))
+ (builder)))
+
+(define-deferred char-set:unreserved
+ (char-set-difference char-set:ascii
+ (char-set-union char-set:ctls
+ (string->char-set " +%=&;"))))
+
+(define-deferred char-unreserved?
+ (char-set-predicate char-set:unreserved))
\ No newline at end of file
(make-accumulator-output-port open-output-string)
(string->input-port open-input-string)
(with-string-output-port call-with-output-string)
- call-with-input-octets
- call-with-output-octets
- open-input-octets
- open-output-octets
with-input-from-string
with-output-to-string
with-output-to-truncated-string)
(declare (usual-integrations))
\f
-;;;; Input as characters
+;;;; Input
;; obsolete
(define (with-input-from-string string thunk)
(make-textual-port string-input-type
(make-istate string start end start 0))))
-(define-structure istate
- (string #f read-only #t)
- (start #f read-only #t)
- (end #f read-only #t)
- next
- line-number)
+(define-record-type <istate>
+ (make-istate string start end next line-number)
+ istate?
+ (string istate-string)
+ (start istate-start)
+ (end istate-end)
+ (next istate-next set-istate-next!)
+ (line-number istate-line-number set-istate-line-number!))
-(define (make-string-input-type)
+(define-deferred string-input-type
(make-textual-port-type `((char-ready? ,string-in/char-ready?)
(eof? ,string-in/eof?)
(input-line ,string-in/input-line)
port
(write-string " from string" output-port))
\f
-;;;; Input as byte vector
-
-(define (call-with-input-octets octets procedure)
- (procedure (open-input-octets octets)))
-
-(define (open-input-octets octets #!optional start end)
- (let* ((end (fix:end-index end (string-length octets) 'open-input-octets))
- (start (fix:start-index start end 'open-input-octets))
- (port
- (make-generic-i/o-port (make-binary-port (make-octets-source octets
- start
- end)
- #f
- 'open-input-octets)
- octets-input-type
- 'open-input-octets)))
- (port/set-coding port 'binary)
- (port/set-line-ending port 'binary)
- port))
-
-(define (make-octets-source string start end)
- (let ((index start))
- (make-non-channel-input-source
- (lambda ()
- (fix:< index end))
- (lambda (bv start* end*)
- (let ((n (fix:min (fix:- end index) (fix:- end* start*))))
- (let ((limit (fix:+ index n)))
- (do ((i index (fix:+ i 1))
- (j start* (fix:+ j 1)))
- ((not (fix:< i limit))
- (set! index i))
- (bytevector-u8-set! bv j (char->integer (string-ref string i)))))
- n)))))
-
-(define (make-octets-input-type)
- (make-textual-port-type
- `((write-self
- ,(lambda (port output-port)
- port
- (write-string " from byte vector" output-port))))
- (generic-i/o-port-type #t #f)))
-\f
-;;;; Output as characters
+;;;; Output
(define (get-output-string port)
((textual-port-operation port 'extract-output) port))
(define (open-output-string)
(make-textual-port string-output-type (make-ostate (string-builder) 0)))
-(define-structure ostate
- (builder #f read-only #t)
- column)
+(define-record-type <ostate>
+ (make-ostate builder column)
+ ostate?
+ (builder ostate-builder)
+ (column ostate-column set-ostate-column!))
-(define (make-string-output-type)
+(define-deferred string-output-type
(make-textual-port-type `((write-char ,string-out/write-char)
(write-substring ,string-out/write-substring)
(extract-output ,string-out/extract-output)
(let ((nl (string-find-previous-char string #\newline start end)))
(if nl
(loop (fix:+ nl 1) 0)
- (loop start (ostate-column os))))))
-\f
-;;;; Output as octets
-
-(define (call-with-output-octets generator)
- (let ((port (open-output-octets)))
- (generator port)
- (get-output-string port)))
-
-(define (open-output-octets)
- (let ((port
- (let ((os (make-ostate (string-builder) #f)))
- (make-generic-i/o-port (make-binary-port #f
- (make-byte-sink os)
- 'open-output-octets)
- octets-output-type
- 'open-output-octets
- os))))
- (port/set-line-ending port 'newline)
- port))
-
-(define (make-byte-sink os)
- (make-non-channel-output-sink
- (lambda (bv start end)
- (let ((builder (ostate-builder os)))
- (do ((i start (fix:+ i 1)))
- ((not (fix:< i end)))
- (builder (integer->char (bytevector-u8-ref bv i)))))
- (fix:- end start))
- (lambda ()
- unspecific)))
-
-(define (make-octets-output-type)
- (make-textual-port-type `((extract-output ,string-out/extract-output)
- (extract-output! ,string-out/extract-output!)
- (position ,string-out/position)
- (write-self ,octets-out/write-self))
- (generic-i/o-port-type #f #t)))
-
-(define (octets-out/write-self port output-port)
- port
- (write-string " to byte vector" output-port))
-
-(define string-input-type)
-(define octets-input-type)
-(define string-output-type)
-(define octets-output-type)
-(define output-octets-port/os)
-(add-boot-init!
- (lambda ()
- (set! string-input-type (make-string-input-type))
- (set! octets-input-type (make-octets-input-type))
- (set! string-output-type (make-string-output-type))
- (set! octets-output-type (make-octets-output-type))
- (set! output-octets-port/os (generic-i/o-port-accessor 0))
- unspecific))
\ No newline at end of file
+ (loop start (ostate-column os))))))
\ No newline at end of file
(if (eq? (http-request-method) 'post)
(let ((entity (http-request-entity)))
(if entity
- (let ((document (read-xml (open-input-octets entity))))
+ (let ((document (bytevector->xml (string->iso8859-1 entity))))
(if document
(write-xml (process-xmlrpc-request document pathname) port)
(http-status-response 400 "Ill-formed XML entity")))
projects / mit-scheme.git / commitdiff