;;;; streams for UNIX file descriptors ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!IMPL") ;;;; BUFFER ;;;; ;;;; Streams hold BUFFER objects, which contain a SAP, size of the ;;;; memory area the SAP stands for (LENGTH bytes), and HEAD and TAIL ;;;; indexes which delimit the "valid", or "active" area of the ;;;; memory. HEAD is inclusive, TAIL is exclusive. ;;;; ;;;; Buffers get allocated lazily, and are recycled by returning them ;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has it's own ;;;; finalizer, to take care of releasing the SAP memory when a stream ;;;; is not properly closed. ;;;; ;;;; The code aims to provide a limited form of thread and interrupt ;;;; safety: parallel writes and reads may lose output or input, cause ;;;; interleaved IO, etc -- but they should not corrupt memory. The ;;;; key to doing this is to read buffer state once, and update the ;;;; state based on the read state: ;;;; ;;;; (let ((tail (buffer-tail buffer))) ;;;; ... ;;;; (setf (buffer-tail buffer) (+ tail n))) ;;;; ;;;; NOT ;;;; ;;;; (let ((tail (buffer-tail buffer))) ;;;; ... ;;;; (incf (buffer-tail buffer) n)) ;;;; (declaim (inline buffer-sap buffer-length buffer-head buffer-tail (setf buffer-head) (setf buffer-tail))) (defstruct (buffer (:constructor %make-buffer (sap length))) (sap (missing-arg) :type system-area-pointer :read-only t) (length (missing-arg) :type index :read-only t) (head 0 :type index) (tail 0 :type index)) (defvar *available-buffers* () #!+sb-doc "List of available buffers.") (defvar *available-buffers-spinlock* (sb!thread::make-spinlock :name "lock for *AVAILABLE-BUFFERS*") #!+sb-doc "Mutex for access to *AVAILABLE-BUFFERS*.") (defmacro with-available-buffers-lock ((&optional) &body body) ;; CALL-WITH-SYSTEM-SPINLOCK because ;; ;; 1. streams are low-level enough to be async signal safe, and in ;; particular a C-c that brings up the debugger while holding the ;; mutex would lose badly ;; ;; 2. this can potentially be a fairly busy (but also probably ;; uncontended) lock, so we don't want to pay the syscall per ;; release -- hence a spinlock. ;; ;; ...again, once we have smarted locks the spinlock here can become ;; a mutex. `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) #!+sb-doc "Default number of bytes per buffer.") (defun alloc-buffer (&optional (size +bytes-per-buffer+)) ;; Don't want to allocate & unwind before the finalizer is in place. (without-interrupts (let* ((sap (allocate-system-memory size)) (buffer (%make-buffer sap size))) (when (zerop (sap-int sap)) (error "Could not allocate ~D bytes for buffer." size)) (finalize buffer (lambda () (deallocate-system-memory sap size)) :dont-save t) buffer))) (defun get-buffer () ;; Don't go for the lock if there is nothing to be had -- sure, ;; another thread might just release one before we get it, but that ;; is not worth the cost of locking. Also release the lock before ;; allocation, since it's going to take a while. (if *available-buffers* (or (with-available-buffers-lock () (pop *available-buffers*)) (alloc-buffer)) (alloc-buffer))) (declaim (inline reset-buffer)) (defun reset-buffer (buffer) (setf (buffer-head buffer) 0 (buffer-tail buffer) 0) buffer) (defun release-buffer (buffer) (reset-buffer buffer) (with-available-buffers-lock () (push buffer *available-buffers*))) ;;; This is a separate buffer management function, as it wants to be ;;; clever about locking -- grabbing the lock just once. (defun release-fd-stream-buffers (fd-stream) (let ((ibuf (fd-stream-ibuf fd-stream)) (obuf (fd-stream-obuf fd-stream)) (queue (loop for item in (fd-stream-output-queue fd-stream) when (buffer-p item) collect (reset-buffer item)))) (when ibuf (push (reset-buffer ibuf) queue)) (when obuf (push (reset-buffer obuf) queue)) ;; ...so, anything found? (when queue ;; detach from stream (setf (fd-stream-ibuf fd-stream) nil (fd-stream-obuf fd-stream) nil (fd-stream-output-queue fd-stream) nil) ;; splice to *available-buffers* (with-available-buffers-lock () (setf *available-buffers* (nconc queue *available-buffers*)))))) ;;;; the FD-STREAM structure (defstruct (fd-stream (:constructor %make-fd-stream) (:conc-name fd-stream-) (:predicate fd-stream-p) (:include ansi-stream (misc #'fd-stream-misc-routine)) (:copier nil)) ;; the name of this stream (name nil) ;; the file this stream is for (file nil) ;; the backup file namestring for the old file, for :IF-EXISTS ;; :RENAME or :RENAME-AND-DELETE. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete ;;; the number of bytes per element (element-size 1 :type index) ;; the type of element being transfered (element-type 'base-char) ;; the Unix file descriptor (fd -1 :type fixnum) ;; What do we know about the FD? (fd-type :unknown :type keyword) ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) ;; controls whether the input buffer must be cleared before output ;; (must be done for files, not for sockets, pipes and other data ;; sources where input and output aren't related). non-NIL means ;; don't clear input buffer. (dual-channel-p nil) ;; character position if known -- this may run into bignums, but ;; we probably should flip it into null then for efficiency's sake... (char-pos nil :type (or unsigned-byte null)) ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) ;; T if serve-event is allowed when this stream blocks (serve-events nil :type boolean) ;; the input buffer (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*))) (ibuf nil :type (or buffer null)) (eof-forced-p nil :type (member t nil)) ;; the output buffer (obuf nil :type (or buffer null)) ;; output flushed, but not written due to non-blocking io? (output-queue nil) (handler nil) ;; timeout specified for this stream as seconds or NIL if none (timeout nil :type (or single-float null)) ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null)) ;; Not :DEFAULT, because we want to match CHAR-SIZE! (external-format :latin-1) ;; fixed width, or function to call with a character (char-size 1 :type (or fixnum function)) (output-bytes #'ill-out :type function) ;; a boolean indicating whether the stream is bivalent. For ;; internal use only. (bivalent-p nil :type boolean)) (def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) (print-unreadable-object (fd-stream stream :type t :identity t) (format stream "for ~S" (fd-stream-name fd-stream)))) ;;;; CORE OUTPUT FUNCTIONS ;;; Buffer the section of THING delimited by START and END by copying ;;; to output buffer(s) of stream. (defun buffer-output (stream thing start end) (declare (index start end)) (when (< end start) (error ":END before :START!")) (when (> end start) ;; Copy bytes from THING to buffers. (flet ((copy-to-buffer (buffer tail count) (declare (buffer buffer) (index tail count)) (aver (plusp count)) (let ((sap (buffer-sap buffer))) (etypecase thing (system-area-pointer (system-area-ub8-copy thing start sap tail count)) ((simple-unboxed-array (*)) (copy-ub8-to-system-area thing start sap tail count)))) ;; Not INCF! If another thread has moved tail from under ;; us, we don't want to accidentally increment tail ;; beyond buffer-length. (setf (buffer-tail buffer) (+ count tail)) (incf start count))) (tagbody ;; First copy is special: the buffer may already contain ;; something, or be even full. (let* ((obuf (fd-stream-obuf stream)) (tail (buffer-tail obuf)) (space (- (buffer-length obuf) tail))) (when (plusp space) (copy-to-buffer obuf tail (min space (- end start))) (go :more-output-p))) :flush-and-fill ;; Later copies should always have an empty buffer, since ;; they are freshly flushed, but if another thread is ;; stomping on the same buffer that might not be the case. (let* ((obuf (flush-output-buffer stream)) (tail (buffer-tail obuf)) (space (- (buffer-length obuf) tail))) (copy-to-buffer obuf tail (min space (- end start)))) :more-output-p (when (> end start) (go :flush-and-fill)))))) ;;; Flush the current output buffer of the stream, ensuring that the ;;; new buffer is empty. Returns (for convenience) the new output ;;; buffer -- which may or may not be EQ to the old one. If the is no ;;; queued output we try to write the buffer immediately -- otherwise ;;; we queue it for later. (defun flush-output-buffer (stream) (let ((obuf (fd-stream-obuf stream))) (when obuf (let ((head (buffer-head obuf)) (tail (buffer-tail obuf))) (cond ((eql head tail) ;; Buffer is already empty -- just ensure that is is ;; set to zero as well. (reset-buffer obuf)) ((fd-stream-output-queue stream) ;; There is already stuff on the queue -- go directly ;; there. (aver (< head tail)) (%queue-and-replace-output-buffer stream)) (t ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue ;; whatever is left over. Otherwise wait until we can write. (aver (< head tail)) (synchronize-stream-output stream) (loop (let ((length (- tail head))) (multiple-value-bind (count errno) (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) head length) (flet ((queue-or-wait () (if (fd-stream-serve-events stream) (return (%queue-and-replace-output-buffer stream)) (or (wait-until-fd-usable (fd-stream-fd stream) :output (fd-stream-timeout stream) nil) (signal-timeout 'io-timeout :stream stream :direction :output :seconds (fd-stream-timeout stream)))))) (cond ((eql count length) ;; Complete write -- we can use the same buffer. (return (reset-buffer obuf))) (count ;; Partial write -- update buffer status and ;; queue or wait. (incf head count) (setf (buffer-head obuf) head) (queue-or-wait)) #!-win32 ((eql errno sb!unix:ewouldblock) ;; Blocking, queue or wair. (queue-or-wait)) (t (simple-stream-perror "Couldn't write to ~s" stream errno))))))))))))) ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer. (defun %queue-and-replace-output-buffer (stream) (aver (fd-stream-serve-events stream)) (let ((queue (fd-stream-output-queue stream)) (later (list (or (fd-stream-obuf stream) (bug "Missing obuf.")))) (new (get-buffer))) ;; Important: before putting the buffer on queue, give the stream ;; a new one. If we get an interrupt and unwind losing the buffer ;; is relatively OK, but having the same buffer in two places ;; would be bad. (setf (fd-stream-obuf stream) new) (cond (queue (nconc queue later)) (t (setf (fd-stream-output-queue stream) later))) (unless (fd-stream-handler stream) (setf (fd-stream-handler stream) (add-fd-handler (fd-stream-fd stream) :output (lambda (fd) (declare (ignore fd)) (write-output-from-queue stream))))) new)) ;;; This is called by the FD-HANDLER for the stream when output is ;;; possible. (defun write-output-from-queue (stream) (aver (fd-stream-serve-events stream)) (synchronize-stream-output stream) (let (not-first-p) (tagbody :pop-buffer (let* ((buffer (pop (fd-stream-output-queue stream))) (head (buffer-head buffer)) (length (- (buffer-tail buffer) head))) (declare (index head length)) (aver (>= length 0)) (multiple-value-bind (count errno) (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) head length) (cond ((eql count length) ;; Complete write, see if we can do another right ;; away, or remove the handler if we're done. (release-buffer buffer) (cond ((fd-stream-output-queue stream) (setf not-first-p t) (go :pop-buffer)) (t (let ((handler (fd-stream-handler stream))) (aver handler) (setf (fd-stream-handler stream) nil) (remove-fd-handler handler))))) (count ;; Partial write. Update buffer status and requeue. (aver (< count length)) ;; Do not use INCF! Another thread might have moved head. (setf (buffer-head buffer) (+ head count)) (push buffer (fd-stream-output-queue stream))) (not-first-p ;; We tried to do multiple writes, and finally our ;; luck ran out. Requeue. (push buffer (fd-stream-output-queue stream))) (t ;; Could not write on the first try at all! #!+win32 (simple-stream-perror "Couldn't write to ~S." stream errno) #!-win32 (if (= errno sb!unix:ewouldblock) (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.") (simple-stream-perror "Couldn't write to ~S" stream errno)))))))) nil) ;;; Try to write THING directly to STREAM without buffering, if ;;; possible. If direct write doesn't happen, buffer. (defun write-or-buffer-output (stream thing start end) (declare (index start end)) (cond ((fd-stream-output-queue stream) (buffer-output stream thing start end)) ((< end start) (error ":END before :START!")) ((> end start) (let ((length (- end start))) (synchronize-stream-output stream) (multiple-value-bind (count errno) (sb!unix:unix-write (fd-stream-fd stream) thing start length) (cond ((eql count length) ;; Complete write -- done! ) (count (aver (< count length)) ;; Partial write -- buffer the rest. (buffer-output stream thing (+ start count) end)) (t ;; Could not write -- buffer or error. #!+win32 (simple-stream-perror "couldn't write to ~s" stream errno) #!-win32 (if (= errno sb!unix:ewouldblock) (buffer-output stream thing start end) (simple-stream-perror "couldn't write to ~s" stream errno))))))))) ;;; Deprecated -- can go away after 1.1 or so. Deprecated because ;;; this is not something we want to export. Nikodemus thinks the ;;; right thing is to support a low-level non-stream like IO layer, ;;; akin to java.nio. (declaim (inline output-raw-bytes)) (define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence (stream thing &optional start end) (write-or-buffer-output stream thing (or start 0) (or end (length thing)))) ;;;; output routines and related noise (defvar *output-routines* () #!+sb-doc "List of all available output routines. Each element is a list of the element-type output, the kind of buffering, the function name, and the number of bytes per element.") ;;; common idioms for reporting low-level stream and file problems (defun simple-stream-perror (note-format stream errno) (error 'simple-stream-error :stream stream :format-control "~@<~?: ~2I~_~A~:>" :format-arguments (list note-format (list stream) (strerror errno)))) (defun simple-file-perror (note-format pathname errno) (error 'simple-file-error :pathname pathname :format-control "~@<~?: ~2I~_~A~:>" :format-arguments (list note-format (list pathname) (strerror errno)))) (defun stream-decoding-error (stream octets) (error 'stream-decoding-error :external-format (stream-external-format stream) :stream stream ;; FIXME: dunno how to get at OCTETS currently, or even if ;; that's the right thing to report. :octets octets)) (defun stream-encoding-error (stream code) (error 'stream-encoding-error :external-format (stream-external-format stream) :stream stream :code code)) (defun c-string-encoding-error (external-format code) (error 'c-string-encoding-error :external-format external-format :code code)) (defun c-string-decoding-error (external-format octets) (error 'c-string-decoding-error :external-format external-format :octets octets)) ;;; Returning true goes into end of file handling, false will enter another ;;; round of input buffer filling followed by re-entering character decode. (defun stream-decoding-error-and-handle (stream octet-count) (restart-case (stream-decoding-error stream (let* ((buffer (fd-stream-ibuf stream)) (sap (buffer-sap buffer)) (head (buffer-head buffer))) (loop for i from 0 below octet-count collect (sap-ref-8 sap (+ head i))))) (attempt-resync () :report (lambda (stream) (format stream "~@")) (fd-stream-resync stream) nil) (force-end-of-file () :report (lambda (stream) (format stream "~@")) (setf (fd-stream-eof-forced-p stream) t)) (input-replacement (string) :report (lambda (stream) (format stream "~@")) :interactive (lambda () (format *query-io* "~@") (finish-output *query-io*) (list (read *query-io*))) (let ((string (reverse (string string))) (instead (fd-stream-instead stream))) (dotimes (i (length string)) (vector-push-extend (char string i) instead)) (fd-stream-resync stream) (when (> (length string) 0) (setf (fd-stream-listen stream) t))) nil))) (defun stream-encoding-error-and-handle (stream code) (restart-case (stream-encoding-error stream code) (output-nothing () :report (lambda (stream) (format stream "~@")) (throw 'output-nothing nil)) (output-replacement (string) :report (lambda (stream) (format stream "~@")) :interactive (lambda () (format *query-io* "~@") (finish-output *query-io*) (list (read *query-io*))) (let ((string (string string))) (fd-sout stream (string string) 0 (length string))) (throw 'output-nothing nil)))) (defun external-format-encoding-error (stream code) (if (streamp stream) (stream-encoding-error-and-handle stream code) (c-string-encoding-error stream code))) (defun synchronize-stream-output (stream) ;; If we're reading and writing on the same file, flush buffered ;; input and rewind file position accordingly. (unless (fd-stream-dual-channel-p stream) (let ((adjust (nth-value 1 (flush-input-buffer stream)))) (unless (eql 0 adjust) (sb!unix:unix-lseek (fd-stream-fd stream) (- adjust) sb!unix:l_incr))))) (defun fd-stream-output-finished-p (stream) (let ((obuf (fd-stream-obuf stream))) (or (not obuf) (and (zerop (buffer-tail obuf)) (not (fd-stream-output-queue stream)))))) (defmacro output-wrapper/variable-width ((stream size buffering restart) &body body) (let ((stream-var (gensym "STREAM"))) `(let* ((,stream-var ,stream) (obuf (fd-stream-obuf ,stream-var)) (tail (buffer-tail obuf)) (size ,size)) ,(unless (eq (car buffering) :none) `(when (<= (buffer-length obuf) (+ tail size)) (setf obuf (flush-output-buffer ,stream-var) tail (buffer-tail obuf)))) ,(unless (eq (car buffering) :none) ;; FIXME: Why this here? Doesn't seem necessary. `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body (setf (buffer-tail obuf) (+ tail size))) `(progn ,@body (setf (buffer-tail obuf) (+ tail size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) (:line `(when (eql byte #\Newline) (flush-output-buffer ,stream-var))) (:full)) (values)))) (defmacro output-wrapper ((stream size buffering restart) &body body) (let ((stream-var (gensym "STREAM"))) `(let* ((,stream-var ,stream) (obuf (fd-stream-obuf ,stream-var)) (tail (buffer-tail obuf))) ,(unless (eq (car buffering) :none) `(when (<= (buffer-length obuf) (+ tail ,size)) (setf obuf (flush-output-buffer ,stream-var) tail (buffer-tail obuf)))) ;; FIXME: Why this here? Doesn't seem necessary. ,(unless (eq (car buffering) :none) `(synchronize-stream-output ,stream-var)) ,(if restart `(catch 'output-nothing ,@body (setf (buffer-tail obuf) (+ tail ,size))) `(progn ,@body (setf (buffer-tail obuf) (+ tail ,size)))) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) (:line `(when (eql byte #\Newline) (flush-output-buffer ,stream-var))) (:full)) (values)))) (defmacro def-output-routines/variable-width ((name-fmt size restart external-format &rest bufferings) &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar (lambda (buffering) (let ((function (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) (declare (ignorable byte)) (output-wrapper/variable-width (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* (nconc *output-routines* ',(mapcar (lambda (type) (list type (car buffering) function 1 external-format)) (cdr buffering))))))) bufferings))) ;;; Define output routines that output numbers SIZE bytes long for the ;;; given bufferings. Use BODY to do the actual output. (defmacro def-output-routines ((name-fmt size restart &rest bufferings) &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar (lambda (buffering) (let ((function (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) (output-wrapper (stream ,size ,buffering ,restart) ,@body)) (setf *output-routines* (nconc *output-routines* ',(mapcar (lambda (type) (list type (car buffering) function size nil)) (cdr buffering))))))) bufferings))) ;;; FIXME: is this used anywhere any more? (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 t (:none character) (:line character) (:full character)) (if (eql byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (setf (sap-ref-8 (buffer-sap obuf) tail) (char-code byte))) (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" 1 nil (:none (unsigned-byte 8)) (:full (unsigned-byte 8))) (setf (sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" 1 nil (:none (signed-byte 8)) (:full (signed-byte 8))) (setf (signed-sap-ref-8 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" 2 nil (:none (unsigned-byte 16)) (:full (unsigned-byte 16))) (setf (sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" 2 nil (:none (signed-byte 16)) (:full (signed-byte 16))) (setf (signed-sap-ref-16 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" 4 nil (:none (unsigned-byte 32)) (:full (unsigned-byte 32))) (setf (sap-ref-32 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" 4 nil (:none (signed-byte 32)) (:full (signed-byte 32))) (setf (signed-sap-ref-32 (buffer-sap obuf) tail) byte)) #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) (progn (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED" 8 nil (:none (unsigned-byte 64)) (:full (unsigned-byte 64))) (setf (sap-ref-64 (buffer-sap obuf) tail) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED" 8 nil (:none (signed-byte 64)) (:full (signed-byte 64))) (setf (signed-sap-ref-64 (buffer-sap obuf) tail) byte))) ;;; the routine to use to output a string. If the stream is ;;; unbuffered, slam the string down the file descriptor, otherwise ;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by ;;; checking to see where the last newline was. (defun fd-sout (stream thing start end) (declare (type fd-stream stream) (type string thing)) (let ((start (or start 0)) (end (or end (length (the vector thing))))) (declare (fixnum start end)) (let ((last-newline (string-dispatch (simple-base-string #!+sb-unicode (simple-array character (*)) string) thing (position #\newline thing :from-end t :start start :end end)))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format-keyword stream) :latin-1)) (ecase (fd-stream-buffering stream) (:full (buffer-output stream thing start end)) (:line (buffer-output stream thing start end) (when last-newline (flush-output-buffer stream))) (:none (write-or-buffer-output stream thing start end))) (ecase (fd-stream-buffering stream) (:full (funcall (fd-stream-output-bytes stream) stream thing nil start end)) (:line (funcall (fd-stream-output-bytes stream) stream thing last-newline start end)) (:none (funcall (fd-stream-output-bytes stream) stream thing t start end)))) (if last-newline (setf (fd-stream-char-pos stream) (- end last-newline 1)) (incf (fd-stream-char-pos stream) (- end start)))))) (defstruct (external-format (:constructor %make-external-format) (:conc-name ef-) (:predicate external-format-p) (:copier %copy-external-format)) ;; All the names that can refer to this external format. The first ;; one is the canonical name. (names (missing-arg) :type list :read-only t) (default-replacement-character (missing-arg) :type character) (read-n-chars-fun (missing-arg) :type function) (read-char-fun (missing-arg) :type function) (write-n-bytes-fun (missing-arg) :type function) (write-char-none-buffered-fun (missing-arg) :type function) (write-char-line-buffered-fun (missing-arg) :type function) (write-char-full-buffered-fun (missing-arg) :type function) ;; Can be nil for fixed-width formats. (resync-fun nil :type (or function null)) (bytes-for-char-fun (missing-arg) :type function) (read-c-string-fun (missing-arg) :type function) (write-c-string-fun (missing-arg) :type function) ;; We indirect through symbols in these functions so that a ;; developer working on the octets code can easily redefine things ;; and use the new function definition without redefining the ;; external format as well. The slots above don't do any ;; indirection because a developer working with those slots would be ;; redefining the external format anyway. (octets-to-string-fun (missing-arg) :type function) (string-to-octets-fun (missing-arg) :type function)) (defun ef-char-size (ef-entry) (if (variable-width-external-format-p ef-entry) (bytes-for-char-fun ef-entry) (funcall (bytes-for-char-fun ef-entry) #\x))) (defun wrap-external-format-functions (external-format fun) (let ((result (%copy-external-format external-format))) (macrolet ((frob (accessor) `(setf (,accessor result) (funcall fun (,accessor result))))) (frob ef-read-n-chars-fun) (frob ef-read-char-fun) (frob ef-write-n-bytes-fun) (frob ef-write-char-none-buffered-fun) (frob ef-write-char-line-buffered-fun) (frob ef-write-char-full-buffered-fun) (frob ef-resync-fun) (frob ef-bytes-for-char-fun) (frob ef-read-c-string-fun) (frob ef-write-c-string-fun) (frob ef-octets-to-string-fun) (frob ef-string-to-octets-fun)) result)) (defvar *external-formats* (make-hash-table) #!+sb-doc "Hashtable of all available external formats. The table maps from external-format names to EXTERNAL-FORMAT structures.") (defun get-external-format (external-format) (flet ((keyword-external-format (keyword) (declare (type keyword keyword)) (gethash keyword *external-formats*)) (replacement-handlerify (entry replacement) (when entry (wrap-external-format-functions entry (lambda (fun) (and fun (lambda (&rest rest) (declare (dynamic-extent rest)) (handler-bind ((stream-decoding-error (lambda (c) (declare (ignore c)) (invoke-restart 'input-replacement replacement))) (stream-encoding-error (lambda (c) (declare (ignore c)) (invoke-restart 'output-replacement replacement))) (octets-encoding-error (lambda (c) (use-value replacement c))) (octet-decoding-error (lambda (c) (use-value replacement c)))) (apply fun rest))))))))) (typecase external-format (keyword (keyword-external-format external-format)) ((cons keyword) (let ((entry (keyword-external-format (car external-format))) (replacement (getf (cdr external-format) :replacement))) (if replacement (replacement-handlerify entry replacement) entry)))))) (defun get-external-format-or-lose (external-format) (or (get-external-format external-format) (error "Undefined external-format: ~S" external-format))) (defun external-format-keyword (external-format) (typecase external-format (keyword external-format) ((cons keyword) (car external-format)))) (defun fd-stream-external-format-keyword (stream) (external-format-keyword (fd-stream-external-format stream))) (defun canonize-external-format (external-format entry) (typecase external-format (keyword (first (ef-names entry))) ((cons keyword) (cons (first (ef-names entry)) (rest external-format))))) ;;; Find an output routine to use given the type and buffering. Return ;;; as multiple values the routine, the real type transfered, and the ;;; number of bytes per element. (defun pick-output-routine (type buffering &optional external-format) (when (subtypep type 'character) (let ((entry (get-external-format-or-lose external-format))) (return-from pick-output-routine (values (ecase buffering (:none (ef-write-char-none-buffered-fun entry)) (:line (ef-write-char-line-buffered-fun entry)) (:full (ef-write-char-full-buffered-fun entry))) 'character 1 (ef-write-n-bytes-fun entry) (ef-char-size entry) (canonize-external-format external-format entry))))) (dolist (entry *output-routines*) (when (and (subtypep type (first entry)) (eq buffering (second entry)) (or (not (fifth entry)) (eq external-format (fifth entry)))) (return-from pick-output-routine (values (symbol-function (third entry)) (first entry) (fourth entry))))) ;; KLUDGE: dealing with the buffering here leads to excessive code ;; explosion. ;; ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) if (subtypep type `(unsigned-byte ,i)) do (return-from pick-output-routine (values (ecase buffering (:none (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(unsigned-byte ,i) (/ i 8)))) (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) if (subtypep type `(signed-byte ,i)) do (return-from pick-output-routine (values (ecase buffering (:none (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full) nil) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (buffer-sap obuf) (+ j tail)) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(signed-byte ,i) (/ i 8))))) ;;;; input routines and related noise ;;; a list of all available input routines. Each element is a list of ;;; the element-type input, the function name, and the number of bytes ;;; per element. (defvar *input-routines* ()) ;;; Return whether a primitive partial read operation on STREAM's FD ;;; would (probably) block. Signal a `simple-stream-error' if the ;;; system call implementing this operation fails. ;;; ;;; It is "may" instead of "would" because "would" is not quite ;;; correct on win32. However, none of the places that use it require ;;; further assurance than "may" versus "will definitely not". (defun sysread-may-block-p (stream) #!+win32 ;; This answers T at EOF on win32, I think. (not (sb!win32:fd-listen (fd-stream-fd stream))) #!-win32 (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0))) ;;; If the read would block wait (using SERVE-EVENT) till input is available, ;;; then fill the input buffer, and return the number of bytes read. Throws ;;; to EOF-INPUT-CATCHER if the eof was reached. (defun refill-input-buffer (stream) (dx-let ((fd (fd-stream-fd stream)) (errno 0) (count 0)) (tagbody ;; Check for blocking input before touching the stream if we are to ;; serve events: if the FD is blocking, we don't want to try an uninterruptible ;; read(). Regular files should never block, so we can elide the check. (if (and (neq :regular (fd-stream-fd-type stream)) (sysread-may-block-p stream)) (go :wait-for-input) (go :main)) ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what ;; we can signal errors outside the WITHOUT-INTERRUPTS. :closed-flame (closed-flame stream) :read-error (simple-stream-perror "couldn't read from ~S" stream errno) :wait-for-input ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS ;; to wait for input if read tells us EWOULDBLOCK. (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream) (fd-stream-serve-events stream)) (signal-timeout 'io-timeout :stream stream :direction :input :seconds (fd-stream-timeout stream))) :main ;; Since the read should not block, we'll disable the ;; interrupts here, so that we don't accidentally unwind and ;; leave the stream in an inconsistent state. ;; Execute the nlx outside without-interrupts to ensure the ;; resulting thunk is stack-allocatable. ((lambda (return-reason) (ecase return-reason ((nil)) ; fast path normal cases ((:wait-for-input) (go :wait-for-input)) ((:closed-flame) (go :closed-flame)) ((:read-error) (go :read-error)))) (without-interrupts ;; Check the buffer: if it is null, then someone has closed ;; the stream from underneath us. This is not ment to fix ;; multithreaded races, but to deal with interrupt handlers ;; closing the stream. (block nil (prog1 nil (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame))) (sap (buffer-sap ibuf)) (length (buffer-length ibuf)) (head (buffer-head ibuf)) (tail (buffer-tail ibuf))) (declare (index length head tail) (inline sb!unix:unix-read)) (unless (zerop head) (cond ((eql head tail) ;; Buffer is empty, but not at yet reset -- make it so. (setf head 0 tail 0) (reset-buffer ibuf)) (t ;; Buffer has things in it, but they are not at the ;; head -- move them there. (let ((n (- tail head))) (system-area-ub8-copy sap head sap 0 n) (setf head 0 (buffer-head ibuf) head tail n (buffer-tail ibuf) tail))))) (setf (fd-stream-listen stream) nil) (setf (values count errno) (sb!unix:unix-read fd (sap+ sap tail) (- length tail))) (cond ((null count) #!+win32 (return :read-error) #!-win32 (if (eql errno sb!unix:ewouldblock) (return :wait-for-input) (return :read-error))) ((zerop count) (setf (fd-stream-listen stream) :eof) (/show0 "THROWing EOF-INPUT-CATCHER") (throw 'eof-input-catcher nil)) (t ;; Success! (Do not use INCF, for sake of other threads.) (setf (buffer-tail ibuf) (+ count tail)))))))))) count)) ;;; Make sure there are at least BYTES number of bytes in the input ;;; buffer. Keep calling REFILL-INPUT-BUFFER until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym "STREAM")) (bytes-var (gensym "BYTES")) (buffer-var (gensym "IBUF"))) `(let* ((,stream-var ,stream) (,bytes-var ,bytes) (,buffer-var (fd-stream-ibuf ,stream-var))) (loop (when (>= (- (buffer-tail ,buffer-var) (buffer-head ,buffer-var)) ,bytes-var) (return)) (refill-input-buffer ,stream-var))))) (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value) &body read-forms) (let ((stream-var (gensym "STREAM")) (retry-var (gensym "RETRY")) (element-var (gensym "ELT"))) `(let* ((,stream-var ,stream) (ibuf (fd-stream-ibuf ,stream-var)) (size nil)) (block use-instead (when (fd-stream-eof-forced-p ,stream-var) (setf (fd-stream-eof-forced-p ,stream-var) nil) (return-from use-instead (eof-or-lose ,stream-var ,eof-error ,eof-value))) (let ((,element-var nil) (decode-break-reason nil)) (do ((,retry-var t)) ((not ,retry-var)) (if (> (length (fd-stream-instead ,stream-var)) 0) (let* ((instead (fd-stream-instead ,stream-var)) (result (vector-pop instead)) (pointer (fill-pointer instead))) (when (= pointer 0) (setf (fd-stream-listen ,stream-var) nil)) (return-from use-instead result)) (unless (catch 'eof-input-catcher (setf decode-break-reason (block decode-break-reason (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes))) (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf)))) (declare (ignorable byte)) ,@(when (consp bytes) `((let ((sap (buffer-sap ibuf)) (head (buffer-head ibuf))) (declare (ignorable sap head)) (setq size ,(cadr bytes)) (input-at-least ,stream-var size)))) (setq ,element-var (locally ,@read-forms)) (setq ,retry-var nil)) nil)) (when decode-break-reason (when (stream-decoding-error-and-handle stream decode-break-reason) (setq ,retry-var nil) (throw 'eof-input-catcher nil))) t) (let ((octet-count (- (buffer-tail ibuf) (buffer-head ibuf)))) (when (or (zerop octet-count) (and (not ,element-var) (not decode-break-reason) (stream-decoding-error-and-handle stream octet-count))) (setq ,retry-var nil)))))) (cond (,element-var (incf (buffer-head ibuf) size) ,element-var) (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) ;;; a macro to wrap around all input routines to handle EOF-ERROR noise (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms) (let ((stream-var (gensym "STREAM")) (element-var (gensym "ELT"))) `(let* ((,stream-var ,stream) (ibuf (fd-stream-ibuf ,stream-var))) (if (> (length (fd-stream-instead ,stream-var)) 0) (bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var) (let ((,element-var (catch 'eof-input-catcher (input-at-least ,stream-var ,bytes) (locally ,@read-forms)))) (cond (,element-var (incf (buffer-head (fd-stream-ibuf ,stream-var)) ,bytes) ,element-var) (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) (defmacro def-input-routine/variable-width (name (type external-format size sap head) &rest body) `(progn (defun ,name (stream eof-error eof-value) (input-wrapper/variable-width (stream ,size eof-error eof-value) (let ((,sap (buffer-sap ibuf)) (,head (buffer-head ibuf))) ,@body))) (setf *input-routines* (nconc *input-routines* (list (list ',type ',name 1 ',external-format)))))) (defmacro def-input-routine (name (type size sap head) &rest body) `(progn (defun ,name (stream eof-error eof-value) (input-wrapper (stream ,size eof-error eof-value) (let ((,sap (buffer-sap ibuf)) (,head (buffer-head ibuf))) ,@body))) (setf *input-routines* (nconc *input-routines* (list (list ',type ',name ',size nil)))))) ;;; STREAM-IN routine for reading a string char (def-input-routine input-character (character 1 sap head) (code-char (sap-ref-8 sap head))) ;;; STREAM-IN routine for reading an unsigned 8 bit number (def-input-routine input-unsigned-8bit-byte ((unsigned-byte 8) 1 sap head) (sap-ref-8 sap head)) ;;; STREAM-IN routine for reading a signed 8 bit number (def-input-routine input-signed-8bit-number ((signed-byte 8) 1 sap head) (signed-sap-ref-8 sap head)) ;;; STREAM-IN routine for reading an unsigned 16 bit number (def-input-routine input-unsigned-16bit-byte ((unsigned-byte 16) 2 sap head) (sap-ref-16 sap head)) ;;; STREAM-IN routine for reading a signed 16 bit number (def-input-routine input-signed-16bit-byte ((signed-byte 16) 2 sap head) (signed-sap-ref-16 sap head)) ;;; STREAM-IN routine for reading a unsigned 32 bit number (def-input-routine input-unsigned-32bit-byte ((unsigned-byte 32) 4 sap head) (sap-ref-32 sap head)) ;;; STREAM-IN routine for reading a signed 32 bit number (def-input-routine input-signed-32bit-byte ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) (progn (def-input-routine input-unsigned-64bit-byte ((unsigned-byte 64) 8 sap head) (sap-ref-64 sap head)) (def-input-routine input-signed-64bit-byte ((signed-byte 64) 8 sap head) (signed-sap-ref-64 sap head))) ;;; Find an input routine to use given the type. Return as multiple ;;; values the routine, the real type transfered, and the number of ;;; bytes per element (and for character types string input routine). (defun pick-input-routine (type &optional external-format) (when (subtypep type 'character) (let ((entry (get-external-format-or-lose external-format))) (return-from pick-input-routine (values (ef-read-char-fun entry) 'character 1 (ef-read-n-chars-fun entry) (ef-char-size entry) (canonize-external-format external-format entry))))) (dolist (entry *input-routines*) (when (and (subtypep type (first entry)) (or (not (fourth entry)) (eq external-format (fourth entry)))) (return-from pick-input-routine (values (symbol-function (second entry)) (first entry) (third entry))))) ;; FIXME: let's do it the hard way, then (but ignore things like ;; endianness, efficiency, and the necessary coupling between these ;; and the output routines). -- CSR, 2004-02-09 (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) if (subtypep type `(unsigned-byte ,i)) do (return-from pick-input-routine (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) (let ((sap (buffer-sap ibuf)) (head (buffer-head ibuf))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result (+ (* 256 result) (sap-ref-8 sap (+ head j)))) finally (return result))))) `(unsigned-byte ,i) (/ i 8)))) (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) if (subtypep type `(signed-byte ,i)) do (return-from pick-input-routine (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) (let ((sap (buffer-sap ibuf)) (head (buffer-head ibuf))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result (+ (* 256 result) (sap-ref-8 sap (+ head j)))) finally (return (if (logbitp (1- i) result) (dpb result (byte i 0) -1) result)))))) `(signed-byte ,i) (/ i 8))))) ;;; the N-BIN method for FD-STREAMs ;;; ;;; Note that this blocks in UNIX-READ. It is generally used where ;;; there is a definite amount of reading to be done, so blocking ;;; isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p &aux (total-copied 0)) (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (aver (= (length (fd-stream-instead stream)) 0)) (do () (nil) (let* ((remaining-request (- requested total-copied)) (ibuf (fd-stream-ibuf stream)) (head (buffer-head ibuf)) (tail (buffer-tail ibuf)) (available (- tail head)) (n-this-copy (min remaining-request available)) (this-start (+ start total-copied)) (this-end (+ this-start n-this-copy)) (sap (buffer-sap ibuf))) (declare (type index remaining-request head tail available)) (declare (type index n-this-copy)) ;; Copy data from stream buffer into user's buffer. (%byte-blt sap head buffer this-start this-end) (incf (buffer-head ibuf) n-this-copy) (incf total-copied n-this-copy) ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. (eql total-copied requested) (return total-copied)) (;; If EOF, we're done in another way. (null (catch 'eof-input-catcher (refill-input-buffer stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) ;; Otherwise we refilled the stream buffer, so fall ;; through into another pass of the loop. )))) (defun fd-stream-resync (stream) (let ((entry (get-external-format (fd-stream-external-format stream)))) (when entry (funcall (ef-resync-fun entry) stream)))) (defun get-fd-stream-character-sizer (stream) (let ((entry (get-external-format (fd-stream-external-format stream)))) (when entry (ef-bytes-for-char-fun entry)))) (defun fd-stream-character-size (stream char) (let ((sizer (get-fd-stream-character-sizer stream))) (when sizer (funcall sizer char)))) (defun fd-stream-string-size (stream string) (let ((sizer (get-fd-stream-character-sizer stream))) (when sizer (loop for char across string summing (funcall sizer char))))) (defun find-external-format (external-format) (when external-format (get-external-format external-format))) (defun variable-width-external-format-p (ef-entry) (and ef-entry (not (null (ef-resync-fun ef-entry))))) (defun bytes-for-char-fun (ef-entry) (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1))) (defmacro define-unibyte-mapping-external-format (canonical-name (&rest other-names) &body exceptions) (let ((->code-name (symbolicate canonical-name '->code-mapper)) (code->-name (symbolicate 'code-> canonical-name '-mapper)) (get-bytes-name (symbolicate 'get- canonical-name '-bytes)) (string->-name (symbolicate 'string-> canonical-name)) (define-string*-name (symbolicate 'define- canonical-name '->string*)) (string*-name (symbolicate canonical-name '->string*)) (define-string-name (symbolicate 'define- canonical-name '->string)) (string-name (symbolicate canonical-name '->string)) (->string-aref-name (symbolicate canonical-name '->string-aref))) `(progn (define-unibyte-mapper ,->code-name ,code->-name ,@exceptions) (declaim (inline ,get-bytes-name)) (defun ,get-bytes-name (string pos) (declare (optimize speed (safety 0)) (type simple-string string) (type array-range pos)) (get-latin-bytes #',code->-name ,canonical-name string pos)) (defun ,string->-name (string sstart send null-padding) (declare (optimize speed (safety 0)) (type simple-string string) (type array-range sstart send)) (values (string->latin% string sstart send #',get-bytes-name null-padding))) (defmacro ,define-string*-name (accessor type) (declare (ignore type)) (let ((name (make-od-name ',string*-name accessor))) `(progn (defun ,name (string sstart send array astart aend) (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #',',->code-name))))) (instantiate-octets-definition ,define-string*-name) (defmacro ,define-string-name (accessor type) (declare (ignore type)) (let ((name (make-od-name ',string-name accessor))) `(progn (defun ,name (array astart aend) (,(make-od-name 'latin->string accessor) array astart aend #',',->code-name))))) (instantiate-octets-definition ,define-string-name) (define-unibyte-external-format ,canonical-name ,other-names (let ((octet (,code->-name bits))) (if octet (setf (sap-ref-8 sap tail) octet) (external-format-encoding-error stream bits))) (let ((code (,->code-name byte))) (if code (code-char code) (return-from decode-break-reason 1))) ,->string-aref-name ,string->-name)))) (defmacro define-unibyte-external-format (canonical-name (&rest other-names) out-form in-form octets-to-string-symbol string-to-octets-symbol) `(define-external-format/variable-width (,canonical-name ,@other-names) t #\? 1 ,out-form 1 ,in-form ,octets-to-string-symbol ,string-to-octets-symbol)) (defmacro define-external-format/variable-width (external-format output-restart replacement-character out-size-expr out-expr in-size-expr in-expr octets-to-string-sym string-to-octets-sym) (let* ((name (first external-format)) (out-function (symbolicate "OUTPUT-BYTES/" name)) (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) (in-char-function (symbolicate "INPUT-CHAR/" name)) (resync-function (symbolicate "RESYNC/" name)) (size-function (symbolicate "BYTES-FOR-CHAR/" name)) (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name)) (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)) (n-buffer (gensym "BUFFER"))) `(progn (defun ,size-function (byte) (declare (ignorable byte)) ,out-size-expr) (defun ,out-function (stream string flush-p start end) (let ((start (or start 0)) (end (or end (length string)))) (declare (type index start end)) (synchronize-stream-output stream) (unless (<= 0 start end (length string)) (sequence-bounding-indices-bad-error string start end)) (do () ((= end start)) (let ((obuf (fd-stream-obuf stream))) (string-dispatch (simple-base-string #!+sb-unicode (simple-array character (*)) string) string (let ((len (buffer-length obuf)) (sap (buffer-sap obuf)) ;; FIXME: Rename (tail (buffer-tail obuf))) (declare (type index tail) ;; STRING bounds have already been checked. (optimize (safety 0))) (,@(if output-restart `(catch 'output-nothing) `(progn)) (do* () ((or (= start end) (< (- len tail) 4))) (let* ((byte (aref string start)) (bits (char-code byte)) (size ,out-size-expr)) ,out-expr (incf tail size) (setf (buffer-tail obuf) tail) (incf start))) (go flush)) ;; Exited via CATCH: skip the current character. (incf start)))) flush (when (< start end) (flush-output-buffer stream))) (when flush-p (flush-output-buffer stream)))) (def-output-routines/variable-width (,format ,out-size-expr ,output-restart ,external-format (:none character) (:line character) (:full character)) (if (eql byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (let ((bits (char-code byte)) (sap (buffer-sap obuf)) (tail (buffer-tail obuf))) ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p &aux (total-copied 0)) (declare (type fd-stream stream) (type index start requested total-copied) (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) (when (fd-stream-eof-forced-p stream) (setf (fd-stream-eof-forced-p stream) nil) (return-from ,in-function 0)) (do ((instead (fd-stream-instead stream))) ((= (fill-pointer instead) 0) (setf (fd-stream-listen stream) nil)) (setf (aref buffer (+ start total-copied)) (vector-pop instead)) (incf total-copied) (when (= requested total-copied) (when (= (fill-pointer instead) 0) (setf (fd-stream-listen stream) nil)) (return-from ,in-function total-copied))) (do () (nil) (let* ((ibuf (fd-stream-ibuf stream)) (head (buffer-head ibuf)) (tail (buffer-tail ibuf)) (sap (buffer-sap ibuf)) (decode-break-reason nil)) (declare (type index head tail)) ;; Copy data from stream buffer into user's buffer. (do ((size nil nil)) ((or (= tail head) (= requested total-copied))) (setf decode-break-reason (block decode-break-reason ,@(when (consp in-size-expr) `((when (> ,(car in-size-expr) (- tail head)) (return)))) (let ((byte (sap-ref-8 sap head))) (declare (ignorable byte)) (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)) (when (> size (- tail head)) (return)) (setf (aref buffer (+ start total-copied)) ,in-expr) (incf total-copied) (incf head size)) nil)) (setf (buffer-head ibuf) head) (when decode-break-reason ;; If we've already read some characters on when the invalid ;; code sequence is detected, we return immediately. The ;; handling of the error is deferred until the next call ;; (where this check will be false). This allows establishing ;; high-level handlers for decode errors (for example ;; automatically resyncing in Lisp comments). (when (plusp total-copied) (return-from ,in-function total-copied)) (when (stream-decoding-error-and-handle stream decode-break-reason) (if eof-error-p (error 'end-of-file :stream stream) (return-from ,in-function total-copied))) ;; we might have been given stuff to use instead, so ;; we have to return (and trust our caller to know ;; what to do about TOTAL-COPIED being 0). (return-from ,in-function total-copied))) (setf (buffer-head ibuf) head) ;; Maybe we need to refill the stream buffer. (cond ( ;; If was data in the stream buffer, we're done. (plusp total-copied) (return total-copied)) ( ;; If EOF, we're done in another way. (or (eq decode-break-reason 'eof) (null (catch 'eof-input-catcher (refill-input-buffer stream)))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) ;; Otherwise we refilled the stream buffer, so fall ;; through into another pass of the loop. )))) (def-input-routine/variable-width ,in-char-function (character ,external-format ,in-size-expr sap head) (let ((byte (sap-ref-8 sap head))) (declare (ignorable byte)) ,in-expr)) (defun ,resync-function (stream) (let ((ibuf (fd-stream-ibuf stream)) size) (catch 'eof-input-catcher (loop (incf (buffer-head ibuf)) (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr))) (unless (block decode-break-reason (let* ((sap (buffer-sap ibuf)) (head (buffer-head ibuf)) (byte (sap-ref-8 sap head))) (declare (ignorable byte)) ,@(when (consp in-size-expr) `((setq size ,(cadr in-size-expr)) (input-at-least stream size))) (setf head (buffer-head ibuf)) ,in-expr) nil) (return)))))) (defun ,read-c-string-function (sap element-type) (declare (type system-area-pointer sap)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((stream ,name) (size 0) (head 0) (byte 0) (char nil) (decode-break-reason nil) (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count) (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason (c-string-decoding-error ,name decode-break-reason)) (when (zerop (char-code char)) (return count)))) (string (make-string length :element-type element-type))) (declare (ignorable stream) (type index head length) ;; size (type (unsigned-byte 8) byte) (type (or null character) char) (type string string)) (setf head 0) (dotimes (index length string) (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason (c-string-decoding-error ,name decode-break-reason)) (setf (aref string index) char))))) (defun ,output-c-string-function (string) (declare (type simple-string string)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((length (length string)) (char-length (make-array (1+ length) :element-type 'index)) (buffer-length (+ (loop for i of-type index below length for byte of-type character = (aref string i) for bits = (char-code byte) sum (setf (aref char-length i) (the index ,out-size-expr))) (let* ((byte (code-char 0)) (bits (char-code byte))) (declare (ignorable byte bits)) (setf (aref char-length length) (the index ,out-size-expr))))) (tail 0) (,n-buffer (make-array buffer-length :element-type '(unsigned-byte 8))) stream) (declare (type index length buffer-length tail) (type null stream) (ignorable stream)) (with-pinned-objects (,n-buffer) (let ((sap (vector-sap ,n-buffer))) (declare (system-area-pointer sap)) (loop for i of-type index below length for byte of-type character = (aref string i) for bits = (char-code byte) for size of-type index = (aref char-length i) do (prog1 ,out-expr (incf tail size))) (let* ((bits 0) (byte (code-char bits)) (size (aref char-length length))) (declare (ignorable bits byte size)) ,out-expr))) ,n-buffer))) (let ((entry (%make-external-format :names ',external-format :default-replacement-character ,replacement-character :read-n-chars-fun #',in-function :read-char-fun #',in-char-function :write-n-bytes-fun #',out-function ,@(mapcan #'(lambda (buffering) (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword) `#',(intern (format nil format (string buffering))))) '(:none :line :full)) :resync-fun #',resync-function :bytes-for-char-fun #',size-function :read-c-string-fun #',read-c-string-function :write-c-string-fun #',output-c-string-function :octets-to-string-fun (lambda (&rest rest) (declare (dynamic-extent rest)) (apply ',octets-to-string-sym rest)) :string-to-octets-fun (lambda (&rest rest) (declare (dynamic-extent rest)) (apply ',string-to-octets-sym rest))))) (dolist (ef ',external-format) (setf (gethash ef *external-formats*) entry)))))) ;;;; utility functions (misc routines, etc) ;;; Fill in the various routine slots for the given type. INPUT-P and ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be ;;; set prior to calling this routine. (defun set-fd-stream-routines (fd-stream element-type external-format input-p output-p buffer-p) (let* ((target-type (case element-type (unsigned-byte '(unsigned-byte 8)) (signed-byte '(signed-byte 8)) (:default 'character) (t element-type))) (character-stream-p (subtypep target-type 'character)) (bivalent-stream-p (eq element-type :default)) normalized-external-format char-size (bin-routine #'ill-bin) (bin-type nil) (bin-size nil) (cin-routine #'ill-in) (cin-type nil) (cin-size nil) (input-type nil) ;calculated from bin-type/cin-type (input-size nil) ;calculated from bin-size/cin-size (read-n-characters #'ill-in) (bout-routine #'ill-bout) (bout-type nil) (bout-size nil) (cout-routine #'ill-out) (cout-type nil) (cout-size nil) (output-type nil) (output-size nil) (output-bytes #'ill-bout)) ;; Ensure that we have buffers in the desired direction(s) only, ;; getting new ones and dropping/resetting old ones as necessary. (let ((obuf (fd-stream-obuf fd-stream))) (if output-p (if obuf (reset-buffer obuf) (setf (fd-stream-obuf fd-stream) (get-buffer))) (when obuf (setf (fd-stream-obuf fd-stream) nil) (release-buffer obuf)))) (let ((ibuf (fd-stream-ibuf fd-stream))) (if input-p (if ibuf (reset-buffer ibuf) (setf (fd-stream-ibuf fd-stream) (get-buffer))) (when ibuf (setf (fd-stream-ibuf fd-stream) nil) (release-buffer ibuf)))) ;; FIXME: Why only for output? Why unconditionally? (when output-p (setf (fd-stream-char-pos fd-stream) 0)) (when (and character-stream-p (eq external-format :default)) (/show0 "/getting default external format") (setf external-format (default-external-format))) (when input-p (when (or (not character-stream-p) bivalent-stream-p) (setf (values bin-routine bin-type bin-size read-n-characters char-size normalized-external-format) (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) target-type) external-format)) (unless bin-routine (error "could not find any input routine for ~S" target-type))) (when character-stream-p (setf (values cin-routine cin-type cin-size read-n-characters char-size normalized-external-format) (pick-input-routine target-type external-format)) (unless cin-routine (error "could not find any input routine for ~S" target-type))) (setf (fd-stream-in fd-stream) cin-routine (fd-stream-bin fd-stream) bin-routine) ;; character type gets preferential treatment (setf input-size (or cin-size bin-size)) (setf input-type (or cin-type bin-type)) (when normalized-external-format (setf (fd-stream-external-format fd-stream) normalized-external-format (fd-stream-char-size fd-stream) char-size)) (when (= (or cin-size 1) (or bin-size 1) 1) (setf (fd-stream-n-bin fd-stream) ;XXX (if (and character-stream-p (not bivalent-stream-p)) read-n-characters #'fd-stream-read-n-bytes)) ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on ;; for character and (unsigned-byte 8) streams. In these ;; cases, fast-read-* will read from the ;; ansi-stream-(c)in-buffer, saving function calls. ;; Otherwise, the various data-reading functions in the stream ;; structure will be called. (when (and buffer-p (not bivalent-stream-p) ;; temporary disable on :io streams (not output-p)) (cond (character-stream-p (setf (ansi-stream-cin-buffer fd-stream) (make-array +ansi-stream-in-buffer-length+ :element-type 'character))) ((equal target-type '(unsigned-byte 8)) (setf (ansi-stream-in-buffer fd-stream) (make-array +ansi-stream-in-buffer-length+ :element-type '(unsigned-byte 8)))))))) (when output-p (when (or (not character-stream-p) bivalent-stream-p) (setf (values bout-routine bout-type bout-size output-bytes char-size normalized-external-format) (let ((buffering (fd-stream-buffering fd-stream))) (if bivalent-stream-p (pick-output-routine '(unsigned-byte 8) (if (eq :line buffering) :full buffering) external-format) (pick-output-routine target-type buffering external-format)))) (unless bout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when character-stream-p (setf (values cout-routine cout-type cout-size output-bytes char-size normalized-external-format) (pick-output-routine target-type (fd-stream-buffering fd-stream) external-format)) (unless cout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type))) (when normalized-external-format (setf (fd-stream-external-format fd-stream) normalized-external-format (fd-stream-char-size fd-stream) char-size)) (when character-stream-p (setf (fd-stream-output-bytes fd-stream) output-bytes)) (setf (fd-stream-out fd-stream) cout-routine (fd-stream-bout fd-stream) bout-routine (fd-stream-sout fd-stream) (if (eql cout-size 1) #'fd-sout #'ill-out)) (setf output-size (or cout-size bout-size)) (setf output-type (or cout-type bout-type))) (when (and input-size output-size (not (eq input-size output-size))) (error "Element sizes for input (~S:~S) and output (~S:~S) differ?" input-type input-size output-type output-size)) (setf (fd-stream-element-size fd-stream) (or input-size output-size)) (setf (fd-stream-element-type fd-stream) (cond ((equal input-type output-type) input-type) ((null output-type) input-type) ((null input-type) output-type) ((subtypep input-type output-type) input-type) ((subtypep output-type input-type) output-type) (t (error "Input type (~S) and output type (~S) are unrelated?" input-type output-type)))))) ;;; Handles the resource-release aspects of stream closing, and marks ;;; it as closed. (defun release-fd-stream-resources (fd-stream) (handler-case (without-interrupts ;; Drop handlers first. (when (fd-stream-handler fd-stream) (remove-fd-handler (fd-stream-handler fd-stream)) (setf (fd-stream-handler fd-stream) nil)) ;; Disable interrupts so that a asynch unwind will not leave ;; us with a dangling finalizer (that would close the same ;; --possibly reassigned-- FD again), or a stream with a closed ;; FD that appears open. (sb!unix:unix-close (fd-stream-fd fd-stream)) (set-closed-flame fd-stream) (when (fboundp 'cancel-finalization) (cancel-finalization fd-stream))) ;; On error unwind from WITHOUT-INTERRUPTS. (serious-condition (e) (error e))) ;; Release all buffers. If this is undone, or interrupted, ;; we're still safe: buffers have finalizers of their own. (release-fd-stream-buffers fd-stream)) ;;; Flushes the current input buffer and any supplied replacements, ;;; and returns the input buffer, and the amount of of flushed input ;;; in bytes. (defun flush-input-buffer (stream) (let ((unread (length (fd-stream-instead stream)))) (setf (fill-pointer (fd-stream-instead stream)) 0) (let ((ibuf (fd-stream-ibuf stream))) (if ibuf (let ((head (buffer-head ibuf)) (tail (buffer-tail ibuf))) (values (reset-buffer ibuf) (- (+ unread tail) head))) (values nil unread))))) (defun fd-stream-clear-input (stream) (flush-input-buffer stream) #!+win32 (progn (sb!win32:fd-clear-input (fd-stream-fd stream)) (setf (fd-stream-listen stream) nil)) #!-win32 (catch 'eof-input-catcher (loop until (sysread-may-block-p stream) do (refill-input-buffer stream) (reset-buffer (fd-stream-ibuf stream))) t)) ;;; Handle miscellaneous operations on FD-STREAM. (defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2) (declare (ignore arg2)) (case operation (:listen (labels ((do-listen () (let ((ibuf (fd-stream-ibuf fd-stream))) (or (not (eql (buffer-head ibuf) (buffer-tail ibuf))) (fd-stream-listen fd-stream) #!+win32 (sb!win32:fd-listen (fd-stream-fd fd-stream)) #!-win32 ;; If the read can block, LISTEN will certainly return NIL. (if (sysread-may-block-p fd-stream) nil ;; Otherwise select(2) and CL:LISTEN have slightly ;; different semantics. The former returns that an FD ;; is readable when a read operation wouldn't block. ;; That includes EOF. However, LISTEN must return NIL ;; at EOF. (progn (catch 'eof-input-catcher ;; r-b/f too calls select, but it shouldn't ;; block as long as read can return once w/o ;; blocking (refill-input-buffer fd-stream)) ;; At this point either IBUF-HEAD != IBUF-TAIL ;; and FD-STREAM-LISTEN is NIL, in which case ;; we should return T, or IBUF-HEAD == ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in ;; which case we should return :EOF for this ;; call and all future LISTEN call on this stream. ;; Call ourselves again to determine which case ;; applies. (do-listen))))))) (do-listen))) (:unread (decf (buffer-head (fd-stream-ibuf fd-stream)) (fd-stream-character-size fd-stream arg1))) (:close ;; Drop input buffers (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+ (ansi-stream-cin-buffer fd-stream) nil (ansi-stream-in-buffer fd-stream) nil) (cond (arg1 ;; We got us an abort on our hands. (let ((outputp (fd-stream-obuf fd-stream)) (file (fd-stream-file fd-stream)) (orig (fd-stream-original fd-stream))) ;; This takes care of the important stuff -- everything ;; rest is cleaning up the file-system, which we cannot ;; do on some platforms as long as the file is open. (release-fd-stream-resources fd-stream) ;; We can't do anything unless we know what file were ;; dealing with, and we don't want to do anything ;; strange unless we were writing to the file. (when (and outputp file) (if orig ;; If the original is EQ to file we are appending to ;; and can just close the file without renaming. (unless (eq orig file) ;; We have a handle on the original, just revert. (multiple-value-bind (okay err) (sb!unix:unix-rename orig file) ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the ;; others are SIMPLE-FILE-ERRORS? Surely they should ;; all be the same? (unless okay (error 'simple-stream-error :format-control "~@" :format-arguments (list file orig fd-stream (strerror err)) :stream fd-stream)))) ;; We can't restore the original, and aren't ;; appending, so nuke that puppy. ;; ;; FIXME: This is currently the fate of superseded ;; files, and according to the CLOSE spec this is ;; wrong. However, there seems to be no clean way to ;; do that that doesn't involve either copying the ;; data (bad if the :abort resulted from a full ;; disk), or renaming the old file temporarily ;; (probably bad because stream opening becomes more ;; racy). (multiple-value-bind (okay err) (sb!unix:unix-unlink file) (unless okay (error 'simple-file-error :pathname file :format-control "~@" :format-arguments (list file fd-stream (strerror err))))))))) (t (finish-fd-stream-output fd-stream) (let ((orig (fd-stream-original fd-stream))) (when (and orig (fd-stream-delete-original fd-stream)) (multiple-value-bind (okay err) (sb!unix:unix-unlink orig) (unless okay (error 'simple-file-error :pathname orig :format-control "~@" :format-arguments (list orig fd-stream (strerror err))))))) ;; In case of no-abort close, don't *really* close the ;; stream until the last moment -- the cleaning up of the ;; original can be done first. (release-fd-stream-resources fd-stream)))) (:clear-input (fd-stream-clear-input fd-stream)) (:force-output (flush-output-buffer fd-stream)) (:finish-output (finish-fd-stream-output fd-stream)) (:element-type (fd-stream-element-type fd-stream)) (:external-format (fd-stream-external-format fd-stream)) (:interactive-p (= 1 (the (member 0 1) (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) (:line-length 80) (:charpos (fd-stream-char-pos fd-stream)) (:file-length (unless (fd-stream-file fd-stream) ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH ;; "should signal an error of type TYPE-ERROR if stream is not ;; a stream associated with a file". Too bad there's no very ;; appropriate value for the EXPECTED-TYPE slot.. (error 'simple-type-error :datum fd-stream :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) (declare (ignore ino nlink uid gid rdev atime mtime ctime blksize blocks)) (unless okay (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) (if (zerop mode) nil (truncate size (fd-stream-element-size fd-stream))))) (:file-string-length (etypecase arg1 (character (fd-stream-character-size fd-stream arg1)) (string (fd-stream-string-size fd-stream arg1)))) (:file-position (if arg1 (fd-stream-set-file-position fd-stream arg1) (fd-stream-get-file-position fd-stream))))) ;; FIXME: Think about this. ;; ;; (defun finish-fd-stream-output (fd-stream) ;; (let ((timeout (fd-stream-timeout fd-stream))) ;; (loop while (fd-stream-output-queue fd-stream) ;; ;; FIXME: SIGINT while waiting for a timeout will ;; ;; cause a timeout here. ;; do (when (and (not (serve-event timeout)) timeout) ;; (signal-timeout 'io-timeout ;; :stream fd-stream ;; :direction :write ;; :seconds timeout))))) (defun finish-fd-stream-output (stream) (flush-output-buffer stream) (do () ((null (fd-stream-output-queue stream))) (aver (fd-stream-serve-events stream)) (serve-all-events))) (defun fd-stream-get-file-position (stream) (declare (fd-stream stream)) (without-interrupts (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr))) (declare (type (or (alien sb!unix:off-t) null) posn)) ;; We used to return NIL for errno==ESPIPE, and signal an error ;; in other failure cases. However, CLHS says to return NIL if ;; the position cannot be determined -- so that's what we do. (when (integerp posn) ;; Adjust for buffered output: If there is any output ;; buffered, the *real* file position will be larger ;; than reported by lseek() because lseek() obviously ;; cannot take into account output we have not sent ;; yet. (dolist (buffer (fd-stream-output-queue stream)) (incf posn (- (buffer-tail buffer) (buffer-head buffer)))) (let ((obuf (fd-stream-obuf stream))) (when obuf (incf posn (buffer-tail obuf)))) ;; Adjust for unread input: If there is any input ;; read from UNIX but not supplied to the user of the ;; stream, the *real* file position will smaller than ;; reported, because we want to look like the unread ;; stuff is still available. (let ((ibuf (fd-stream-ibuf stream))) (when ibuf (decf posn (- (buffer-tail ibuf) (buffer-head ibuf))))) ;; Divide bytes by element size. (truncate posn (fd-stream-element-size stream)))))) (defun fd-stream-set-file-position (stream position-spec) (declare (fd-stream stream)) (check-type position-spec (or (alien sb!unix:off-t) (member nil :start :end)) "valid file position designator") (tagbody :again ;; Make sure we don't have any output pending, because if we ;; move the file pointer before writing this stuff, it will be ;; written in the wrong location. (finish-fd-stream-output stream) ;; Disable interrupts so that interrupt handlers doing output ;; won't screw us. (without-interrupts (unless (fd-stream-output-finished-p stream) ;; We got interrupted and more output came our way during ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors, ;; so we prefer to do things like this... (go :again)) ;; Clear out any pending input to force the next read to go to ;; the disk. (flush-input-buffer stream) ;; Trash cached value for listen, so that we check next time. (setf (fd-stream-listen stream) nil) ;; Now move it. (multiple-value-bind (offset origin) (case position-spec (:start (values 0 sb!unix:l_set)) (:end (values 0 sb!unix:l_xtnd)) (t (values (* position-spec (fd-stream-element-size stream)) sb!unix:l_set))) (declare (type (alien sb!unix:off-t) offset)) (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) offset origin))) ;; CLHS says to return true if the file-position was set ;; succesfully, and NIL otherwise. We are to signal an error ;; only if the given position was out of bounds, and that is ;; dealt with above. In times past we used to return NIL for ;; errno==ESPIPE, and signal an error in other cases. ;; ;; FIXME: We are still liable to signal an error if flushing ;; output fails. (return-from fd-stream-set-file-position (typep posn '(alien sb!unix:off-t)))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) ;;; Create a stream for the given Unix file descriptor. ;;; ;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil, ;;; allow output operations. If neither INPUT nor OUTPUT is specified, ;;; default to allowing input. ;;; ;;; ELEMENT-TYPE indicates the element type to use (as for OPEN). ;;; ;;; BUFFERING indicates the kind of buffering to use. ;;; ;;; TIMEOUT (if true) is the number of seconds to wait for input. If ;;; NIL (the default), then wait forever. When we time out, we signal ;;; IO-TIMEOUT. ;;; ;;; FILE is the name of the file (will be returned by PATHNAME). ;;; ;;; NAME is used to identify the stream when printed. ;;; ;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to ;;; handle blocking IO on the stream. (defun make-fd-stream (fd &key (input nil input-p) (output nil output-p) (element-type 'base-char) (buffering :full) (external-format :default) serve-events timeout file original delete-original pathname input-buffer-p dual-channel-p (name (if file (format nil "file ~A" file) (format nil "descriptor ~W" fd))) auto-close) (declare (type index fd) (type (or real null) timeout) (type (member :none :line :full) buffering)) (cond ((not (or input-p output-p)) (setf input t)) ((not (or input output)) (error "File descriptor must be opened either for input or output."))) (let ((stream (%make-fd-stream :fd fd :fd-type (progn #!-win32 (sb!unix:fd-type fd) ;; KLUDGE. #!+win32 (if serve-events :unknown :regular)) :name name :file file :original original :delete-original delete-original :pathname pathname :buffering buffering :dual-channel-p dual-channel-p :bivalent-p (eq element-type :default) :serve-events serve-events :timeout (if timeout (coerce timeout 'single-float) nil)))) (set-fd-stream-routines stream element-type external-format input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream (lambda () (sb!unix:unix-close fd) #!+sb-show (format *terminal-io* "** closed file descriptor ~W **~%" fd)) :dont-save t)) stream)) ;;; Pick a name to use for the backup file for the :IF-EXISTS ;;; :RENAME-AND-DELETE and :RENAME options. (defun pick-backup-name (name) (declare (type simple-string name)) (concatenate 'simple-string name ".bak")) ;;; Ensure that the given arg is one of the given list of valid ;;; things. Allow the user to fix any problems. (defun ensure-one-of (item list what) (unless (member item list) (error 'simple-type-error :datum item :expected-type `(member ,@list) :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>" :format-arguments (list item what list)))) ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write ;;; access, since we don't want to trash unwritable files even if we ;;; technically can. We return true if we succeed in renaming. (defun rename-the-old-one (namestring original) (unless (sb!unix:unix-access namestring sb!unix:w_ok) (error "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) (if okay t (error 'simple-file-error :pathname namestring :format-control "~@" :format-arguments (list namestring original (strerror err)))))) (defun open (filename &key (direction :input) (element-type 'base-char) (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given) (external-format :default) &aux ; Squelch assignment warning. (direction direction) (if-does-not-exist if-does-not-exist) (if-exists if-exists)) #!+sb-doc "Return a stream which reads from or writes to FILENAME. Defined keywords: :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE or NIL :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL See the manual for details." ;; Calculate useful stuff. (multiple-value-bind (input output mask) (ecase direction (:input (values t nil sb!unix:o_rdonly)) (:output (values nil t sb!unix:o_wronly)) (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) (let* (;; PATHNAME is the pathname we associate with the stream. (pathname (merge-pathnames filename)) (physical (physicalize-pathname pathname)) (truename (probe-file physical)) ;; NAMESTRING is the native namestring we open the file with. (namestring (cond (truename (native-namestring truename :as-file t)) ((or (not input) (and input (eq if-does-not-exist :create)) (and (eq direction :io) (not if-does-not-exist-given))) (native-namestring physical :as-file t))))) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given (setf if-exists (if (eq (pathname-version pathname) :newest) :new-version :error))) (ensure-one-of if-exists '(:error :new-version :rename :rename-and-delete :overwrite :append :supersede nil) :if-exists) (case if-exists ((:new-version :error nil) (setf mask (logior mask sb!unix:o_excl))) ((:rename :rename-and-delete) (setf mask (logior mask sb!unix:o_creat))) ((:supersede) (setf mask (logior mask sb!unix:o_trunc))) (:append (setf mask (logior mask sb!unix:o_append))))) (t (setf if-exists :ignore-this-arg))) (unless if-does-not-exist-given (setf if-does-not-exist (cond ((eq direction :input) :error) ((and output (member if-exists '(:overwrite :append))) :error) ((eq direction :probe) nil) (t :create)))) (ensure-one-of if-does-not-exist '(:error :create nil) :if-does-not-exist) (if (eq if-does-not-exist :create) (setf mask (logior mask sb!unix:o_creat))) (let ((original (case if-exists ((:rename :rename-and-delete) (pick-backup-name namestring)) ((:append :overwrite) ;; KLUDGE: Provent CLOSE from deleting ;; appending streams when called with :ABORT T namestring))) (delete-original (eq if-exists :rename-and-delete)) (mode #o666)) (when (and original (not (eq original namestring))) ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine ;; whether the file already exists, make sure the original ;; file is not a directory, and keep the mode. (let ((exists (and namestring (multiple-value-bind (okay err/dev inode orig-mode) (sb!unix:unix-stat namestring) (declare (ignore inode) (type (or index null) orig-mode)) (cond (okay (when (and output (= (logand orig-mode #o170000) #o40000)) (error 'simple-file-error :pathname pathname :format-control "can't open ~S for output: is a directory" :format-arguments (list namestring))) (setf mode (logand orig-mode #o777)) t) ((eql err/dev sb!unix:enoent) nil) (t (simple-file-perror "can't find ~S" namestring err/dev))))))) (unless (and exists (rename-the-old-one namestring original)) (setf original nil) (setf delete-original nil) ;; In order to use :SUPERSEDE instead, we have to make ;; sure SB!UNIX:O_CREAT corresponds to ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before ;; because of IF-EXISTS being :RENAME. (unless (eq if-does-not-exist :create) (setf mask (logior (logandc2 mask sb!unix:o_creat) sb!unix:o_trunc))) (setf if-exists :supersede)))) ;; Now we can try the actual Unix open(2). (multiple-value-bind (fd errno) (if namestring (sb!unix:unix-open namestring mask mode) (values nil sb!unix:enoent)) (labels ((open-error (format-control &rest format-arguments) (error 'simple-file-error :pathname pathname :format-control format-control :format-arguments format-arguments)) (vanilla-open-error () (simple-file-perror "error opening ~S" pathname errno))) (cond ((numberp fd) (case direction ((:input :output :io) ;; For O_APPEND opened files, lseek returns 0 until first write. ;; So we jump ahead here. (when (eq if-exists :append) (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd)) (make-fd-stream fd :input input :output output :element-type element-type :external-format external-format :file namestring :original original :delete-original delete-original :pathname pathname :dual-channel-p nil :serve-events nil :input-buffer-p t :auto-close t)) (:probe (let ((stream (%make-fd-stream :name namestring :fd fd :pathname pathname :element-type element-type))) (close stream) stream)))) ((eql errno sb!unix:enoent) (case if-does-not-exist (:error (vanilla-open-error)) (:create (open-error "~@" pathname)) (t nil))) ((and (eql errno sb!unix:eexist) (null if-exists)) nil) (t (vanilla-open-error))))))))) ;;;; initialization ;;; the stream connected to the controlling terminal, or NIL if there is none (defvar *tty*) ;;; the stream connected to the standard input (file descriptor 0) (defvar *stdin*) ;;; the stream connected to the standard output (file descriptor 1) (defvar *stdout*) ;;; the stream connected to the standard error output (file descriptor 2) (defvar *stderr*) ;;; This is called when the cold load is first started up, and may also ;;; be called in an attempt to recover from nested errors. (defun stream-cold-init-or-reset () (stream-reinit) (setf *terminal-io* (make-synonym-stream '*tty*)) (setf *standard-output* (make-synonym-stream '*stdout*)) (setf *standard-input* (make-synonym-stream '*stdin*)) (setf *error-output* (make-synonym-stream '*stderr*)) (setf *query-io* (make-synonym-stream '*terminal-io*)) (setf *debug-io* *query-io*) (setf *trace-output* *standard-output*) (values)) (defun stream-deinit () ;; Unbind to make sure we're not accidently dealing with it ;; before we're ready (or after we think it's been deinitialized). (with-available-buffers-lock () (without-package-locks (makunbound '*available-buffers*)))) (defun stdstream-external-format (outputp) (declare (ignorable outputp)) (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage)) #!-win32 (default-external-format)) (ef (get-external-format keyword)) (replacement (ef-default-replacement-character ef))) `(,keyword :replacement ,replacement))) ;;; This is called whenever a saved core is restarted. (defun stream-reinit (&optional init-buffers-p) (when init-buffers-p (with-available-buffers-lock () (aver (not (boundp '*available-buffers*))) (setf *available-buffers* nil))) (with-output-to-string (*error-output*) (setf *stdin* (make-fd-stream 0 :name "standard input" :input t :buffering :line :element-type :default :serve-events t :external-format (stdstream-external-format nil))) (setf *stdout* (make-fd-stream 1 :name "standard output" :output t :buffering :line :element-type :default :external-format (stdstream-external-format t))) (setf *stderr* (make-fd-stream 2 :name "standard error" :output t :buffering :line :element-type :default :external-format (stdstream-external-format t))) (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty (setf *tty* (make-fd-stream tty :name "the terminal" :input t :output t :buffering :line :external-format (stdstream-external-format t) :serve-events t :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*)) (values)) ;;;; miscellany ;;; the Unix way to beep (defun beep (stream) (write-char (code-char bell-char-code) stream) (finish-output stream)) ;;; This is kind of like FILE-POSITION, but is an internal hack used ;;; by the filesys stuff to get and set the file name. ;;; ;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) (when (typep stream 'fd-stream) (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) (native-namestring (physicalize-pathname new-name) :as-file t)) t) (t (fd-stream-pathname stream)))))