Newer
Older
;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
;;;
;;; Routine to read in an unsigned 8 bit number.
;;;
(def-input-routine input-unsigned-8bit-byte
((unsigned-byte 8) 1 sap head)
;;; INPUT-SIGNED-8BIT-BYTE -- internal
;;;
;;; Routine to read in a signed 8 bit number.
;;;
(def-input-routine input-signed-8bit-number
((signed-byte 8) 1 sap head)
;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
;;;
;;; Routine to read in an unsigned 16 bit number.
;;;
(def-input-routine input-unsigned-16bit-byte
((unsigned-byte 16) 2 sap head)
(sap-ref-16 sap head))
;;; INPUT-SIGNED-16BIT-BYTE -- internal
;;;
;;; Routine to read in a signed 16 bit number.
;;;
(def-input-routine input-signed-16bit-byte
((signed-byte 16) 2 sap head)
(signed-sap-ref-16 sap head))
;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
;;;
;;; Routine to read in a unsigned 32 bit number.
;;;
(def-input-routine input-unsigned-32bit-byte
((unsigned-byte 32) 4 sap head)
(sap-ref-32 sap head))
;;; INPUT-SIGNED-32BIT-BYTE -- internal
;;;
;;; Routine to read in a signed 32 bit number.
;;;
(def-input-routine input-signed-32bit-byte
((signed-byte 32) 4 sap head)
(signed-sap-ref-32 sap head))
(stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
#|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
(let* ((head (fd-stream-ibuf-head stream))
(ch (catch 'eof-input-catcher
(stream::octets-to-char ,extfmt
(fd-stream-oc-state stream)
(fd-stream-last-char-read-size stream)
;;@@ Note: need proper EOF handling...
(progn
(when (= head (fd-stream-ibuf-tail stream))
(let ((sofar (- head (fd-stream-ibuf-head
stream))))
(do-input stream)
(setf head (+ (fd-stream-ibuf-head stream)
sofar))))
(bref (fd-stream-ibuf-sap stream)
(1- (incf head))))
(lambda (n) (decf head n))))))
(declare (type index head))
(if ch
(progn
(setf (fd-stream-ibuf-head stream) head)
ch)
(eof-or-lose stream eof-error-p eof-value)))))
#+(or)
(stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
`(lambda (stream string char start end)
(declare (type fd-stream stream)
(type simple-string string)
(type (or character null) char)
(type index start end)
(optimize (speed 3) (space 0) (debug 0) (safety 0)))
(let ((sap (fd-stream-ibuf-sap stream))
(head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(curr start))
(declare (type sys:system-area-pointer sap)
(type index head tail curr))
(loop
;;@@ Fix EOF handling
(let* ((sz 0)
(ch (catch 'eof-input-catcher
(stream::octets-to-char ,extfmt
(fd-stream-oc-state stream)
sz
(progn
(when (= head tail)
(let ((sofar (- head
(fd-stream-ibuf-head
stream))))
(do-input stream)
(setq head
(+ (fd-stream-ibuf-head
stream)
sofar)
tail
(fd-stream-ibuf-tail
stream))))
(bref sap (1- (incf head))))
(lambda (n) (decf head n))))))
(declare (type index sz)
(type (or null character) ch))
(when (null ch)
(return (values (- curr start) :eof)))
(setf (fd-stream-last-char-read-size stream) sz)
(incf (fd-stream-ibuf-head stream) sz)
(when (and char (char= ch char))
(return (values (- curr start) t)))
(setf (schar string (1- (incf curr))) ch)
(when (= curr end)
(return (values (- curr start) nil))))))))
;;; PICK-INPUT-ROUTINE -- internal
;;;
;;; 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.
;;;
(defun pick-input-routine (type)
(dolist (entry *input-routines*)
(when (subtypep type (car entry))
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
(return-from pick-input-routine
(values (symbol-function (cadr entry))
(car entry)
(caddr 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 max-stream-element-size ; 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 (fd-stream-ibuf-sap stream))
(head (fd-stream-ibuf-head stream)))
(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 max-stream-element-size ; 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 (fd-stream-ibuf-sap stream))
(head (fd-stream-ibuf-head stream)))
(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)))))
;;; STRING-FROM-SAP -- internal
;;;
;;; Returns a string constructed from the sap, start, and end.
;;;
(defun string-from-sap (sap start end)
(declare (type index start end))
(let* ((length (- end start))
(string (make-string length)))
(copy-from-system-area sap (* start vm:byte-bits)
string (* vm:vector-data-offset vm:word-bits)
(* length vm:byte-bits))
#|
;;; This version waits using server. I changed to the non-server version
;;; because it allows this method to be used by CLX w/o confusing serve-event.
;;; The non-server method is also significantly more efficient for large
;;; reads. -- Ram
;;;
;;; The n-bin routine.
;;;
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type stream stream) (type index start requested))
(let* ((sap (fd-stream-ibuf-sap stream))
(elsize (fd-stream-element-size stream))
(offset (* elsize start))
(bytes (* elsize requested))
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
(result
(catch 'eof-input-catcher
(loop
(input-at-least stream 1)
(let* ((head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(available (- tail head))
(copy (min available bytes)))
(if (typep buffer 'system-area-pointer)
(system-area-copy sap (* head vm:byte-bits)
buffer (* offset vm:byte-bits)
(* copy vm:byte-bits))
(copy-from-system-area sap (* head vm:byte-bits)
buffer (+ (* offset vm:byte-bits)
(* vm:vector-data-offset
vm:word-bits))
(* copy vm:byte-bits)))
(incf (fd-stream-ibuf-head stream) copy)
(incf offset copy)
(decf bytes copy))
(when (zerop bytes)
(return requested))))))
(or result
(eof-or-lose stream eof-error-p
(- requested (/ bytes elsize))))))
|#
;;; FD-STREAM-READ-N-BYTES -- internal
;;;
;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
;;; in UNIX-READ. This allows the method to be used to implement reading
;;; for CLX. It is generally used where there is a definite amount of reading
;;; to be done, so blocking isn't too problematical.
;;;
;;; We copy buffered data into the buffer. If there is enough, just return.
;;; Otherwise, we see if the amount of additional data needed will fit in the
;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
;;; argument), and read directly into the user supplied buffer. Otherwise,
;;; read a buffer-full into the stream buffer and then copy the amount we need
;;; out.
;;;
;;; We loop doing the reads until we either get enough bytes or hit EOF. We
;;; must loop when eof-errorp is T because some streams (like pipes) may return
;;; a partial amount without hitting EOF.
;;;
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type stream stream) (type index start requested))
(let* ((sap (fd-stream-ibuf-sap stream))
(head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(available (- tail head))
(copy (min requested available)))
(declare (type index offset head tail available copy))
;;
;; If something has been unread, put that at buffer + start,
;; and read the rest to start + 1.
(etypecase buffer
(system-area-pointer
(assert (= 1 (fd-stream-element-size stream)))
(setf (sap-ref-8 buffer start) (char-code (read-char stream))))
(string
(setf (aref buffer start) (read-char stream)))
(setf (aref buffer start) (char-code(read-char stream)))))
(return-from fd-stream-read-n-bytes
(1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
eof-error-p))))
;;
(unless (zerop copy)
(if (typep buffer 'system-area-pointer)
(system-area-copy sap (* head vm:byte-bits)
buffer (* offset vm:byte-bits)
(* copy vm:byte-bits))
(copy-from-system-area sap (* head vm:byte-bits)
buffer (+ (* offset vm:byte-bits)
(* vm:vector-data-offset
vm:word-bits))
(* copy vm:byte-bits)))
(incf (fd-stream-ibuf-head stream) copy))
(cond
((or (= copy requested)
(and (not eof-error-p) (/= copy 0)))
copy)
(t
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) 0)
(setf (fd-stream-listen stream) nil)
(let ((now-needed (- requested copy))
(len (fd-stream-ibuf-length stream)))
(declare (type index now-needed len))
(cond
((> now-needed len)
;;
;; If the desired amount is greater than the stream buffer size, then
;; read directly into the destination, incrementing the start
;; accordingly. In this case, we never leave anything in the stream
;; buffer.
(system:without-gcing
(loop
(multiple-value-bind
(count err)
(sap+ (if (typep buffer 'system-area-pointer)
buffer
(vector-sap buffer))
(+ offset copy))
now-needed)
(declare (type (or index null) count))
(unless count
(error (intl:gettext "Error reading ~S: ~A") stream
(decf now-needed count)
(if eof-error-p
(when (zerop count)
(error 'end-of-file :stream stream))
(return (- requested now-needed)))
(when (zerop now-needed) (return requested))
(incf offset count)))))
(t
;;
;; If we want less than the buffer size, then loop trying to fill the
;; stream buffer and copying what we get into the destination. When
;; we have enough, we leave what's left in the stream buffer.
(loop
(multiple-value-bind
(count err)
(unix:unix-read (fd-stream-fd stream) sap len)
(declare (type (or index null) count))
(unless count
(error (intl:gettext "Error reading ~S: ~A") stream
(when (and eof-error-p (zerop count))
(error 'end-of-file :stream stream))
(let* ((copy (min now-needed count))
(copy-bits (* copy vm:byte-bits))
(buffer-start-bits
(* (+ offset available) vm:byte-bits)))
(declare (type index copy copy-bits buffer-start-bits))
(if (typep buffer 'system-area-pointer)
(system-area-copy sap 0
buffer buffer-start-bits
copy-bits)
(copy-from-system-area sap 0
buffer (+ buffer-start-bits
(* vm:vector-data-offset
vm:word-bits))
copy-bits))
(decf now-needed copy)
(when (or (zerop now-needed) (not eof-error-p))
(setf (fd-stream-ibuf-head stream) copy)
(setf (fd-stream-ibuf-tail stream) count)
(return (- requested now-needed)))
;;;; Utility functions (misc routines, etc)
;;; SET-ROUTINES -- internal
;;;
;;; 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-routines (stream type input-p output-p buffer-p &key binary-stream-p)
(let ((target-type (case type
((:default unsigned-byte)
'(unsigned-byte 8))
(signed-byte
'(signed-byte 8))
(t
type)))
(input-type nil)
(output-type nil)
(input-size nil)
(output-size nil))
(when (fd-stream-obuf-sap stream)
(push (fd-stream-obuf-sap stream) *available-buffers*)
(setf (fd-stream-obuf-sap stream) nil))
(when (fd-stream-ibuf-sap stream)
(push (fd-stream-ibuf-sap stream) *available-buffers*)
(setf (fd-stream-ibuf-sap stream) nil))
#+unicode
(when (null (fd-stream-external-format stream))
(setf (fd-stream-external-format stream) :default))
(when input-p
(multiple-value-bind
(routine type size)
(pick-input-routine target-type)
(unless routine
(error (intl:gettext "Could not find any input routine for ~S") target-type))
(setf (fd-stream-ibuf-sap stream) (next-available-buffer))
(setf (fd-stream-ibuf-length stream) bytes-per-buffer)
(setf (fd-stream-ibuf-tail stream) 0)
;; Set the in and bin methods. Normally put an illegal input
;; function in, but if we have a binary text stream, pick an
;; appropriate input routine.
(setf (fd-stream-in stream) routine
(fd-stream-bin stream) (if (and binary-stream-p
(eql size 1))
(pick-input-routine '(unsigned-byte 8))
#'ill-bin))
(setf (fd-stream-in stream) (if (and binary-stream-p
(eql size 1))
(pick-input-routine 'character)
#'ill-in)
(when (or (eql size 1)
(eql size 2)
(eql size 4))
;; Support for n-byte operations on 8-, 16-, and 32-bit streams
(setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
(when (and buffer-p (eql size 1)
(or
;; FIXME: Do this better. We want to check for
;; (unsigned-byte 8). The 8 is unnecessary
;; since we already have size = 1.
(or (eq 'unsigned-byte (and (consp type) (car type)))
(eq type :default))
(eq type 'character)))
(when *enable-stream-buffer-p*
(when (and (not binary-stream-p)
(eq type 'character))
;; Create the in-buffer for any character (only)
;; stream. Don't want one for binary-text-streams!
(setf (lisp-stream-in-buffer stream)
(make-array in-buffer-length
:element-type '(unsigned-byte 8))))
(when (and (not binary-stream-p)
(eq type 'character)
(not (eq :iso8859-1 (fd-stream-external-format stream))))
;; For character streams, we create the string-buffer so
;; we can convert all available octets at once instead
;; of for each character. The string is one element
;; longer than in-buffer-length to leave room for
;; unreading.
;;
;; For ISO8859-1, we don't want this because it's very
;; easy and quick to convert octets to iso8859-1. (See
;; FAST-READ-CHAR.)
(setf (lisp-stream-string-buffer stream)
(make-string (1+ in-buffer-length)))
(setf (fd-stream-octet-count stream)
(make-array in-buffer-length :element-type '(unsigned-byte 8)))
(setf (lisp-stream-string-buffer-len stream) 0)
(setf (lisp-stream-string-index stream) 0)))))
(setf input-size size)
(setf input-type type)))
(when output-p
(multiple-value-bind
(routine type size)
(pick-output-routine target-type (fd-stream-buffering stream))
(unless routine
(error (intl:gettext "Could not find any output routine for ~S buffered ~S.")
(setf (fd-stream-obuf-sap stream) (next-available-buffer))
(setf (fd-stream-obuf-length stream) bytes-per-buffer)
;; Normally signal errors for reading from a stream with the
;; wrong element type, but allow binary-text-streams to read
;; from either.
(setf (fd-stream-out stream) routine
(fd-stream-bout stream)
(if (and binary-stream-p
(eql size 1))
(pick-output-routine '(unsigned-byte 8)
(fd-stream-buffering stream))
#'ill-bout))
(setf (fd-stream-out stream)
(if (and binary-stream-p (eql size 1))
(fd-stream-buffering stream))
#'ill-out)
(fd-stream-bout stream) routine))
(if (eql size 1) #'fd-sout #'ill-out))
(setf (fd-stream-char-pos stream) 0)
(setf output-size size)
(setf output-type type)))
(when (and input-size output-size
(error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?")
input-type input-size
output-type output-size))
(setf (fd-stream-element-size stream)
(or input-size output-size))
(setf (fd-stream-element-type 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 (intl:gettext "Input type (~S) and output type (~S) are unrelated?")
;;; REVERT-FILE -- internal
;;;
;;; Revert a file, if possible; otherwise do nothing. Used during
;;; CLOSE when the abort flag is set.
;;;
(defun revert-file (filename original)
(declare (type simple-base-string filename)
(type (or simple-base-string null) original))
(when original
(multiple-value-bind (okay err)
(unix:unix-rename original filename)
(unless okay
(cerror (intl:gettext "Go on as if nothing bad happened.")
(intl:gettext "Could not restore ~S to its original contents: ~A")
filename (unix:get-unix-error-msg err))))))
;;; DELETE-ORIGINAL -- internal
;;;
;;; Delete a backup file. Used during CLOSE.
;;;
(defun delete-original (filename original)
(declare (type simple-base-string filename)
(type (or simple-base-string null) original))
(when original
(multiple-value-bind (okay err) (unix:unix-unlink original)
(unless okay
(cerror "Go on as if nothing bad happened."
"Could not delete ~S during close of ~S: ~A"
original filename (unix:get-unix-error-msg err))))))
;;; FD-STREAM-MISC-ROUTINE -- input
;;;
;;; Handle the various misc operations on fd-stream.
;;;
(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
(or (not (eql (fd-stream-ibuf-head stream)
(fd-stream-ibuf-tail stream)))
(fd-stream-listen stream)
(setf (fd-stream-listen stream)
(eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
(unix:fd-zero read-fds)
(unix:fd-set (fd-stream-fd stream) read-fds)
(unix:unix-fast-select (1+ (fd-stream-fd stream))
(alien:addr read-fds) nil nil
0 0))
1))))
(setf (fd-stream-unread stream) arg1)
(cond ((lisp-stream-string-buffer stream)
(if (zerop (lisp-stream-string-index stream))
(setf (fd-stream-unread stream) arg1)
(decf (lisp-stream-string-index stream))))
(t
(if (zerop (fd-stream-last-char-read-size stream))
(setf (fd-stream-unread stream) arg1)
(decf (fd-stream-ibuf-head stream)
(fd-stream-last-char-read-size stream)))))
;; Paul says:
;;
;; Not needed for unicode when unreading is implemented by backing up in
;; the buffer (e.g., with last-char-read-size...)
;;
;; (AFAICS there's nothing wrong with setting it there, but it
;; screws up read-interactive in my toplevel command thing -
;; leaves it expecting to read arguments when it shouldn't,
;; because LISTEN returns T when there's no input pending, but I
;; don't understand why...)
#-unicode
(setf (fd-stream-listen stream) t))
(:close
(cond (arg1
;; We got us an abort on our hands.
(when (fd-stream-handler stream)
(system:remove-fd-handler (fd-stream-handler stream))
(setf (fd-stream-handler stream) nil))
(when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
(revert-file (fd-stream-file stream)
(fd-stream-original stream))))
#+(and unicode (not unicode-bootstrap))
(when (and (output-stream-p stream)
(eq (stream-element-type stream) 'character))
;; For output character streams, we need to flush out
;; any state that the external format might have.
#+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
(funcall (ef-flush (fd-stream-external-format stream))
stream))
(when (fd-stream-delete-original stream)
(delete-original (fd-stream-file stream)
(fd-stream-original stream)))))
(when (fboundp 'cancel-finalization)
(cancel-finalization stream))
(when (fd-stream-obuf-sap stream)
(push (fd-stream-obuf-sap stream) *available-buffers*)
(setf (fd-stream-obuf-sap stream) nil))
(when (fd-stream-ibuf-sap stream)
(push (fd-stream-ibuf-sap stream) *available-buffers*)
(setf (fd-stream-ibuf-sap stream) nil))
(:clear-input
(setf (fd-stream-unread stream) nil) ;;@@
#+unicode (setf (fd-stream-last-char-read-size stream) 0)
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) 0)
(multiple-value-bind
(count errno)
(alien:with-alien ((read-fds (alien:struct unix:fd-set)))
(unix:fd-zero read-fds)
(unix:fd-set (fd-stream-fd stream) read-fds)
(unix:unix-fast-select (1+ (fd-stream-fd stream))
(alien:addr read-fds) nil nil 0 0))
(cond ((eql count 1)
(do-input stream)
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) 0))
((and (not count) (eql errno unix:eintr)))
(:force-output
(flush-output-buffer stream))
(:finish-output
(flush-output-buffer stream)
(do ()
((null (fd-stream-output-later stream)))
(system:serve-all-events)))
(:element-type
(fd-stream-element-type stream))
(:interactive-p
(unix:unix-isatty (fd-stream-fd stream)))
(:line-length
80)
(:charpos
(fd-stream-char-pos stream))
(:file-length
(unless (fd-stream-file stream)
(error 'simple-type-error
:datum stream
:expected-type 'file-stream
:format-control (intl:gettext "~s is not a stream associated with a file.")
(multiple-value-bind
(okay dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks)
(declare (ignore ino nlink uid gid rdev
atime mtime ctime blksize blocks))
(unless okay
(error 'simple-file-error
:format-control (intl:gettext "Error fstating ~S: ~A")
:format-arguments (list stream (unix:get-unix-error-msg dev))))
(if (zerop mode)
(values (truncate size (fd-stream-element-size stream))))))
(fd-stream-file-position stream arg1))
(:clear-output
(setf (fd-stream-obuf-tail stream) 0))))
;;; FD-STREAM-FILE-POSITION -- internal.
;;;
(defun fd-stream-file-position (stream &optional newpos)
(declare (type fd-stream stream)
(type (or (integer 0) (member nil :start :end)) newpos))
;; First, find the position of the UNIX file descriptor in the file.
(posn errno)
(unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
(declare (type (or (integer 0) null) posn))
;; Adjust for buffered output:
;; If there is any output buffered, the *real* file position
;; will be larger than reported by lseek because lseek
;; sent yet.
(dolist (later (fd-stream-output-later stream))
(incf posn (- (the index (caddr later))
(the index (cadr later)))))
;; 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.
(decf posn (- (fd-stream-ibuf-tail stream)
(fd-stream-ibuf-head stream)))
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
(when (fd-stream-string-buffer stream)
;; The string buffer contains Lisp characters,
;; not octets! To figure out how many octets
;; have not been already supplied, we need to
;; count how many octets were consumed for all
;; the characters in the string bbuffer that have
;; not been supplied.
(let ((ocount (fd-stream-octet-count stream)))
(when ocount
;; Note: string-index starts at 1 (because
;; index 0 is for the unread-char), but
;; octet-count doesn't use that. Hence,
;; subtract one from string-index and
;; string-buffer-len.
#+nil
(progn
(format t "~&ocount = ~D~%" ocount)
(format t "posn = ~D~%" posn))
(loop for k of-type fixnum from (1- (fd-stream-string-index stream))
below (1- (fd-stream-string-buffer-len stream))
do (decf posn (aref ocount k)))
#+nil
(progn
(format t "new posn = ~D~%" posn)
(format t "in-buffer-length = ~D~%" in-buffer-length)
(format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))))))
(when (fd-stream-in-buffer stream)
;; When we have an in-buffer (whether we have a
;; string-buffer or not!), we need to adjust for
;; the octets that have not yet been supplied.
;; (This case happens with string-buffer when the
;; in-buffer does not have enough octets to form a
;; complete character.) If there's no
;; string-buffer and no in-buffer, then the ibuf
;; tail and head pointers contain all the
;; information needed.
#+nil
(progn
(format t "in-buffer-length = ~D~%" in-buffer-length)
(format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream)))
(fd-stream-in-index stream))))
#+nil
(format t "fd-stream-unread = ~S~%" (fd-stream-unread stream))
(truncate posn (fd-stream-element-size stream)))
(error (intl:gettext "Error lseek'ing ~S: ~A")
(let ((offset 0)
origin)
(declare (type (integer 0) offset))
;; 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.
(flush-output-buffer stream)
(do ()
((null (fd-stream-output-later stream)))
(system:serve-all-events))
;; Clear out any pending input to force the next read to go to the
;; disk.
(setf (fd-stream-unread stream) nil) ;;@@
#+unicode
(progn
(setf (fd-stream-last-char-read-size stream) 0)
(setf (fd-stream-string-index stream)
(fd-stream-string-buffer-len stream)))
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) 0)
;; Trash cached value for listen, so that we check next time.
(setf (fd-stream-listen stream) nil)
(setf offset 0
origin unix:l_set))
(setf offset 0
origin unix:l_xtnd))
((typep newpos '(integer 0))
(error (intl:gettext "Invalid position given to file-position: ~S") newpos)))
(unix:unix-lseek (fd-stream-fd stream) offset origin)
(error (intl:gettext "Error lseek'ing ~S: ~A")
;;;; Creation routines (MAKE-FD-STREAM and OPEN)
;; The unicode version of this is in fd-stream-extfmt.lisp
#-(and unicode (not unicode-boootstrap))
(defun %set-fd-stream-external-format (stream extfmt &optional (updatep t))
(declare (ignore stream extfmt updatep))
(values))
;;; MAKE-FD-STREAM -- Public.
;;;
;;; Returns a FD-STREAM on the given file.
;;;
(defun make-fd-stream (fd
&key
(input nil input-p)
(output nil output-p)
timeout
pathname
;; DO NOT translate these! It causes an
;; infinite loop. We need to open a file for
;; the translations, but if you translate
;; these, then we need to do a lookup which
;; wants to open the mo file which calls this
;; to name which causes a lookup ....
auto-close
binary-stream-p
decoding-error
encoding-error)
(declare (type index fd) (type (or index null) timeout)
(type (member :none :line :full) buffering))
"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 are 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.
External-format is the external format to use for the stream.
Decoding-error and Encoding-error indicate how decoding/encoding errors on
the stream should be handled. The default is to use a replacement character."
(cond ((not (or input-p output-p))
(setf input t))
((not (or input output))
(error (intl:gettext "File descriptor must be opened either for input or output."))))
(let ((stream (if binary-stream-p
(%make-binary-text-stream :fd fd
:name name
:file file
:original original
:delete-original delete-original
:pathname pathname
:buffering buffering
:timeout timeout)
(let ((e (cond ((characterp encoding-error)
(constantly (char-code encoding-error)))
(t
encoding-error)))
(d (cond ((characterp decoding-error)
(constantly (char-code decoding-error)))
((eq t decoding-error)
#'(lambda (&rest args)
(apply 'cerror
#+unicode _"Use Unicode replacement character instead"
#-unicode _"Use question mark character instead"
#+unicode
stream:+replacement-character-code+
#-unicode
(t
decoding-error))))
(%make-fd-stream :fd fd
:name name
:file file
:original original
:delete-original delete-original
:pathname pathname
:buffering buffering
:timeout timeout
:char-to-octets-error e
:octets-to-char-error d)))))
;; Set the lisp-stream flags appropriately for the kind of stream
;; we have (character, binary, binary-text-stream).
(cond ((typep stream 'binary-text-stream)
(setf (fd-stream-flags stream) #b100))
((subtypep element-type 'character)
(setf (fd-stream-flags stream) #b001))
(t
(setf (fd-stream-flags stream) #b010)))
;; FIXME: setting the external format here should be better
;; integrated into set-routines. We do it before so that
;; set-routines can create an in-buffer if appropriate. But we
;; need to do it after to put the correct input routines for the
;; external format.
;;#-unicode-bootstrap ; fails in stream-reinit otherwise
(%set-fd-stream-external-format stream external-format nil)
(set-routines stream element-type input output input-buffer-p
:binary-stream-p binary-stream-p)
(%set-fd-stream-external-format stream external-format nil)
(when (and auto-close (fboundp 'finalize))
(finalize stream
#'(lambda ()
(format *terminal-io* (intl:gettext "** Closed ~A~%") name)
;;; PICK-BACKUP-NAME -- internal
;;;
;;; Pick a name to use for the backup file.
;;;
(defvar *backup-extension* ".BAK"
"This is a string that OPEN tacks on the end of a file namestring to produce
a name for the :if-exists :rename-and-delete and :rename options. Also,
this can be a function that takes a namestring and returns a complete
namestring.")
;;;
(defun pick-backup-name (name)
(declare (type simple-string name))
(let ((ext *backup-extension*))
(etypecase ext
(simple-string (concatenate 'simple-string name ext))
(function (funcall ext name)))))
;;; NEXT-VERSION -- internal
;;;
;;; Find the next available versioned name for a file.
;;;
(defun next-version (name)
(declare (type simple-string name))
(let* ((*ignore-wildcards* t)
(sep (position #\/ name :from-end t))
(base (if sep (subseq name 0 (1+ sep)) ""))
(dir (unix:open-dir base)))
(multiple-value-bind (name type version)
(extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
(let ((version (if (symbolp version) 1 (1+ version)))
(match (if type
(concatenate 'string name "." type ".~")
(concatenate 'string name ".~"))))
(when dir
(unwind-protect
(loop
(let ((name (unix:read-dir dir)))
(cond ((null name) (return))
((and (> (length name) (length match))
(string= name match :end1 (length match)))
(multiple-value-bind (v e)
(parse-integer name :start (length match)
:junk-allowed t)
(when (and v
(= (length name) (1+ e))
(char= (schar name e) #\~))