diff --git a/collects/r6rs/private/ports.ss b/collects/r6rs/private/ports.ss new file mode 100644 index 0000000000..1849237864 --- /dev/null +++ b/collects/r6rs/private/ports.ss @@ -0,0 +1,1138 @@ +#lang scheme/base + +;; FIXME: newline decoding + +(require rnrs/enums-6 + rnrs/conditions-6 + r6rs/private/io-conds + r6rs/private/readtable + r6rs/private/exns + scheme/port + scheme/pretty + scheme/promise) + +(provide (all-from-out r6rs/private/io-conds) + file-options + buffer-mode buffer-mode? + latin-1-codec utf-8-codec utf-16-codec + eol-style native-eol-style + &i/o-decoding make-i/o-decoding-error i/o-decoding-error? + &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char + error-handling-mode + (rename-out [r6rs:make-transcoder make-transcoder]) + transcoder-codec + transcoder-eol-style + transcoder-error-handling-mode + native-transcoder + bytevector->string + string->bytevector + eof-object + eof-object? + port? + port-transcoder + textual-port? + binary-port? + transcoded-port + port-has-port-position? + port-position + port-has-set-port-position!? + set-port-position! + close-port + call-with-port + input-port? + port-eof? + open-file-input-port + open-bytevector-input-port + open-string-input-port + standard-input-port + (rename-out [r6rs:current-input-port current-input-port]) + make-custom-binary-input-port + make-custom-textual-input-port + get-u8 + lookahead-u8 + get-bytevector-n + get-bytevector-n! + get-bytevector-some + get-bytevector-all + get-char + lookahead-char + get-string-n + get-string-n! + get-string-all + get-line + get-datum + output-port? + flush-output-port + output-port-buffer-mode + open-file-output-port + open-bytevector-output-port + call-with-bytevector-output-port + open-string-output-port + call-with-string-output-port + standard-output-port + standard-error-port + (rename-out [r6rs:current-output-port current-output-port] + [r6rs:current-error-port current-error-port]) + make-custom-binary-output-port + make-custom-textual-output-port + put-u8 + put-bytevector + put-char + put-string + put-datum + open-file-input/output-port + make-custom-binary-input/output-port + make-custom-textual-input/output-port + + ;; Non-standard + r6rs-port->port) + +;; ---------------------------------------- + +(define-enumeration -file-option (no-create no-fail no-truncate) + file-options) + +(define-enumeration buffer-mode (none line block) + -buffer-modes) + +(define (buffer-mode? m) + (enum-set-member? m (-buffer-modes none line block))) + +(define-enumeration eol-style (lf cr crlf nel crnel ls none) + -eol-styles) + +(define-struct codec (enc)) +(define latin-1 (make-codec "latin1")) +(define utf-8 (make-codec "utf-8")) +(define utf-16 (make-codec "utf-16")) + +(define (latin-1-codec) latin-1) +(define (utf-8-codec) utf-8) +(define (utf-16-codec) utf-16) + +(define (native-eol-style) + (if (eq? (system-type) 'windows) + 'crlf + 'lf)) + +(define-condition-type &i/o-decoding &i/o-port + make-i/o-decoding-error i/o-decoding-error?) + +(define-condition-type &i/o-encoding &i/o-port + make-i/o-encoding-error i/o-encoding-error? + (char i/o-encoding-error-char)) + +(define-enumeration error-handling-mode (ignore raise replace) + -handling-modes) + +(define-struct transcoder (codec eol-style error-handling-mode)) + +(define (r6rs:make-transcoder codec + [eol-style (native-eol-style)] + [handling-mode 'replace]) + (unless (codec? codec) + (raise-type-error 'make-transcoder "codec" codec)) + (unless (enum-set-member? eol-style (-eol-styles lf cr crlf nel crnel ls none)) + (raise-type-error 'make-transcoder "'lf, 'cr, 'crlf, 'nel, 'crnel, 'ls, or 'none" eol-style)) + (unless (enum-set-member? handling-mode (-handling-modes ignore raise replace)) + (raise-type-error 'make-transcoder "'ignore, 'raise, or 'replace" eol-style)) + (make-transcoder codec eol-style handling-mode)) + +(define utf8-transcoder + (make-transcoder utf-8 'none '?)) + +(define (native-transcoder) + utf8-transcoder) + +(define (eof-object) eof) + +;; ---------------------------------------- + +(define (make-disconnectable-input-port port close?) + (define disconnected? #f) + (define (check-disconnect) + (when disconnected? + (error 'read-byte "cannot read for transcoded binary port"))) + (values + (make-input-port + (object-name port) + (lambda (bytes) + (check-disconnect) + (let ([n (read-bytes-avail!* bytes port)]) + (if (eq? n 0) + (wrap-evt port (lambda (v) 0)) + n))) + (lambda (bytes skip evt) + (check-disconnect) + (let ([n (peek-bytes-avail! bytes skip evt port)]) + (if (eq? n 0) + (wrap-evt port (lambda (v) 0)) + n))) + (lambda () + (unless disconnected? + (when close? + (close-input-port port)))) + (and (port-provides-progress-evts? port) + (lambda () + (check-disconnect) + (port-progress-evt port))) + (and (port-provides-progress-evts? port) + (lambda (k evt done) + (port-commit-peeked k evt done port))) + (lambda () + (check-disconnect) + (port-next-location port)) + (lambda () + (check-disconnect) + (port-count-lines! port)) + 1 + (case-lambda + [() (check-disconnect) (file-stream-buffer-mode port)] + [(mode) (check-disconnect) (file-stream-buffer-mode port + (if (eq? mode 'line) 'block mode))])) + (lambda () + (set! disconnected? #t) + port))) + +(define (make-disconnectable-output-port port close?) + (define disconnected? #f) + (define (check-disconnect) + (when disconnected? + (error 'read-byte "cannot read for transcoded binary port"))) + (values + (make-output-port + (object-name port) + port + (lambda (bytes start end can-buffer/block? enable-breaks?) + (check-disconnect) + (if (= start end) + (begin + (flush-output port) + 0) + (cond + [enable-breaks? + (parameterize-break #t (write-bytes (subbytes bytes start end) port))] + [can-buffer/block? + (write-bytes (subbytes bytes start end) port)] + [else + (write-bytes-avail* (subbytes bytes start end) port)]))) + (lambda () + (unless disconnected? + (when close? + (close-output-port port)))) + (and (port-writes-special? port) + (lambda (v can-buffer/block? enable-breaks?) + (check-disconnect) + (cond + [enable-breaks? + (parameterize-break #t (write-special v port))] + [can-buffer/block? + (write-special v port)] + [else + (write-special-avail* v port)]))) + (and (port-writes-atomic? port) + (lambda (bytes start end) + (check-disconnect) + (write-bytes-avail-evt bytes port start end))) + (and (port-writes-special? port) + (port-writes-atomic? port) + (lambda (v) + (check-disconnect) + (write-special-evt v port))) + (lambda () + (check-disconnect) + (port-next-location port)) + (lambda () + (check-disconnect) + (port-count-lines! port)) + 1 + (case-lambda + [() (check-disconnect) (file-stream-buffer-mode port)] + [(mode) (check-disconnect) (file-stream-buffer-mode port mode)])) + (lambda () + (set! disconnected? #t) + port))) + +;; For merging two kinds of ports: +(define-struct dual-port (in out) + #:property prop:input-port 0 + #:property prop:output-port 1) + +;; R6RS functions that generate binary ports wrap them with `binary-...-port' +;; structures, so that the binary ports can be "closed" by `transcoded-port'. +(define-struct binary-input-port (port disconnect get-pos set-pos!) + #:property prop:input-port 0) +(define-struct binary-output-port (port disconnect get-pos set-pos!) + #:property prop:output-port 0) +(define-struct (binary-input/output-port binary-input-port) (out-port out-disconnect) + #:property prop:output-port 0) + +;; Textual ports are transcoded +(define-struct textual-input-port (port transcoder) + #:property prop:input-port 0) +(define-struct textual-output-port (port transcoder) + #:property prop:output-port 0) +(define-struct (textual-input/output-port textual-input-port) (out-port) + #:property prop:output-port 0) + +(define (port-transcoder port) + (cond + [(dual-port? port) (port-transcoder (dual-port-in port))] + [(textual-input-port? port) (textual-input-port-transcoder port)] + [(textual-output-port? port) (textual-output-port-transcoder port)] + [(input-port? port) #f] + [(output-port? port) #f] + [else (raise-type-error 'port-transcoder "port" port)])) + +(define (textual-port? v) + (if (port? v) + (or (textual-input-port? v) + (textual-output-port? v) + (and (dual-port? v) + (textual-port? (dual-port-in v)))) + (raise-type-error 'textual-port? "port" v))) + +(define (binary-port? v) + (if (port? v) + (not (or (textual-input-port? v) + (textual-output-port? v) + (and (dual-port? v) + (textual-port? (dual-port-in v))))) + (raise-type-error 'binary-port? "port" v))) + +(define (wrap-binary-input-port p get-pos set-pos! close?) + (let-values ([(p disconnect) (make-disconnectable-input-port p close?)]) + (make-binary-input-port p disconnect get-pos set-pos!))) + +(define (wrap-binary-output-port p get-pos set-pos! close?) + (let-values ([(p disconnect) (make-disconnectable-output-port p close?)]) + (make-binary-output-port p disconnect get-pos set-pos!))) + +(define (wrap-binary-input/output-port p get-pos set-pos! close?) + (let-values ([(p disconnect) (make-disconnectable-input-port p #t)] + [(out-p out-disconnect) (make-disconnectable-output-port p #t)]) + (make-binary-input/output-port p disconnect get-pos set-pos! + out-p out-disconnect))) + +(define (no-op-transcoder? t) + (or (eq? t utf8-transcoder) + (and (eq? utf-8 (transcoder-codec t)) + (eq? (transcoder-eol-style t) 'none) + (eq? 'replace (transcoder-error-handling-mode t))))) + +(define (transcode-input p t) + (let ([p (if (binary-input-port? p) + ((binary-input-port-disconnect p)) + p)]) + (if (no-op-transcoder? t) + p + (letrec ([self + (reencode-input-port p + (codec-enc (transcoder-codec t)) + (case (transcoder-error-handling-mode t) + [(raise) #f] + [(ignore) #""] + [(replace) (string->bytes/utf-8 "\uFFFD")]) + #t + (object-name p) + (not (eq? (transcoder-eol-style t) 'none)) + (lambda (msg port) + (raise + (condition + (make-message-condition + (format "~a: ~e" msg port)) + (make-i/o-decoding-error + self)))))]) + self)))) + +(define (transcode-output p t) + (let ([p (cond + [(binary-output-port? p) + ((binary-output-port-disconnect p))] + [(binary-input/output-port? p) + ((binary-input/output-port-out-disconnect p))] + [else p])]) + (if (no-op-transcoder? t) + p + (letrec ([self + (reencode-output-port p + (codec-enc (transcoder-codec t)) + (case (transcoder-error-handling-mode t) + [(raise) #f] + [(ignore) #""] + [(replace) (string->bytes/utf-8 "\uFFFD")]) + #t + (object-name p) + (case (transcoder-eol-style t) + [(lf none) #f] + [(cr) #"\r"] + [(crlf) #"\r\n"] + [(nel) (string->bytes/utf-8 "\u85")] + [(crnel) (string->bytes/utf-8 "\r\u85")] + [(ls) (string->bytes/utf-8 "\u2028")] + [else (error 'transcoded-port "unknown eol style: ~e" + (transcoder-eol-style t))]) + (lambda (msg port) + (raise + (condition + (make-message-condition + (format "~a: ~e" msg port)) + (make-i/o-encoding-error + self + #\?)))))]) + self)))) + +(define (transcoded-port p t) + (unless (and (port? p) + (binary-port? p)) + (raise-type-error 'transcoded-port "binary port" p)) + (unless (transcoder? t) + (raise-type-error 'transcoded-port "transcoder" t)) + (cond + [(and (input-port? p) (output-port? p)) + (make-textual-input/output-port (transcode-input p t) + t + (transcode-output p t))] + [(input-port? p) + (make-textual-input-port (transcode-input p t) t)] + [(output-port? p) + (make-textual-output-port (transcode-output p t) t)])) + +(define (port-has-port-position? p) + (unless (port? p) + (raise-type-error 'port-has-port-position? "port" p)) + (cond + [(binary-input-port? p) + (and (binary-input-port-get-pos p) #t)] + [(binary-output-port? p) + (and (binary-output-port-get-pos p) #t)] + [(textual-input-port? p) + (port-has-port-position? (textual-input-port-port p))] + [(textual-output-port? p) + (port-has-port-position? (textual-output-port-port p))] + [(dual-port? p) + (port-has-port-position? (dual-port-in p))] + [else #t])) + +(define (port-position p) + (cond + [(binary-input-port? p) + ((binary-input-port-get-pos p))] + [(binary-output-port? p) + ((binary-output-port-get-pos p))] + [(textual-input-port? p) + (port-position (textual-input-port-port p))] + [(textual-output-port? p) + (port-position (textual-output-port-port p))] + [(dual-port? p) + (port-position (dual-port-in p))] + [else (file-position p)])) + +(define (port-has-set-port-position!? p) + (unless (port? p) + (raise-type-error 'port-has-port-set-position!? "port" p)) + (cond + [(binary-input-port? p) + (and (binary-input-port-set-pos! p) #t)] + [(binary-output-port? p) + (and (binary-output-port-set-pos! p) #t)] + [(textual-input-port? p) + (port-has-set-port-position!? (textual-input-port-port p))] + [(textual-output-port? p) + (port-has-set-port-position!? (textual-output-port-port p))] + [(dual-port? p) + (port-has-set-port-position!? (dual-port-in p))] + [else + ;; we could also allow string ports here + (file-stream-port? p)])) + +(define (set-port-position! p pos) + (unless (and (port? p) + (port-has-set-port-position!? p)) + (raise-type-error 'set-port-position! "port with settable position" p)) + (cond + [(binary-input-port? p) + ((binary-input-port-set-pos! p) pos)] + [(binary-output-port? p) + ((binary-output-port-set-pos! p) pos)] + [(textual-input-port? p) + (set-port-position! (textual-input-port-port p) pos)] + [(textual-output-port? p) + (set-port-position! (textual-output-port-port p) pos)] + [(dual-port? p) + (set-port-position! (dual-port-in p) pos)] + [else + (file-position p pos)])) + +(define (call-with-port port proc) + (unless (port? port) + (raise-type-error 'call-with-port "port" port)) + (begin0 + (proc port) + (close-port port))) + +(define (close-port port) + (when (input-port? port) + (close-input-port port)) + (when (output-port? port) + (close-output-port port))) + +;; ---------------------------------------- + +(define (port-eof? p) + (eof-object? (peek-byte p))) + +(define (open-file-input-port filename + [options (file-options)] + [buffer-mode 'block] + [maybe-transcoder #f]) + (unless (enum-set=? (enum-set-universe options) + (enum-set-universe (file-options))) + (raise-type-error 'open-file-input-port "file-options enum set" options)) + (unless (enum-set-member? buffer-mode (-buffer-modes none line block)) + (raise-type-error 'open-file-input-port "'none, 'line, or 'block" buffer-mode)) + (when maybe-transcoder + (unless (transcoder? maybe-transcoder) + (raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder))) + (let ([p (open-input-file filename)]) + (file-stream-buffer-mode p (if (eq? buffer-mode 'line) + 'block + buffer-mode)) + (if maybe-transcoder + (transcoded-port p maybe-transcoder) + (wrap-binary-input-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #t)))) + +(define (open-bytevector-input-port bytes [maybe-transcoder #f]) + (unless (bytes? bytes) + (raise-type-error 'open-bytevector-input-port "bytevector" bytes)) + (when maybe-transcoder + (unless (transcoder? maybe-transcoder) + (raise-type-error 'open-bytevector-input-port "transcoder or #f" maybe-transcoder))) + (let ([p (open-input-bytes bytes)]) + (if maybe-transcoder + (transcoded-port p maybe-transcoder) + (wrap-binary-input-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #t)))) + +(define (open-string-input-port str) + (unless (string? str) + (raise-type-error 'open-bytevector-input-port "string" str)) + (let ([p (open-input-string str)]) + (transcoded-port + (wrap-binary-input-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #t) + utf8-transcoder))) + +(define standard-input-port + (let ([p (current-input-port)]) + (lambda () + (wrap-binary-input-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #f)))) + +(define input-ports (make-weak-hasheq)) + +(define (r6rs:current-input-port) + (let ([p (current-input-port)]) + (cond + [(textual-port? p) p] + [(hash-ref input-ports p #f) + => ephemeron-value] + [else + (let ([p2 (transcoded-port p utf8-transcoder)]) + (hash-set! input-ports p (make-ephemeron p p2)) + p2)]))) + +(define (make-custom-binary-input-port id read! get-position set-position! close) + (let* ([peeked 0] + [p (make-input-port/read-to-peek + id + (lambda (bytes) + (let ([v (read! bytes 0 (bytes-length bytes))]) + (set! peeked (+ peeked v)) + (if (zero? v) + eof + v))) + #f + (or close void) + #f void 1 + #f #f + (lambda (consumed-n) + (unless (eof-object? consumed-n) + (set! peeked (- consumed-n 1)))))]) + (wrap-binary-input-port p + (and get-position + (lambda () + (let ([v (get-position)]) + (- v peeked)))) + (and set-position! + (lambda (pos) + ;; flush peeked + (let loop () + (unless (zero? peeked) + (read-byte-or-special p) + (loop))) + ;; set position + (set-position! pos))) + #t))) + + +(define (make-custom-textual-input-port id read! get-position set-position! close) + (make-textual-input-port + (make-custom-binary-input-port + id + (let-values ([(in out) (make-pipe)]) + (lambda (bstr offset len) + (let loop () + (let ([n (read-bytes-avail!* bstr in offset len)]) + (if (zero? n) + (let ([str (make-string (bytes-length bstr))]) + (let ([len (read! str 0 (bytes-length bstr))]) + (if (zero? len) + 0 + (begin + (write-string (substring str 0 len) out) + (loop))))) + n))))) + get-position + set-position! + (or close void)) + #f)) + +;; ---------------------------------------- + +(define (get-u8 p) + (unless (binary-port? p) + (raise-type-error 'get-u8 "binary port" p)) + (read-byte p)) + +(define (lookahead-u8 p) + (unless (binary-port? p) + (raise-type-error 'lookahead-u8 "binary port" p)) + (peek-byte p 0)) + +(define (get-bytevector-n p cnt) + (unless (binary-port? p) + (raise-type-error 'get-bytevector-n "binary port" p)) + (read-bytes cnt p)) + +(define (get-bytevector-n! p bytes start end) + (unless (binary-port? p) + (raise-type-error 'get-bytevector-n! "binary port" p)) + (read-bytes! bytes p start end)) + +(define (get-bytevector-some p) + (unless (binary-port? p) + (raise-type-error 'get-bytevector-some "binary port" p)) + (let ([bytes (make-bytes 4096)]) + (let ([n (read-bytes-avail! bytes p)]) + (if (eof-object? n) + n + (subbytes bytes 0 n))))) + +(define (get-bytevector-all p) + (unless (binary-port? p) + (raise-type-error 'get-bytevector-all "binary port" p)) + (let ([p2 (open-output-bytes)]) + (copy-port p p2) + (get-output-bytes p2 #t))) + +;; ---------------------------------------- + +(define (get-char p) + (unless (textual-port? p) + (raise-type-error 'get-char "textual port" p)) + (read-char p)) + +(define (lookahead-char p) + (unless (textual-port? p) + (raise-type-error 'lookahead-char "textual port" p)) + (peek-char p)) + +(define (get-string-n p cnt) + (unless (textual-port? p) + (raise-type-error 'get-string-n "textual port" p)) + (read-string cnt p)) + +(define (get-string-n! p str start end) + (unless (textual-port? p) + (raise-type-error 'get-string-n! "textual port" p)) + (read-string! str p start end)) + +(define (get-string-all p) + (unless (textual-port? p) + (raise-type-error 'get-string-all "textual port" p)) + (let ([p2 (open-output-bytes)]) + (copy-port p p2) + (get-output-string p2))) + +(define (get-line p) + (unless (textual-port? p) + (raise-type-error 'get-line "textual port" p)) + (read-line p 'linefeed)) + +(define (get-datum p) + (unless (textual-port? p) + (raise-type-error 'get-datum "textual port" p)) + (let loop ([v (with-r6rs-reader-parameters (lambda () (read p)))]) + (cond + [(pair? v) (mcons (loop (car v)) + (loop (cdr v)))] + [(vector? v) (list->vector + (map loop (vector->list v)))] + [else v]))) + +;; ---------------------------------------- + +(define (flush-output-port p) + (flush-output p)) + +(define (output-port-buffer-mode p) + (file-stream-buffer-mode p)) + +(define (do-open-file-output-port who + filename + options + buffer-mode + maybe-transcoder + open-output-file + file-position + wrap-binary-port) + (unless (enum-set=? (enum-set-universe options) + (enum-set-universe (file-options))) + (raise-type-error who "file-options enum set" options)) + (unless (enum-set-member? buffer-mode (-buffer-modes none line block)) + (raise-type-error who "'none, 'line, or 'block" buffer-mode)) + (when maybe-transcoder + (unless (transcoder? maybe-transcoder) + (raise-type-error who "transcoder or #f" maybe-transcoder))) + (let ([exists-mode (cond + [(or (enum-set=? options (file-options no-create no-fail no-truncate)) + (enum-set=? options (file-options no-create no-truncate))) + 'update] + [(enum-set=? options (file-options no-fail no-truncate)) + 'can-update] + [(enum-set-member? 'no-create options) ; no-create, no-create + no-fail + 'must-truncate] + [(enum-set-member? 'no-fail options) ; no-fail + 'truncate] + [else ; no-truncate, + 'error])]) + (let ([p (with-handlers ([exn:fail:filesystem? + (lambda (exn) + (if (and (or (eq? exists-mode 'update) + (eq? exists-mode 'must-truncate)) + (not (file-exists? filename))) + (raise + (make-exn:fail:filesystem:exists-not + (exn-message exn) + (exn-continuation-marks exn) + filename)) + (raise exn)))]) + (open-output-file filename #:exists exists-mode))]) + (file-stream-buffer-mode p buffer-mode) + (if maybe-transcoder + (transcoded-port p maybe-transcoder) + (wrap-binary-port p + (and file-position (lambda () (file-position p))) + (and file-position (lambda (pos) (file-position p pos))) + #t))))) + +(define (open-file-output-port filename + [options (file-options)] + [buffer-mode 'block] + [maybe-transcoder #f]) + (do-open-file-output-port 'open-file-output-port + filename + options + buffer-mode + maybe-transcoder + open-output-file + file-position + wrap-binary-output-port)) + +(define (open-bytevector-output-port [maybe-transcoder #f]) + (when maybe-transcoder + (unless (transcoder? maybe-transcoder) + (raise-type-error 'open-bytevector-output-port "transcoder or #f" maybe-transcoder))) + (let* ([p (open-output-bytes)] + [p2 (if maybe-transcoder + (transcoded-port p maybe-transcoder) + (wrap-binary-output-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #t))]) + (values + p2 + (lambda () + (unless (port-closed? p2) + (flush-output p2)) + (get-output-bytes p #t))))) + +(define (call-with-bytevector-output-port proc [maybe-transcoder #f]) + (let-values ([(p get) (open-bytevector-output-port maybe-transcoder)]) + (proc p) + (close-output-port p) + (get))) + +(define (open-string-output-port) + (let ([p (open-output-string)]) + (values + (transcoded-port p utf8-transcoder) + (lambda () + (bytes->string/utf-8 (get-output-bytes p #t)))))) + +(define (call-with-string-output-port proc) + (let-values ([(p get) (open-string-output-port)]) + (proc p) + (close-output-port p) + (get))) + +(define standard-output-port + (let ([p (current-output-port)]) + (lambda () + (wrap-binary-output-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #f)))) + + +(define standard-error-port + (let ([p (current-error-port)]) + (lambda () + (wrap-binary-output-port p + (lambda () (file-position p)) + (lambda (pos) (file-position p pos)) + #f)))) + +(define output-ports (make-weak-hasheq)) + +(define (r6rs:current-output-port) + (convert-output-port (current-output-port))) + +(define (r6rs:current-error-port) + (convert-output-port (current-error-port))) + +(define (convert-output-port p) + (cond + [(textual-port? p) p] + [(hash-ref output-ports p #f) + => ephemeron-value] + [else + (let ([p2 (transcoded-port p utf8-transcoder)]) + (hash-set! output-ports p (make-ephemeron p p2)) + p2)])) + +(define (make-custom-binary-output-port id write! get-position set-position! close) + (wrap-binary-output-port + (make-output-port + id + always-evt ;; assuming that it never blocks! + (lambda (bytes start end can-block/buffer? enable-break?) + (if (= start end) + 0 + (write! bytes start end))) + (or close void) + #f + #f + #f + #f + void + 1 + #f) + get-position + set-position! + #t)) + +(define (make-custom-textual-output-port id write! get-position set-position! close) + (make-textual-output-port + (wrap-binary-output-port + (make-output-port + id + always-evt ;; assuming that it never blocks! + (let-values ([(in out) (make-pipe)] + [(c) #f] + [(cvt-buffer) #f] + [(buffer) #f]) + (lambda (bytes start end can-block/buffer? enable-break?) + (let ([direct? (zero? (pipe-content-length in))]) + (if (and direct? + (bytes-utf-8-length bytes #f start end)) + ;; No old bytes saved, and bytes to write form a complete + ;; UTF-8 encoding, so we can write directly: + (let* ([s (bytes->string/utf-8 bytes #f start end)] + [len (string-length s)]) + (when (positive? len) + (write! s 0 len))) + ;; Partial or need to use existing bytes, so use pipe + (begin + (write-bytes bytes out start end) + (unless buffer + (set! c (bytes-open-converter "UTF-8-permissive" "UTF-8")) + (set! buffer (make-bytes 4096)) + (set! cvt-buffer (make-bytes 4096))) + (let loop () + (let ([n (peek-bytes-avail!* buffer 0 in)]) + (let ([more? ((pipe-content-length in) . > . n)]) + (let-values ([(amt used status) (bytes-convert c buffer 0 n cvt-buffer)]) + (when (positive? amt) + (read-bytes! buffer in 0 amt) + (let* ([s (bytes->string/utf-8 buffer #f 0 amt)] + [len (string-length s)]) + (when (positive? len) + (write! s 0 (string-length s))))) + (when (eq? status 'error) + ;; Discard an erroneous byte + (read-byte in)) + ;; Loop + (unless (and (eq? status 'complete) + (not more?)) + (loop))))))))) + (- end start))) + (or close void) + #f + #f + #f + #f + void + 1 + #f) + get-position + set-position! + #t) + #f)) + +;; ---------------------------------------- + +(define (put-u8 port b) + (unless (binary-port? port) + (raise-type-error 'put-u8 "binary port" port)) + (write-byte b port)) + +(define (put-bytevector port bytes [start 0] [count (- (bytes-length bytes) start)]) + (unless (binary-port? port) + (raise-type-error 'put-bytevector "binary port" port)) + (write-bytes bytes port start (+ start count))) + +(define (put-char port ch) + (unless (textual-port? port) + (raise-type-error 'put-u8 "textual port" port)) + (write-char ch port)) + +(define (put-string port str [start 0] [count (- (string-length str) start)]) + (unless (textual-port? port) + (raise-type-error 'put-string "textual port" port)) + (write-string (substring str start (+ start count)) port)) + +(define (put-datum port v) + (unless (textual-port? port) + (raise-type-error 'put-datum "textual port" port)) + (parameterize ([print-mpair-curly-braces #f] + [pretty-print-columns 'infinity] + [pretty-print-size-hook + (lambda (v write? p) + (cond + [(symbol? v) + (let ([s (symbol->string v)]) + (and (not (regexp-match (force rx:id) s)) + (for/fold ([len 0]) + ([c (in-string s)] + [pos (in-naturals)]) + (+ len + (if (or (char-alphabetic? c) + (and (char-numeric? c) + (positive? pos))) + 1 + (+ 3 (string-length + (number->string (char->integer c) 16))))))))] + [(string? v) + (and (for/or ([c (in-string v)]) + (not (or (char-graphic? c) + (char-blank? c)))) + (for/fold ([w 2]) + ([c (in-string v)]) + (cond + [(eq? c #\") 2] + [(eq? c #\\) 2] + [(char-graphic? c) 1] + [(char-blank? c) 1] + [(eq? c #\newline) 2] + [(eq? c #\return) 2] + [else 9])))] + [(char? v) + (case v + [(#\u7) 7] ; #\alarm + [(#\u1B) 5] ; #\esc + [(#\u7F) 8] ; #\delete + [else (and (not (char-graphic? v)) + (+ 3 + (if ((char->integer v) . < . #x10000) + 4 + 6)))])] + [(bytes? v) (+ 5 + (sub1 (bytes-length v)) + (for/fold ([len 0]) + ([b (in-bytes v)]) + (+ len (cond + [(b . < . 10) 1] + [(b . < . 100) 2] + [else 3]))))] + [else #f]))] + [pretty-print-print-hook + (lambda (v write? p) + (cond + [(symbol? v) + (for ([c (in-string (symbol->string v))] + [pos (in-naturals)]) + (if (or (char-alphabetic? c) + (and (char-numeric? c) + (positive? pos))) + (display c p) + (begin + (display "\\x" p) + (display (number->string (char->integer c) 16) p) + (display ";" p))))] + [(string? v) + (write-char #\" p) + (for ([c (in-string v)]) + (cond + [(eq? c #\") (display "\\\"" p)] + [(eq? c #\\) (display "\\\\" p)] + [(char-graphic? c) (write-char c p)] + [(char-blank? c) (write-char c p)] + [(eq? c #\newline) (display "\\n" p)] + [(eq? c #\return) (display "\\r" p)] + [else + (display "\\x" p) + (let ([s (format "00000~x" (char->integer c))]) + (display (substring s (- (string-length s) 6)) p) + (write-char #\; p))])) + (write-char #\" p)] + [(char? v) + (case v + [(#\u7) (display "#\\alarm" p)] + [(#\u1B) (display "#\\esc" p)] + [(#\u7F) (display "#\\delete" p)] + [else + (display "#\\x" p) + (let ([n (number->string (char->integer v) 16)]) + (display (make-string + (- (if ((string-length n) . <= . 4) + 4 + 6) + (string-length n)) + #\0) + p) + (display n p))])] + [(bytes? v) + (display "#vu8(" p) + (if (zero? (bytes-length v)) + (display ")" p) + (begin + (display (bytes-ref v 0) p) + (for ([b (in-bytes v)] + [i (in-naturals)]) + (unless (zero? i) + (display " " p) + (display b p))) + (display ")" p)))]))]) + (pretty-print v port))) + +;; ---------------------------------------- + +(define (open-file-input/output-port filename + [options (file-options)] + [buffer-mode 'block] + [maybe-transcoder #f]) + (do-open-file-output-port 'open-file-input/output-port + filename + options + (if (eq? buffer-mode 'line) + 'block + buffer-mode) + maybe-transcoder + (lambda (name #:exists mode) + (let-values ([(in out) (open-input-output-file name #:exists mode)]) + (file-stream-buffer-mode out buffer-mode) + (make-dual-port in out))) + ;; Input and output buffering make `file-position' iffy. + (if (eq? buffer-mode 'none) + (case-lambda + [(p) (file-position (dual-port-in p))] + [(p pos) + (flush-output p) + (file-position (dual-port-in p) pos)]) + #f) + wrap-binary-input/output-port)) + +(define (make-make-custom-input/output-port + make-custom-input-port + make-custom-output-port) + (lambda (id read! write! get-pos set-pos! close) + (let* ([closed-one? #f] + [close (and close + (lambda () + (if closed-one? + (close) + (set! closed-one? #t))))]) + (let ([in (make-custom-input-port id read! get-pos set-pos! close)] + [out (make-custom-output-port id write! get-pos set-pos! close)]) + (make-dual-port in out))))) + +(define make-custom-binary-input/output-port + (make-make-custom-input/output-port + make-custom-binary-input-port + make-custom-binary-output-port)) + +(define make-custom-textual-input/output-port + (make-make-custom-input/output-port + make-custom-textual-input-port + make-custom-textual-output-port)) + +(define (bytevector->string bv t) + (unless (transcoder? t) + (raise-type-error 'bytevector->string "transcoder" t)) + (let ([p #f]) + (dynamic-wind + (lambda () + (set! p (open-bytevector-input-port bv t))) + (lambda () + (apply + string-append + (let loop () + (let ([s (get-string-n p 4096)]) + (if (eof-object? s) + null + (cons s (loop))))))) + (lambda () (close-input-port p))))) + +(define (string->bytevector s t) + (unless (transcoder? t) + (raise-type-error 'string->bytevector "transcoder" t)) + (let ([p #f] + [result #f]) + (dynamic-wind + (lambda () + (set!-values (p result) (open-bytevector-output-port t))) + (lambda () + (put-string p s) + (result)) + (lambda () (close-output-port p))))) + +;; ---------------------------------------- + +(define (r6rs-port->port p) + (cond [(binary-input-port? p) + ((binary-input-port-disconnect p))] + [(binary-output-port? p) + ((binary-output-port-disconnect p))] + [else + (raise-type-error 'r6rs-port->port "binary input or output port" p)])) diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss index 8772bd08b1..eab55d3f07 100644 --- a/collects/rnrs/io/ports-6.ss +++ b/collects/rnrs/io/ports-6.ss @@ -1,1125 +1,5 @@ #lang scheme/base -;; FIXME: newline decoding - -(require rnrs/enums-6 - rnrs/conditions-6 - r6rs/private/io-conds - r6rs/private/readtable - r6rs/private/exns - scheme/port - scheme/pretty - scheme/promise) - -(provide (all-from-out r6rs/private/io-conds) - file-options - buffer-mode buffer-mode? - latin-1-codec utf-8-codec utf-16-codec - eol-style native-eol-style - &i/o-decoding make-i/o-decoding-error i/o-decoding-error? - &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char - error-handling-mode - (rename-out [r6rs:make-transcoder make-transcoder]) - transcoder-codec - transcoder-eol-style - transcoder-error-handling-mode - native-transcoder - bytevector->string - string->bytevector - eof-object - eof-object? - port? - port-transcoder - textual-port? - binary-port? - transcoded-port - port-has-port-position? - port-position - port-has-set-port-position!? - set-port-position! - close-port - call-with-port - input-port? - port-eof? - open-file-input-port - open-bytevector-input-port - open-string-input-port - standard-input-port - (rename-out [r6rs:current-input-port current-input-port]) - make-custom-binary-input-port - make-custom-textual-input-port - get-u8 - lookahead-u8 - get-bytevector-n - get-bytevector-n! - get-bytevector-some - get-bytevector-all - get-char - lookahead-char - get-string-n - get-string-n! - get-string-all - get-line - get-datum - output-port? - flush-output-port - output-port-buffer-mode - open-file-output-port - open-bytevector-output-port - call-with-bytevector-output-port - open-string-output-port - call-with-string-output-port - standard-output-port - standard-error-port - (rename-out [r6rs:current-output-port current-output-port] - [r6rs:current-error-port current-error-port]) - make-custom-binary-output-port - make-custom-textual-output-port - put-u8 - put-bytevector - put-char - put-string - put-datum - open-file-input/output-port - make-custom-binary-input/output-port - make-custom-textual-input/output-port) - -;; ---------------------------------------- - -(define-enumeration -file-option (no-create no-fail no-truncate) - file-options) - -(define-enumeration buffer-mode (none line block) - -buffer-modes) - -(define (buffer-mode? m) - (enum-set-member? m (-buffer-modes none line block))) - -(define-enumeration eol-style (lf cr crlf nel crnel ls none) - -eol-styles) - -(define-struct codec (enc)) -(define latin-1 (make-codec "latin1")) -(define utf-8 (make-codec "utf-8")) -(define utf-16 (make-codec "utf-16")) - -(define (latin-1-codec) latin-1) -(define (utf-8-codec) utf-8) -(define (utf-16-codec) utf-16) - -(define (native-eol-style) - (if (eq? (system-type) 'windows) - 'crlf - 'lf)) - -(define-condition-type &i/o-decoding &i/o-port - make-i/o-decoding-error i/o-decoding-error?) - -(define-condition-type &i/o-encoding &i/o-port - make-i/o-encoding-error i/o-encoding-error? - (char i/o-encoding-error-char)) - -(define-enumeration error-handling-mode (ignore raise replace) - -handling-modes) - -(define-struct transcoder (codec eol-style error-handling-mode)) - -(define (r6rs:make-transcoder codec - [eol-style (native-eol-style)] - [handling-mode 'replace]) - (unless (codec? codec) - (raise-type-error 'make-transcoder "codec" codec)) - (unless (enum-set-member? eol-style (-eol-styles lf cr crlf nel crnel ls none)) - (raise-type-error 'make-transcoder "'lf, 'cr, 'crlf, 'nel, 'crnel, 'ls, or 'none" eol-style)) - (unless (enum-set-member? handling-mode (-handling-modes ignore raise replace)) - (raise-type-error 'make-transcoder "'ignore, 'raise, or 'replace" eol-style)) - (make-transcoder codec eol-style handling-mode)) - -(define utf8-transcoder - (make-transcoder utf-8 'none '?)) - -(define (native-transcoder) - utf8-transcoder) - -(define (eof-object) eof) - -;; ---------------------------------------- - -(define (make-disconnectable-input-port port close?) - (define disconnected? #f) - (define (check-disconnect) - (when disconnected? - (error 'read-byte "cannot read for transcoded binary port"))) - (values - (make-input-port - (object-name port) - (lambda (bytes) - (check-disconnect) - (let ([n (read-bytes-avail!* bytes port)]) - (if (eq? n 0) - (wrap-evt port (lambda (v) 0)) - n))) - (lambda (bytes skip evt) - (check-disconnect) - (let ([n (peek-bytes-avail! bytes skip evt port)]) - (if (eq? n 0) - (wrap-evt port (lambda (v) 0)) - n))) - (lambda () - (unless disconnected? - (when close? - (close-input-port port)))) - (and (port-provides-progress-evts? port) - (lambda () - (check-disconnect) - (port-progress-evt port))) - (and (port-provides-progress-evts? port) - (lambda (k evt done) - (port-commit-peeked k evt done port))) - (lambda () - (check-disconnect) - (port-next-location port)) - (lambda () - (check-disconnect) - (port-count-lines! port)) - 1 - (case-lambda - [() (check-disconnect) (file-stream-buffer-mode port)] - [(mode) (check-disconnect) (file-stream-buffer-mode port - (if (eq? mode 'line) 'block mode))])) - (lambda () - (set! disconnected? #t) - port))) - -(define (make-disconnectable-output-port port close?) - (define disconnected? #f) - (define (check-disconnect) - (when disconnected? - (error 'read-byte "cannot read for transcoded binary port"))) - (values - (make-output-port - (object-name port) - port - (lambda (bytes start end can-buffer/block? enable-breaks?) - (check-disconnect) - (if (= start end) - (begin - (flush-output port) - 0) - (cond - [enable-breaks? - (parameterize-break #t (write-bytes (subbytes bytes start end) port))] - [can-buffer/block? - (write-bytes (subbytes bytes start end) port)] - [else - (write-bytes-avail* (subbytes bytes start end) port)]))) - (lambda () - (unless disconnected? - (when close? - (close-output-port port)))) - (and (port-writes-special? port) - (lambda (v can-buffer/block? enable-breaks?) - (check-disconnect) - (cond - [enable-breaks? - (parameterize-break #t (write-special v port))] - [can-buffer/block? - (write-special v port)] - [else - (write-special-avail* v port)]))) - (and (port-writes-atomic? port) - (lambda (bytes start end) - (check-disconnect) - (write-bytes-avail-evt bytes port start end))) - (and (port-writes-special? port) - (port-writes-atomic? port) - (lambda (v) - (check-disconnect) - (write-special-evt v port))) - (lambda () - (check-disconnect) - (port-next-location port)) - (lambda () - (check-disconnect) - (port-count-lines! port)) - 1 - (case-lambda - [() (check-disconnect) (file-stream-buffer-mode port)] - [(mode) (check-disconnect) (file-stream-buffer-mode port mode)])) - (lambda () - (set! disconnected? #t) - port))) - -;; For merging two kinds of ports: -(define-struct dual-port (in out) - #:property prop:input-port 0 - #:property prop:output-port 1) - -;; R6RS functions that generate binary ports wrap them with `binary-...-port' -;; structures, so that the binary ports can be "closed" by `transcoded-port'. -(define-struct binary-input-port (port disconnect get-pos set-pos!) - #:property prop:input-port 0) -(define-struct binary-output-port (port disconnect get-pos set-pos!) - #:property prop:output-port 0) -(define-struct (binary-input/output-port binary-input-port) (out-port out-disconnect) - #:property prop:output-port 0) - -;; Textual ports are transcoded -(define-struct textual-input-port (port transcoder) - #:property prop:input-port 0) -(define-struct textual-output-port (port transcoder) - #:property prop:output-port 0) -(define-struct (textual-input/output-port textual-input-port) (out-port) - #:property prop:output-port 0) - -(define (port-transcoder port) - (cond - [(dual-port? port) (port-transcoder (dual-port-in port))] - [(textual-input-port? port) (textual-input-port-transcoder port)] - [(textual-output-port? port) (textual-output-port-transcoder port)] - [(input-port? port) #f] - [(output-port? port) #f] - [else (raise-type-error 'port-transcoder "port" port)])) - -(define (textual-port? v) - (if (port? v) - (or (textual-input-port? v) - (textual-output-port? v) - (and (dual-port? v) - (textual-port? (dual-port-in v)))) - (raise-type-error 'textual-port? "port" v))) - -(define (binary-port? v) - (if (port? v) - (not (or (textual-input-port? v) - (textual-output-port? v) - (and (dual-port? v) - (textual-port? (dual-port-in v))))) - (raise-type-error 'binary-port? "port" v))) - -(define (wrap-binary-input-port p get-pos set-pos! close?) - (let-values ([(p disconnect) (make-disconnectable-input-port p close?)]) - (make-binary-input-port p disconnect get-pos set-pos!))) - -(define (wrap-binary-output-port p get-pos set-pos! close?) - (let-values ([(p disconnect) (make-disconnectable-output-port p close?)]) - (make-binary-output-port p disconnect get-pos set-pos!))) - -(define (wrap-binary-input/output-port p get-pos set-pos! close?) - (let-values ([(p disconnect) (make-disconnectable-input-port p #t)] - [(out-p out-disconnect) (make-disconnectable-output-port p #t)]) - (make-binary-input/output-port p disconnect get-pos set-pos! - out-p out-disconnect))) - -(define (no-op-transcoder? t) - (or (eq? t utf8-transcoder) - (and (eq? utf-8 (transcoder-codec t)) - (eq? (transcoder-eol-style t) 'none) - (eq? 'replace (transcoder-error-handling-mode t))))) - -(define (transcode-input p t) - (let ([p (if (binary-input-port? p) - ((binary-input-port-disconnect p)) - p)]) - (if (no-op-transcoder? t) - p - (letrec ([self - (reencode-input-port p - (codec-enc (transcoder-codec t)) - (case (transcoder-error-handling-mode t) - [(raise) #f] - [(ignore) #""] - [(replace) (string->bytes/utf-8 "\uFFFD")]) - #t - (object-name p) - (not (eq? (transcoder-eol-style t) 'none)) - (lambda (msg port) - (raise - (condition - (make-message-condition - (format "~a: ~e" msg port)) - (make-i/o-decoding-error - self)))))]) - self)))) - -(define (transcode-output p t) - (let ([p (cond - [(binary-output-port? p) - ((binary-output-port-disconnect p))] - [(binary-input/output-port? p) - ((binary-input/output-port-out-disconnect p))] - [else p])]) - (if (no-op-transcoder? t) - p - (letrec ([self - (reencode-output-port p - (codec-enc (transcoder-codec t)) - (case (transcoder-error-handling-mode t) - [(raise) #f] - [(ignore) #""] - [(replace) (string->bytes/utf-8 "\uFFFD")]) - #t - (object-name p) - (case (transcoder-eol-style t) - [(lf none) #f] - [(cr) #"\r"] - [(crlf) #"\r\n"] - [(nel) (string->bytes/utf-8 "\u85")] - [(crnel) (string->bytes/utf-8 "\r\u85")] - [(ls) (string->bytes/utf-8 "\u2028")] - [else (error 'transcoded-port "unknown eol style: ~e" - (transcoder-eol-style t))]) - (lambda (msg port) - (raise - (condition - (make-message-condition - (format "~a: ~e" msg port)) - (make-i/o-encoding-error - self - #\?)))))]) - self)))) - -(define (transcoded-port p t) - (unless (and (port? p) - (binary-port? p)) - (raise-type-error 'transcoded-port "binary port" p)) - (unless (transcoder? t) - (raise-type-error 'transcoded-port "transcoder" t)) - (cond - [(and (input-port? p) (output-port? p)) - (make-textual-input/output-port (transcode-input p t) - t - (transcode-output p t))] - [(input-port? p) - (make-textual-input-port (transcode-input p t) t)] - [(output-port? p) - (make-textual-output-port (transcode-output p t) t)])) - -(define (port-has-port-position? p) - (unless (port? p) - (raise-type-error 'port-has-port-position? "port" p)) - (cond - [(binary-input-port? p) - (and (binary-input-port-get-pos p) #t)] - [(binary-output-port? p) - (and (binary-output-port-get-pos p) #t)] - [(textual-input-port? p) - (port-has-port-position? (textual-input-port-port p))] - [(textual-output-port? p) - (port-has-port-position? (textual-output-port-port p))] - [(dual-port? p) - (port-has-port-position? (dual-port-in p))] - [else #t])) - -(define (port-position p) - (cond - [(binary-input-port? p) - ((binary-input-port-get-pos p))] - [(binary-output-port? p) - ((binary-output-port-get-pos p))] - [(textual-input-port? p) - (port-position (textual-input-port-port p))] - [(textual-output-port? p) - (port-position (textual-output-port-port p))] - [(dual-port? p) - (port-position (dual-port-in p))] - [else (file-position p)])) - -(define (port-has-set-port-position!? p) - (unless (port? p) - (raise-type-error 'port-has-port-set-position!? "port" p)) - (cond - [(binary-input-port? p) - (and (binary-input-port-set-pos! p) #t)] - [(binary-output-port? p) - (and (binary-output-port-set-pos! p) #t)] - [(textual-input-port? p) - (port-has-set-port-position!? (textual-input-port-port p))] - [(textual-output-port? p) - (port-has-set-port-position!? (textual-output-port-port p))] - [(dual-port? p) - (port-has-set-port-position!? (dual-port-in p))] - [else - ;; we could also allow string ports here - (file-stream-port? p)])) - -(define (set-port-position! p pos) - (unless (and (port? p) - (port-has-set-port-position!? p)) - (raise-type-error 'set-port-position! "port with settable position" p)) - (cond - [(binary-input-port? p) - ((binary-input-port-set-pos! p) pos)] - [(binary-output-port? p) - ((binary-output-port-set-pos! p) pos)] - [(textual-input-port? p) - (set-port-position! (textual-input-port-port p) pos)] - [(textual-output-port? p) - (set-port-position! (textual-output-port-port p) pos)] - [(dual-port? p) - (set-port-position! (dual-port-in p) pos)] - [else - (file-position p pos)])) - -(define (call-with-port port proc) - (unless (port? port) - (raise-type-error 'call-with-port "port" port)) - (begin0 - (proc port) - (close-port port))) - -(define (close-port port) - (when (input-port? port) - (close-input-port port)) - (when (output-port? port) - (close-output-port port))) - -;; ---------------------------------------- - -(define (port-eof? p) - (eof-object? (peek-byte p))) - -(define (open-file-input-port filename - [options (file-options)] - [buffer-mode 'block] - [maybe-transcoder #f]) - (unless (enum-set=? (enum-set-universe options) - (enum-set-universe (file-options))) - (raise-type-error 'open-file-input-port "file-options enum set" options)) - (unless (enum-set-member? buffer-mode (-buffer-modes none line block)) - (raise-type-error 'open-file-input-port "'none, 'line, or 'block" buffer-mode)) - (when maybe-transcoder - (unless (transcoder? maybe-transcoder) - (raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder))) - (let ([p (open-input-file filename)]) - (file-stream-buffer-mode p (if (eq? buffer-mode 'line) - 'block - buffer-mode)) - (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-input-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #t)))) - -(define (open-bytevector-input-port bytes [maybe-transcoder #f]) - (unless (bytes? bytes) - (raise-type-error 'open-bytevector-input-port "bytevector" bytes)) - (when maybe-transcoder - (unless (transcoder? maybe-transcoder) - (raise-type-error 'open-bytevector-input-port "transcoder or #f" maybe-transcoder))) - (let ([p (open-input-bytes bytes)]) - (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-input-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #t)))) - -(define (open-string-input-port str) - (unless (string? str) - (raise-type-error 'open-bytevector-input-port "string" str)) - (let ([p (open-input-string str)]) - (transcoded-port - (wrap-binary-input-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #t) - utf8-transcoder))) - -(define standard-input-port - (let ([p (current-input-port)]) - (lambda () - (wrap-binary-input-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #f)))) - -(define input-ports (make-weak-hasheq)) - -(define (r6rs:current-input-port) - (let ([p (current-input-port)]) - (cond - [(textual-port? p) p] - [(hash-ref input-ports p #f) - => ephemeron-value] - [else - (let ([p2 (transcoded-port p utf8-transcoder)]) - (hash-set! input-ports p (make-ephemeron p p2)) - p2)]))) - -(define (make-custom-binary-input-port id read! get-position set-position! close) - (let* ([peeked 0] - [p (make-input-port/read-to-peek - id - (lambda (bytes) - (let ([v (read! bytes 0 (bytes-length bytes))]) - (set! peeked (+ peeked v)) - (if (zero? v) - eof - v))) - #f - (or close void) - #f void 1 - #f #f - (lambda (consumed-n) - (unless (eof-object? consumed-n) - (set! peeked (- consumed-n 1)))))]) - (wrap-binary-input-port p - (and get-position - (lambda () - (let ([v (get-position)]) - (- v peeked)))) - (and set-position! - (lambda (pos) - ;; flush peeked - (let loop () - (unless (zero? peeked) - (read-byte-or-special p) - (loop))) - ;; set position - (set-position! pos))) - #t))) - - -(define (make-custom-textual-input-port id read! get-position set-position! close) - (make-textual-input-port - (make-custom-binary-input-port - id - (let-values ([(in out) (make-pipe)]) - (lambda (bstr offset len) - (let loop () - (let ([n (read-bytes-avail!* bstr in offset len)]) - (if (zero? n) - (let ([str (make-string (bytes-length bstr))]) - (let ([len (read! str 0 (bytes-length bstr))]) - (if (zero? len) - 0 - (begin - (write-string (substring str 0 len) out) - (loop))))) - n))))) - get-position - set-position! - (or close void)) - #f)) - -;; ---------------------------------------- - -(define (get-u8 p) - (unless (binary-port? p) - (raise-type-error 'get-u8 "binary port" p)) - (read-byte p)) - -(define (lookahead-u8 p) - (unless (binary-port? p) - (raise-type-error 'lookahead-u8 "binary port" p)) - (peek-byte p 0)) - -(define (get-bytevector-n p cnt) - (unless (binary-port? p) - (raise-type-error 'get-bytevector-n "binary port" p)) - (read-bytes cnt p)) - -(define (get-bytevector-n! p bytes start end) - (unless (binary-port? p) - (raise-type-error 'get-bytevector-n! "binary port" p)) - (read-bytes! bytes p start end)) - -(define (get-bytevector-some p) - (unless (binary-port? p) - (raise-type-error 'get-bytevector-some "binary port" p)) - (let ([bytes (make-bytes 4096)]) - (let ([n (read-bytes-avail! bytes p)]) - (if (eof-object? n) - n - (subbytes bytes 0 n))))) - -(define (get-bytevector-all p) - (unless (binary-port? p) - (raise-type-error 'get-bytevector-all "binary port" p)) - (let ([p2 (open-output-bytes)]) - (copy-port p p2) - (get-output-bytes p2 #t))) - -;; ---------------------------------------- - -(define (get-char p) - (unless (textual-port? p) - (raise-type-error 'get-char "textual port" p)) - (read-char p)) - -(define (lookahead-char p) - (unless (textual-port? p) - (raise-type-error 'lookahead-char "textual port" p)) - (peek-char p)) - -(define (get-string-n p cnt) - (unless (textual-port? p) - (raise-type-error 'get-string-n "textual port" p)) - (read-string cnt p)) - -(define (get-string-n! p str start end) - (unless (textual-port? p) - (raise-type-error 'get-string-n! "textual port" p)) - (read-string! str p start end)) - -(define (get-string-all p) - (unless (textual-port? p) - (raise-type-error 'get-string-all "textual port" p)) - (let ([p2 (open-output-bytes)]) - (copy-port p p2) - (get-output-string p2))) - -(define (get-line p) - (unless (textual-port? p) - (raise-type-error 'get-line "textual port" p)) - (read-line p 'linefeed)) - -(define (get-datum p) - (unless (textual-port? p) - (raise-type-error 'get-datum "textual port" p)) - (let loop ([v (with-r6rs-reader-parameters (lambda () (read p)))]) - (cond - [(pair? v) (mcons (loop (car v)) - (loop (cdr v)))] - [(vector? v) (list->vector - (map loop (vector->list v)))] - [else v]))) - -;; ---------------------------------------- - -(define (flush-output-port p) - (flush-output p)) - -(define (output-port-buffer-mode p) - (file-stream-buffer-mode p)) - -(define (do-open-file-output-port who - filename - options - buffer-mode - maybe-transcoder - open-output-file - file-position - wrap-binary-port) - (unless (enum-set=? (enum-set-universe options) - (enum-set-universe (file-options))) - (raise-type-error who "file-options enum set" options)) - (unless (enum-set-member? buffer-mode (-buffer-modes none line block)) - (raise-type-error who "'none, 'line, or 'block" buffer-mode)) - (when maybe-transcoder - (unless (transcoder? maybe-transcoder) - (raise-type-error who "transcoder or #f" maybe-transcoder))) - (let ([exists-mode (cond - [(or (enum-set=? options (file-options no-create no-fail no-truncate)) - (enum-set=? options (file-options no-create no-truncate))) - 'update] - [(enum-set=? options (file-options no-fail no-truncate)) - 'can-update] - [(enum-set-member? 'no-create options) ; no-create, no-create + no-fail - 'must-truncate] - [(enum-set-member? 'no-fail options) ; no-fail - 'truncate] - [else ; no-truncate, - 'error])]) - (let ([p (with-handlers ([exn:fail:filesystem? - (lambda (exn) - (if (and (or (eq? exists-mode 'update) - (eq? exists-mode 'must-truncate)) - (not (file-exists? filename))) - (raise - (make-exn:fail:filesystem:exists-not - (exn-message exn) - (exn-continuation-marks exn) - filename)) - (raise exn)))]) - (open-output-file filename #:exists exists-mode))]) - (file-stream-buffer-mode p buffer-mode) - (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-port p - (and file-position (lambda () (file-position p))) - (and file-position (lambda (pos) (file-position p pos))) - #t))))) - -(define (open-file-output-port filename - [options (file-options)] - [buffer-mode 'block] - [maybe-transcoder #f]) - (do-open-file-output-port 'open-file-output-port - filename - options - buffer-mode - maybe-transcoder - open-output-file - file-position - wrap-binary-output-port)) - -(define (open-bytevector-output-port [maybe-transcoder #f]) - (when maybe-transcoder - (unless (transcoder? maybe-transcoder) - (raise-type-error 'open-bytevector-output-port "transcoder or #f" maybe-transcoder))) - (let* ([p (open-output-bytes)] - [p2 (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-output-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #t))]) - (values - p2 - (lambda () - (unless (port-closed? p2) - (flush-output p2)) - (get-output-bytes p #t))))) - -(define (call-with-bytevector-output-port proc [maybe-transcoder #f]) - (let-values ([(p get) (open-bytevector-output-port maybe-transcoder)]) - (proc p) - (close-output-port p) - (get))) - -(define (open-string-output-port) - (let ([p (open-output-string)]) - (values - (transcoded-port p utf8-transcoder) - (lambda () - (bytes->string/utf-8 (get-output-bytes p #t)))))) - -(define (call-with-string-output-port proc) - (let-values ([(p get) (open-string-output-port)]) - (proc p) - (close-output-port p) - (get))) - -(define standard-output-port - (let ([p (current-output-port)]) - (lambda () - (wrap-binary-output-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #f)))) - - -(define standard-error-port - (let ([p (current-error-port)]) - (lambda () - (wrap-binary-output-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)) - #f)))) - -(define output-ports (make-weak-hasheq)) - -(define (r6rs:current-output-port) - (convert-output-port (current-output-port))) - -(define (r6rs:current-error-port) - (convert-output-port (current-error-port))) - -(define (convert-output-port p) - (cond - [(textual-port? p) p] - [(hash-ref output-ports p #f) - => ephemeron-value] - [else - (let ([p2 (transcoded-port p utf8-transcoder)]) - (hash-set! output-ports p (make-ephemeron p p2)) - p2)])) - -(define (make-custom-binary-output-port id write! get-position set-position! close) - (wrap-binary-output-port - (make-output-port - id - always-evt ;; assuming that it never blocks! - (lambda (bytes start end can-block/buffer? enable-break?) - (if (= start end) - 0 - (write! bytes start end))) - (or close void) - #f - #f - #f - #f - void - 1 - #f) - get-position - set-position! - #t)) - -(define (make-custom-textual-output-port id write! get-position set-position! close) - (make-textual-output-port - (wrap-binary-output-port - (make-output-port - id - always-evt ;; assuming that it never blocks! - (let-values ([(in out) (make-pipe)] - [(c) #f] - [(cvt-buffer) #f] - [(buffer) #f]) - (lambda (bytes start end can-block/buffer? enable-break?) - (let ([direct? (zero? (pipe-content-length in))]) - (if (and direct? - (bytes-utf-8-length bytes #f start end)) - ;; No old bytes saved, and bytes to write form a complete - ;; UTF-8 encoding, so we can write directly: - (let* ([s (bytes->string/utf-8 bytes #f start end)] - [len (string-length s)]) - (when (positive? len) - (write! s 0 len))) - ;; Partial or need to use existing bytes, so use pipe - (begin - (write-bytes bytes out start end) - (unless buffer - (set! c (bytes-open-converter "UTF-8-permissive" "UTF-8")) - (set! buffer (make-bytes 4096)) - (set! cvt-buffer (make-bytes 4096))) - (let loop () - (let ([n (peek-bytes-avail!* buffer 0 in)]) - (let ([more? ((pipe-content-length in) . > . n)]) - (let-values ([(amt used status) (bytes-convert c buffer 0 n cvt-buffer)]) - (when (positive? amt) - (read-bytes! buffer in 0 amt) - (let* ([s (bytes->string/utf-8 buffer #f 0 amt)] - [len (string-length s)]) - (when (positive? len) - (write! s 0 (string-length s))))) - (when (eq? status 'error) - ;; Discard an erroneous byte - (read-byte in)) - ;; Loop - (unless (and (eq? status 'complete) - (not more?)) - (loop))))))))) - (- end start))) - (or close void) - #f - #f - #f - #f - void - 1 - #f) - get-position - set-position! - #t) - #f)) - -;; ---------------------------------------- - -(define (put-u8 port b) - (unless (binary-port? port) - (raise-type-error 'put-u8 "binary port" port)) - (write-byte b port)) - -(define (put-bytevector port bytes [start 0] [count (- (bytes-length bytes) start)]) - (unless (binary-port? port) - (raise-type-error 'put-bytevector "binary port" port)) - (write-bytes bytes port start (+ start count))) - -(define (put-char port ch) - (unless (textual-port? port) - (raise-type-error 'put-u8 "textual port" port)) - (write-char ch port)) - -(define (put-string port str [start 0] [count (- (string-length str) start)]) - (unless (textual-port? port) - (raise-type-error 'put-string "textual port" port)) - (write-string (substring str start (+ start count)) port)) - -(define (put-datum port v) - (unless (textual-port? port) - (raise-type-error 'put-datum "textual port" port)) - (parameterize ([print-mpair-curly-braces #f] - [pretty-print-columns 'infinity] - [pretty-print-size-hook - (lambda (v write? p) - (cond - [(symbol? v) - (let ([s (symbol->string v)]) - (and (not (regexp-match (force rx:id) s)) - (for/fold ([len 0]) - ([c (in-string s)] - [pos (in-naturals)]) - (+ len - (if (or (char-alphabetic? c) - (and (char-numeric? c) - (positive? pos))) - 1 - (+ 3 (string-length - (number->string (char->integer c) 16))))))))] - [(string? v) - (and (for/or ([c (in-string v)]) - (not (or (char-graphic? c) - (char-blank? c)))) - (for/fold ([w 2]) - ([c (in-string v)]) - (cond - [(eq? c #\") 2] - [(eq? c #\\) 2] - [(char-graphic? c) 1] - [(char-blank? c) 1] - [(eq? c #\newline) 2] - [(eq? c #\return) 2] - [else 9])))] - [(char? v) - (case v - [(#\u7) 7] ; #\alarm - [(#\u1B) 5] ; #\esc - [(#\u7F) 8] ; #\delete - [else (and (not (char-graphic? v)) - (+ 3 - (if ((char->integer v) . < . #x10000) - 4 - 6)))])] - [(bytes? v) (+ 5 - (sub1 (bytes-length v)) - (for/fold ([len 0]) - ([b (in-bytes v)]) - (+ len (cond - [(b . < . 10) 1] - [(b . < . 100) 2] - [else 3]))))] - [else #f]))] - [pretty-print-print-hook - (lambda (v write? p) - (cond - [(symbol? v) - (for ([c (in-string (symbol->string v))] - [pos (in-naturals)]) - (if (or (char-alphabetic? c) - (and (char-numeric? c) - (positive? pos))) - (display c p) - (begin - (display "\\x" p) - (display (number->string (char->integer c) 16) p) - (display ";" p))))] - [(string? v) - (write-char #\" p) - (for ([c (in-string v)]) - (cond - [(eq? c #\") (display "\\\"" p)] - [(eq? c #\\) (display "\\\\" p)] - [(char-graphic? c) (write-char c p)] - [(char-blank? c) (write-char c p)] - [(eq? c #\newline) (display "\\n" p)] - [(eq? c #\return) (display "\\r" p)] - [else - (display "\\x" p) - (let ([s (format "00000~x" (char->integer c))]) - (display (substring s (- (string-length s) 6)) p) - (write-char #\; p))])) - (write-char #\" p)] - [(char? v) - (case v - [(#\u7) (display "#\\alarm" p)] - [(#\u1B) (display "#\\esc" p)] - [(#\u7F) (display "#\\delete" p)] - [else - (display "#\\x" p) - (let ([n (number->string (char->integer v) 16)]) - (display (make-string - (- (if ((string-length n) . <= . 4) - 4 - 6) - (string-length n)) - #\0) - p) - (display n p))])] - [(bytes? v) - (display "#vu8(" p) - (if (zero? (bytes-length v)) - (display ")" p) - (begin - (display (bytes-ref v 0) p) - (for ([b (in-bytes v)] - [i (in-naturals)]) - (unless (zero? i) - (display " " p) - (display b p))) - (display ")" p)))]))]) - (pretty-print v port))) - -;; ---------------------------------------- - -(define (open-file-input/output-port filename - [options (file-options)] - [buffer-mode 'block] - [maybe-transcoder #f]) - (do-open-file-output-port 'open-file-input/output-port - filename - options - (if (eq? buffer-mode 'line) - 'block - buffer-mode) - maybe-transcoder - (lambda (name #:exists mode) - (let-values ([(in out) (open-input-output-file name #:exists mode)]) - (file-stream-buffer-mode out buffer-mode) - (make-dual-port in out))) - ;; Input and output buffering make `file-position' iffy. - (if (eq? buffer-mode 'none) - (case-lambda - [(p) (file-position (dual-port-in p))] - [(p pos) - (flush-output p) - (file-position (dual-port-in p) pos)]) - #f) - wrap-binary-input/output-port)) - -(define (make-make-custom-input/output-port - make-custom-input-port - make-custom-output-port) - (lambda (id read! write! get-pos set-pos! close) - (let* ([closed-one? #f] - [close (and close - (lambda () - (if closed-one? - (close) - (set! closed-one? #t))))]) - (let ([in (make-custom-input-port id read! get-pos set-pos! close)] - [out (make-custom-output-port id write! get-pos set-pos! close)]) - (make-dual-port in out))))) - -(define make-custom-binary-input/output-port - (make-make-custom-input/output-port - make-custom-binary-input-port - make-custom-binary-output-port)) - -(define make-custom-textual-input/output-port - (make-make-custom-input/output-port - make-custom-textual-input-port - make-custom-textual-output-port)) - -(define (bytevector->string bv t) - (unless (transcoder? t) - (raise-type-error 'bytevector->string "transcoder" t)) - (let ([p #f]) - (dynamic-wind - (lambda () - (set! p (open-bytevector-input-port bv t))) - (lambda () - (apply - string-append - (let loop () - (let ([s (get-string-n p 4096)]) - (if (eof-object? s) - null - (cons s (loop))))))) - (lambda () (close-input-port p))))) - -(define (string->bytevector s t) - (unless (transcoder? t) - (raise-type-error 'string->bytevector "transcoder" t)) - (let ([p #f] - [result #f]) - (dynamic-wind - (lambda () - (set!-values (p result) (open-bytevector-output-port t))) - (lambda () - (put-string p s) - (result)) - (lambda () (close-output-port p))))) +(require r6rs/private/ports) +(provide (except-out (all-from-out r6rs/private/ports) + r6rs-port->port))