(vector-8b? string?)
ascii-string-copy
burst-string
+ bytevector->string
char->string
decorated-string-append
error:not-string
random-byte-vector
set-string-length!
string
+ string->bytevector
string->list
string->vector
string-append
substring<?
substring=?
substring?
+ textual-input-port->binary
+ textual-output-port->binary
vector-8b-fill!
vector-8b-find-next-char
vector-8b-find-next-char-ci
(call-with-output-string
(lambda (port)
(let ((context (encode-base64:initialize port #f)))
- (encode-base64:update context string 0 (string-length string))
+ (encode-base64:update context (string->bytevector string))
(encode-base64:finalize context))))))
(smtp-write-line port (base64 user-name))
(smtp-read-response port 334)
(call-with-output-string
(lambda (port)
(let ((context (encode-base64:initialize port)))
- (encode-base64:update context "\000" 0 1)
- (encode-base64:update context user-name 0 (string-length user-name))
- (encode-base64:update context "\000" 0 1)
+ (encode-base64:update context (bytevector 0))
+ (encode-base64:update context (string->bytevector user-name))
+ (encode-base64:update context (bytevector 0))
(call-with-stored-pass-phrase pass-phrase-key
(lambda (pass)
- (encode-base64:update context pass 0 (string-length pass))))
+ (encode-base64:update context (string->bytevector pass))))
(encode-base64:finalize context))))))
(define (smtp-server-pass-phrase-key user-name lookup-context)
(lambda (string start end)
(encode-quoted-printable:update
context
- (substring string 0 (string-length string))
+ (string-copy string)
start
end)))
(encode-quoted-printable:finalize context)))
(mime-attachment-message-headers attachment))
(newline port)
((mime-attachment-message-body-generator attachment) port))
- (receive (initialize update finalize text?)
- (if (eq? type 'TEXT)
- (values encode-quoted-printable:initialize
- encode-quoted-printable:update
- encode-quoted-printable:finalize
- #t)
- (values encode-base64:initialize
- encode-base64:update
- encode-base64:finalize
- #f))
- (let ((context (initialize port text?)))
- ((if (eq? type 'TEXT)
- call-with-input-file
- call-with-legacy-binary-input-file)
- (mime-attachment-pathname attachment)
- (lambda (input-port)
- (let ((buffer (make-string 4096)))
- (let loop ()
- (let ((n-read (read-string! buffer input-port)))
- (if (> n-read 0)
- (begin
- (update context buffer 0 n-read)
- (loop))))))))
- (finalize context))))))
+ (if (eq? type 'TEXT)
+ (let ((context (encode-quoted-printable:initialize port #t)))
+ (call-with-input-file (mime-attachment-pathname attachment)
+ (lambda (input-port)
+ (let ((buffer (make-string 4096)))
+ (let loop ()
+ (let ((n-read (read-string! buffer input-port)))
+ (if (> n-read 0)
+ (begin
+ (encode-quoted-printable:update context
+ buffer 0 n-read)
+ (loop))))))))
+ (encode-quoted-printable:finalize context))
+ (let ((context (encode-base64:initialize port #f)))
+ (call-with-binary-input-file
+ (mime-attachment-pathname attachment)
+ (lambda (input-port)
+ (let ((buffer (make-bytevector 4096)))
+ (let loop ()
+ (let ((n-read (read-bytevector! buffer input-port)))
+ (if (> n-read 0)
+ (begin
+ (encode-base64:update context buffer 0 n-read)
+ (loop))))))))
+ (encode-base64:finalize context))))))
\f
(define (enable-buffer-mime-processing! buffer)
(buffer-remove! buffer 'MAIL-DISABLE-MIME-PROCESSING))
(write-string prefix port)
(let ((context (encode-base64:initialize port #f)))
(let ((n (* (integer-ceiling (- length 2) 4) 3)))
- (encode-base64:update context
- (random-byte-vector n) 0 n))
+ (encode-base64:update context (random-bytevector n)))
(encode-base64:finalize context))))
(+ plen length))))
\f
(string-set! string j (string-ref string i))
(string-set! string i char)))))
\f
+;;; Binary <-> textual converters
+
+(define (string->bytevector string #!optional start end)
+ (let* ((end (fix:end-index end (string-length string) 'string->bytevector))
+ (start (fix:start-index start end 'string->bytevector))
+ (bv (make-bytevector (fix:- end start))))
+ (do ((i start (fix:+ i 1))
+ (j 0 (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (bytevector-u8-set! bv j (char->integer (string-ref string i))))
+ bv))
+
+(define (bytevector->string bv #!optional start end)
+ (let* ((end (fix:end-index end (bytevector-length bv) 'bytevector->string))
+ (start (fix:start-index start end 'bytevector->string))
+ (string (make-string (fix:- end start))))
+ (do ((i start (fix:+ i 1))
+ (j 0 (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (string-set! string j (char->integer (bytevector-u8-ref bv i))))
+ string))
+
+(define (textual-input-port->binary textual-port)
+
+ (define (has-bytes?)
+ (char-ready? textual-port))
+
+ (define (read-bytes! bv start end)
+ (let ((string (read-string (fix:- end start) textual-port)))
+ (if (or (not string) (eof-object? string))
+ string
+ (let ((n (string-length string)))
+ (do ((i 0 (fix:+ i 1))
+ (j start (fix:+ j 1)))
+ ((not (fix:< i n)))
+ (bytevector-u8-set! bv j (char->integer (string-ref string i))))
+ n))))
+
+ (define (close)
+ (close-port textual-port))
+
+ (make-binary-port (make-non-channel-input-source has-bytes? read-bytes! close)
+ #f))
+
+(define (textual-output-port->binary textual-port)
+
+ (define (write-bytes bv start end)
+ (do ((i start (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (write-char (bytevector-u8-ref bv i) textual-port)))
+
+ (define (close)
+ (close-port textual-port))
+
+ (make-binary-port #f (make-non-channel-output-sink write-bytes close)))
+\f
(define (decorated-string-append prefix infix suffix strings)
(let ((infix (string-append suffix infix prefix)))
(string-append*
#f)))
(define (mime:get-content-language header-fields)
- ;++ implement
+ ;;++ implement
+ (declare (ignore header-fields))
#f)
\f
;;;; Extended RFC 822 Tokenizer
make-decode-quoted-printable-port
call-with-decode-quoted-printable-output-port)
+(define (make-decode-base64-port* textual-port text?)
+ (make-decode-base64-port (textual-output-port->binary textual-port) text?))
+
+(define (call-with-decode-base64-port* textual-port text? procedure)
+ (let ((port (make-decode-base64-port* textual-port text?)))
+ (let ((value (procedure port)))
+ (close-port port)
+ value)))
+
(define-mime-encoding 'BASE64
encode-base64:initialize
encode-base64:finalize
decode-base64:initialize
decode-base64:finalize
decode-base64:update
- make-decode-base64-port
- call-with-decode-base64-output-port)
+ make-decode-base64-port*
+ call-with-decode-base64-port*)
+
+(define (make-decode-binhex40-port* textual-port text?)
+ (make-decode-binhex40-port (textual-output-port->binary textual-port) text?))
+
+(define (call-with-decode-binhex40-port* textual-port text? procedure)
+ (let ((port (make-decode-binhex40-port* textual-port text?)))
+ (let ((value (procedure port)))
+ (close-port port)
+ value)))
(define-mime-encoding 'BINHEX40
#f #f #f ;No BinHex encoder.
decode-binhex40:initialize
decode-binhex40:finalize
decode-binhex40:update
- make-decode-binhex40-port
- call-with-decode-binhex40-output-port)
+ make-decode-binhex40-port*
+ call-with-decode-binhex40-port*)
;;;; MIME support
(declare (usual-integrations))
-
+\f
(define (make-decoding-port-type update finalize)
(make-textual-port-type
`((write-char
u8-ready?
write-bytevector
write-u8)
+ ;; Temporary hack: this allows these bindings to be seen by Edwin.
+ ;; Move these bindings back to (runtime) after 9.3 release.
+ (export ()
+ make-binary-port
+ make-non-channel-input-source
+ make-non-channel-output-sink)
(export (runtime)
input-source-channel
input-source-custom-length
input-source-open?
input-source-port
input-source?
- make-binary-port
make-channel-input-source
make-channel-output-sink
- make-non-channel-input-source
- make-non-channel-output-sink
output-sink-channel
output-sink-custom-length
output-sink-custom-ref
(define (decode-basic-auth-header string start end)
(let ((auth
- (call-with-output-string
- (lambda (port)
- (let ((ctx (decode-base64:initialize port #t)))
- (decode-base64:update ctx string start end)
- (decode-base64:finalize ctx))))))
+ (utf8->string
+ (call-with-output-bytevector
+ (lambda (port)
+ (let ((ctx (decode-base64:initialize port #t)))
+ (decode-base64:update ctx string start end)
+ (decode-base64:finalize ctx)))))))
(let ((colon (string-find-next-char auth #\:)))
(if (not colon)
(error "Malformed authorization string."))
(content-string elt))
((base64)
(safe-call (lambda (string)
- (call-with-output-string
+ (call-with-output-bytevector
(lambda (port)
(call-with-decode-base64-output-port port #f
(lambda (port)
(call-with-output-string
(lambda (port)
(let ((context (encode-base64:initialize port #f)))
- (encode-base64:update context string 0 (string-length string))
+ (encode-base64:update context (string->utf8 string))
(encode-base64:finalize context)))))))
(define *xml-rpc:encode-value-handler* #f)
projects / mit-scheme.git / commitdiff