| 1 | ;;;-*-Mode: LISP; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2009 Clozure Associates |
|---|
| 4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
|---|
| 5 | ;;; This file is part of Clozure CL. |
|---|
| 6 | ;;; |
|---|
| 7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
|---|
| 9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
|---|
| 11 | ;;; conflict, the preamble takes precedence. |
|---|
| 12 | ;;; |
|---|
| 13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
|---|
| 14 | ;;; |
|---|
| 15 | ;;; The LLGPL is also available online at |
|---|
| 16 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 17 | |
|---|
| 18 | (in-package "CCL") |
|---|
| 19 | |
|---|
| 20 | (defstruct (file-ioblock (:include ioblock)) |
|---|
| 21 | (octet-pos 0 ) ; current io position in octets |
|---|
| 22 | (fileeof 0 ) ; file length in elements |
|---|
| 23 | ) |
|---|
| 24 | |
|---|
| 25 | |
|---|
| 26 | |
|---|
| 27 | |
|---|
| 28 | ;;; The file-ioblock-octet-pos field is the (octet) position |
|---|
| 29 | ;;; at which the next I/O operation will begin (e.g., where the |
|---|
| 30 | ;;; input came from and/or where the output's going.) There are |
|---|
| 31 | ;;; cases (e.g., after a STREAM-CLEAR-INPUT) when this can't be |
|---|
| 32 | ;;; determined (based on its previous value and the logical size |
|---|
| 33 | ;;; of the buffer) so we'll have to ask the OS. |
|---|
| 34 | |
|---|
| 35 | (defun file-octet-filepos (file-ioblock) |
|---|
| 36 | (fd-tell (file-ioblock-device file-ioblock))) |
|---|
| 37 | |
|---|
| 38 | (defun synch-file-octet-filepos (file-ioblock) |
|---|
| 39 | (setf (file-ioblock-octet-pos file-ioblock) |
|---|
| 40 | (file-octet-filepos file-ioblock))) |
|---|
| 41 | |
|---|
| 42 | (defun infer-line-termination (file-ioblock) |
|---|
| 43 | (let* ((encoding (or (file-ioblock-encoding file-ioblock) |
|---|
| 44 | (get-character-encoding nil))) |
|---|
| 45 | (inbuf (file-ioblock-inbuf file-ioblock)) |
|---|
| 46 | (buffer (io-buffer-buffer inbuf)) |
|---|
| 47 | (n (io-buffer-count inbuf))) |
|---|
| 48 | (when (zerop n) |
|---|
| 49 | (setq n (or (fd-stream-advance (file-ioblock-stream file-ioblock) |
|---|
| 50 | file-ioblock |
|---|
| 51 | t) |
|---|
| 52 | 0))) |
|---|
| 53 | (multiple-value-bind (nchars last) |
|---|
| 54 | (funcall (character-encoding-length-of-vector-encoding-function encoding) |
|---|
| 55 | buffer |
|---|
| 56 | 0 |
|---|
| 57 | n) |
|---|
| 58 | (declare (fixnum nchars last)) |
|---|
| 59 | (let* ((string (make-string nchars))) |
|---|
| 60 | (declare (dynamic-extent string)) |
|---|
| 61 | (decode-character-encoded-vector encoding buffer 0 last string) |
|---|
| 62 | (let* ((line-termination |
|---|
| 63 | (do* ((i 0 (1+ i)) |
|---|
| 64 | (last-was-cr nil)) |
|---|
| 65 | ((= i nchars) (if last-was-cr :cr)) |
|---|
| 66 | (declare (fixnum i)) |
|---|
| 67 | (let* ((char (schar string i))) |
|---|
| 68 | (if last-was-cr |
|---|
| 69 | (if (eq char #\Linefeed) |
|---|
| 70 | (return :crlf) |
|---|
| 71 | (return :cr)) |
|---|
| 72 | (case char |
|---|
| 73 | (#\Newline (return nil)) |
|---|
| 74 | (#\Line_Separator (return :unicode)) |
|---|
| 75 | (#\Return (setq last-was-cr t)))))))) |
|---|
| 76 | (when line-termination |
|---|
| 77 | (install-ioblock-input-line-termination file-ioblock line-termination) |
|---|
| 78 | (when (file-ioblock-outbuf file-ioblock) |
|---|
| 79 | (install-ioblock-output-line-termination file-ioblock line-termination)))))) |
|---|
| 80 | (when (eq (ioblock-owner file-ioblock) *current-process*) |
|---|
| 81 | (setf (ioblock-owner file-ioblock) 0)))) |
|---|
| 82 | |
|---|
| 83 | |
|---|
| 84 | |
|---|
| 85 | (defvar *default-external-format* :unix) |
|---|
| 86 | |
|---|
| 87 | (defvar *default-file-character-encoding* nil) |
|---|
| 88 | |
|---|
| 89 | (defmethod default-character-encoding ((domain (eql :file))) |
|---|
| 90 | *default-file-character-encoding*) |
|---|
| 91 | |
|---|
| 92 | (defvar *default-line-termination* :unix |
|---|
| 93 | "The value of this variable is used when :EXTERNAL-FORMAT is |
|---|
| 94 | unspecified or specified as :DEFAULT. It can meaningfully be given any |
|---|
| 95 | of the values :UNIX, :MACOS, :MSDOS, :UNICODE or :INFERRED, each of which is |
|---|
| 96 | interpreted as described in the documentation. |
|---|
| 97 | |
|---|
| 98 | Because there's some risk that unsolicited newline translation could have |
|---|
| 99 | undesirable consequences, the initial value of this variable in Clozure CL |
|---|
| 100 | is :UNIX.") |
|---|
| 101 | |
|---|
| 102 | (defstruct (external-format (:constructor %make-external-format) |
|---|
| 103 | (:copier nil)) |
|---|
| 104 | (character-encoding :default :read-only t) |
|---|
| 105 | (line-termination :default :read-only t)) |
|---|
| 106 | |
|---|
| 107 | (defmethod print-object ((ef external-format) stream) |
|---|
| 108 | (print-unreadable-object (ef stream :type t :identity t) |
|---|
| 109 | (format stream "~s/~s" (external-format-character-encoding ef) (external-format-line-termination ef)))) |
|---|
| 110 | |
|---|
| 111 | |
|---|
| 112 | |
|---|
| 113 | (defvar *external-formats* (make-hash-table :test #'equal)) |
|---|
| 114 | |
|---|
| 115 | (defun make-external-format (&key (domain t) |
|---|
| 116 | (character-encoding :default) |
|---|
| 117 | (line-termination :default)) |
|---|
| 118 | (if (eq line-termination :default) |
|---|
| 119 | (setq line-termination *default-line-termination*)) |
|---|
| 120 | (unless (assq line-termination *canonical-line-termination-conventions*) |
|---|
| 121 | (error "~S is not a known line-termination format." line-termination)) |
|---|
| 122 | |
|---|
| 123 | (if (eq character-encoding :default) |
|---|
| 124 | (setq character-encoding |
|---|
| 125 | (default-character-encoding domain))) |
|---|
| 126 | (unless (lookup-character-encoding character-encoding) |
|---|
| 127 | (error "~S is not the name of a known character encoding." |
|---|
| 128 | character-encoding)) |
|---|
| 129 | (let* ((pair (cons character-encoding line-termination))) |
|---|
| 130 | (declare (dynamic-extent pair)) |
|---|
| 131 | (or (gethash pair *external-formats*) |
|---|
| 132 | (setf (gethash (cons character-encoding line-termination) *external-formats*) |
|---|
| 133 | (%make-external-format :character-encoding character-encoding |
|---|
| 134 | :line-termination line-termination))))) |
|---|
| 135 | |
|---|
| 136 | |
|---|
| 137 | |
|---|
| 138 | (defun normalize-external-format (domain external-format) |
|---|
| 139 | (cond ((listp external-format) |
|---|
| 140 | (unless (plistp external-format) |
|---|
| 141 | (error "External-format ~s is not a property list." external-format)) |
|---|
| 142 | (normalize-external-format domain (apply #'make-external-format :domain domain external-format))) |
|---|
| 143 | ((typep external-format 'external-format) |
|---|
| 144 | external-format) |
|---|
| 145 | ((eq external-format :default) |
|---|
| 146 | (normalize-external-format domain *default-external-format*)) |
|---|
| 147 | ((lookup-character-encoding external-format) |
|---|
| 148 | (normalize-external-format domain `(:character-encoding ,external-format))) |
|---|
| 149 | ((assq external-format *canonical-line-termination-conventions*) |
|---|
| 150 | (normalize-external-format domain `(:line-termination ,external-format))) |
|---|
| 151 | (t |
|---|
| 152 | (error "Invalid external-format: ~s" external-format)))) |
|---|
| 153 | |
|---|
| 154 | |
|---|
| 155 | |
|---|
| 156 | |
|---|
| 157 | |
|---|
| 158 | |
|---|
| 159 | |
|---|
| 160 | ;;; Establish a new position for the specified file-stream. |
|---|
| 161 | (defun file-ioblock-seek (file-ioblock newoctetpos) |
|---|
| 162 | (let* ((result (fd-lseek |
|---|
| 163 | (file-ioblock-device file-ioblock) newoctetpos #$SEEK_SET))) |
|---|
| 164 | (if (< result 0) |
|---|
| 165 | (error 'simple-stream-error |
|---|
| 166 | :stream (file-ioblock-stream file-ioblock) |
|---|
| 167 | :format-control (format nil "Can't set file position to ~d: ~a" |
|---|
| 168 | newoctetpos (%strerror result))) |
|---|
| 169 | newoctetpos))) |
|---|
| 170 | |
|---|
| 171 | ;;; For input streams, getting/setting the position is fairly simple. |
|---|
| 172 | ;;; Getting the position is a simple matter of adding the buffer |
|---|
| 173 | ;;; origin to the current position within the buffer. |
|---|
| 174 | ;;; Setting the position involves either adjusting the buffer index |
|---|
| 175 | ;;; (if the new position is within the current buffer) or seeking |
|---|
| 176 | ;;; to a new position. |
|---|
| 177 | |
|---|
| 178 | (defun %ioblock-input-file-position (file-ioblock newpos) |
|---|
| 179 | (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) |
|---|
| 180 | (element-base (ioblock-octets-to-elements file-ioblock octet-base)) |
|---|
| 181 | (inbuf (file-ioblock-inbuf file-ioblock)) |
|---|
| 182 | (curpos (+ element-base (io-buffer-idx inbuf)))) |
|---|
| 183 | (if (null newpos) |
|---|
| 184 | curpos |
|---|
| 185 | (progn |
|---|
| 186 | (if (and (>= newpos element-base) |
|---|
| 187 | (< newpos (+ element-base (io-buffer-count inbuf)))) |
|---|
| 188 | (setf (io-buffer-idx inbuf) (- newpos element-base)) |
|---|
| 189 | (file-ioblock-seek-and-reset file-ioblock |
|---|
| 190 | (ioblock-elements-to-octets |
|---|
| 191 | file-ioblock |
|---|
| 192 | newpos))) |
|---|
| 193 | newpos)))) |
|---|
| 194 | |
|---|
| 195 | ;;; For (pure) output streams, it's a little more complicated. If we |
|---|
| 196 | ;;; have to seek to a new origin, we may need to flush the buffer |
|---|
| 197 | ;;; first. |
|---|
| 198 | |
|---|
| 199 | (defun %ioblock-output-file-position (file-ioblock newpos) |
|---|
| 200 | (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) |
|---|
| 201 | (element-base (ioblock-octets-to-elements file-ioblock octet-base)) |
|---|
| 202 | (outbuf (file-ioblock-outbuf file-ioblock)) |
|---|
| 203 | (curpos (+ element-base (io-buffer-idx outbuf))) |
|---|
| 204 | (maxpos (+ element-base (io-buffer-count outbuf)))) |
|---|
| 205 | (if (null newpos) |
|---|
| 206 | curpos |
|---|
| 207 | (progn |
|---|
| 208 | (unless (= newpos 0) |
|---|
| 209 | (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) |
|---|
| 210 | (if (and (>= newpos element-base) |
|---|
| 211 | (<= newpos maxpos)) |
|---|
| 212 | ;; Backing up is easy. Skipping forward (without flushing |
|---|
| 213 | ;; and seeking) would be hard, 'cause we can't tell what |
|---|
| 214 | ;; we're skipping over. |
|---|
| 215 | (let* ((newidx (- newpos element-base))) |
|---|
| 216 | (setf (io-buffer-idx outbuf) newidx)) |
|---|
| 217 | (progn |
|---|
| 218 | (when (file-ioblock-dirty file-ioblock) |
|---|
| 219 | (fd-stream-force-output (file-ioblock-stream file-ioblock) |
|---|
| 220 | file-ioblock |
|---|
| 221 | (io-buffer-count outbuf) |
|---|
| 222 | nil) |
|---|
| 223 | ;; May have just extended the file; may need to update |
|---|
| 224 | ;; fileeof. |
|---|
| 225 | (when (> maxpos (file-ioblock-fileeof file-ioblock)) |
|---|
| 226 | (setf (file-ioblock-fileeof file-ioblock) maxpos))) |
|---|
| 227 | (file-ioblock-seek-and-reset file-ioblock |
|---|
| 228 | (ioblock-elements-to-octets |
|---|
| 229 | file-ioblock |
|---|
| 230 | newpos)))) |
|---|
| 231 | newpos)))) |
|---|
| 232 | |
|---|
| 233 | ;;; For I/O file streams, there's an additional complication: if we |
|---|
| 234 | ;;; back up within the (shared) buffer and the old position was beyond |
|---|
| 235 | ;;; the buffer's input count, we have to set the input count to the |
|---|
| 236 | ;;; old position. (Consider the case of writing a single element at |
|---|
| 237 | ;;; the end-of-file, backing up one element, then reading the element |
|---|
| 238 | ;;; we wrote.) We -can- skip forward over stuff that's been read; |
|---|
| 239 | ;;; if the buffer's dirty, we'll eventually write it back out. |
|---|
| 240 | |
|---|
| 241 | (defun %ioblock-io-file-position (file-ioblock newpos) |
|---|
| 242 | (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) |
|---|
| 243 | (element-base (ioblock-octets-to-elements file-ioblock octet-base)) |
|---|
| 244 | (outbuf (file-ioblock-outbuf file-ioblock)) ; outbuf = inbuf |
|---|
| 245 | (curidx (io-buffer-idx outbuf)) |
|---|
| 246 | (curpos (+ element-base curidx))) |
|---|
| 247 | (if (null newpos) |
|---|
| 248 | curpos |
|---|
| 249 | (let* ((incount (io-buffer-count outbuf))) |
|---|
| 250 | (unless (= newpos 0) |
|---|
| 251 | (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) |
|---|
| 252 | (cond |
|---|
| 253 | ((and (>= newpos element-base) |
|---|
| 254 | (<= newpos curpos)) |
|---|
| 255 | ;; If we've read less than we've written, make what's |
|---|
| 256 | ;; been written available for subsequent input. |
|---|
| 257 | (when (> curidx incount) |
|---|
| 258 | (setf (io-buffer-count outbuf) curidx)) |
|---|
| 259 | (setf (io-buffer-idx outbuf) (- newpos element-base))) |
|---|
| 260 | ((and (>= newpos element-base) |
|---|
| 261 | (< newpos (+ element-base incount))) |
|---|
| 262 | (setf (io-buffer-idx outbuf) (- newpos element-base))) |
|---|
| 263 | (t |
|---|
| 264 | (let* ((maxpos (+ element-base (io-buffer-count outbuf)))) |
|---|
| 265 | (when (> maxpos (file-ioblock-fileeof file-ioblock)) |
|---|
| 266 | (setf (file-ioblock-fileeof file-ioblock) maxpos))) |
|---|
| 267 | (when (file-ioblock-dirty file-ioblock) |
|---|
| 268 | (file-ioblock-seek file-ioblock octet-base) |
|---|
| 269 | (fd-stream-force-output (file-ioblock-stream file-ioblock) |
|---|
| 270 | file-ioblock |
|---|
| 271 | (io-buffer-count outbuf) |
|---|
| 272 | nil)) |
|---|
| 273 | (file-ioblock-seek-and-reset file-ioblock |
|---|
| 274 | (ioblock-elements-to-octets |
|---|
| 275 | file-ioblock newpos)))) |
|---|
| 276 | newpos)))) |
|---|
| 277 | |
|---|
| 278 | ;;; Again, it's simplest to define this in terms of the stream's direction. |
|---|
| 279 | ;;; Note that we can't change the size of file descriptors open for input |
|---|
| 280 | ;;; only. |
|---|
| 281 | |
|---|
| 282 | (defun %ioblock-input-file-length (file-ioblock newlen) |
|---|
| 283 | (unless newlen |
|---|
| 284 | (file-ioblock-fileeof file-ioblock))) |
|---|
| 285 | |
|---|
| 286 | (defun %ioblock-output-file-length (file-ioblock newlen) |
|---|
| 287 | (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) |
|---|
| 288 | (element-base (ioblock-octets-to-elements file-ioblock octet-base)) |
|---|
| 289 | (outbuf (file-ioblock-outbuf file-ioblock)) |
|---|
| 290 | (curidx (io-buffer-idx outbuf)) |
|---|
| 291 | (maxpos (+ element-base (io-buffer-count outbuf))) |
|---|
| 292 | (curlen (file-ioblock-fileeof file-ioblock))) |
|---|
| 293 | (if (> maxpos curlen) |
|---|
| 294 | (setf (file-ioblock-fileeof file-ioblock) (setq curlen maxpos))) |
|---|
| 295 | (if (null newlen) |
|---|
| 296 | curlen |
|---|
| 297 | (let* ((fd (file-ioblock-device file-ioblock)) |
|---|
| 298 | (new-octet-eof (ioblock-elements-to-octets file-ioblock newlen)) |
|---|
| 299 | (cur-octet-pos (fd-tell fd))) |
|---|
| 300 | (cond ((> newlen curlen) |
|---|
| 301 | ;; Extend the file; maintain the current position. |
|---|
| 302 | ;; ftruncate isn't guaranteed to extend a file past |
|---|
| 303 | ;; its current EOF. Seeking to the new EOF, then |
|---|
| 304 | ;; writing, is guaranteed to do so. Seek to the |
|---|
| 305 | ;; new EOF, write a random byte, truncate to the |
|---|
| 306 | ;; specified length, then seek back to where we |
|---|
| 307 | ;; were and pretend that nothing happened. |
|---|
| 308 | (file-ioblock-seek file-ioblock new-octet-eof) |
|---|
| 309 | (%stack-block ((buf 1)) |
|---|
| 310 | (fd-write fd buf 1)) |
|---|
| 311 | (fd-ftruncate fd new-octet-eof) |
|---|
| 312 | (file-ioblock-seek file-ioblock cur-octet-pos)) |
|---|
| 313 | ((> newlen maxpos) |
|---|
| 314 | ;; Make the file shorter. Doesn't affect |
|---|
| 315 | ;; our position or anything that we have buffered. |
|---|
| 316 | (fd-ftruncate fd new-octet-eof)) |
|---|
| 317 | ((< newlen element-base) |
|---|
| 318 | ;; Discard any buffered output. Truncate the |
|---|
| 319 | ;; file, then seek to the new EOF. |
|---|
| 320 | (fd-ftruncate fd new-octet-eof) |
|---|
| 321 | (file-ioblock-seek-and-reset file-ioblock new-octet-eof)) |
|---|
| 322 | (t |
|---|
| 323 | (fd-ftruncate fd new-octet-eof) |
|---|
| 324 | (let* ((newidx (- newlen element-base))) |
|---|
| 325 | (when (> maxpos newlen) |
|---|
| 326 | (setf (io-buffer-count outbuf) newidx)) |
|---|
| 327 | (when (> curidx newidx) |
|---|
| 328 | (setf (io-buffer-idx outbuf) newidx))))) |
|---|
| 329 | (setf (file-ioblock-fileeof file-ioblock) newlen))))) |
|---|
| 330 | |
|---|
| 331 | |
|---|
| 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 333 | (defclass fundamental-file-stream (fd-stream file-stream) |
|---|
| 334 | ((filename :initform nil :initarg :filename :accessor file-stream-filename) |
|---|
| 335 | (actual-filename :initform nil :initarg :actual-filename) |
|---|
| 336 | (external-format :initform :default :initarg :external-format |
|---|
| 337 | :accessor file-stream-external-format))) |
|---|
| 338 | |
|---|
| 339 | |
|---|
| 340 | |
|---|
| 341 | (defmethod stream-filename ((s fundamental-file-stream)) |
|---|
| 342 | (file-stream-filename s)) |
|---|
| 343 | |
|---|
| 344 | (defmethod stream-actual-filename ((s file-stream)) |
|---|
| 345 | (slot-value s 'actual-filename)) |
|---|
| 346 | |
|---|
| 347 | (defmethod (setf stream-filename) (new (s fundamental-file-stream)) |
|---|
| 348 | (setf (file-stream-filename s) new)) |
|---|
| 349 | |
|---|
| 350 | (defmethod (setf stream-actual-filename) (new (s fundamental-file-stream)) |
|---|
| 351 | (setf (slot-value s 'actual-filename) new)) |
|---|
| 352 | |
|---|
| 353 | (defun print-file-stream (s out) |
|---|
| 354 | (print-unreadable-object (s out :type t :identity t) |
|---|
| 355 | (let* ((file-ioblock (stream-ioblock s nil))) |
|---|
| 356 | (format out "(~s/" (stream-filename s)) |
|---|
| 357 | (if file-ioblock |
|---|
| 358 | (format out "~d ~a)" (file-ioblock-device file-ioblock) (encoding-name (ioblock-encoding file-ioblock))) |
|---|
| 359 | (format out ":closed"))))) |
|---|
| 360 | |
|---|
| 361 | (defmethod print-object ((s fundamental-file-stream) out) |
|---|
| 362 | (print-file-stream s out)) |
|---|
| 363 | |
|---|
| 364 | (make-built-in-class 'basic-file-stream 'file-stream 'basic-stream) |
|---|
| 365 | |
|---|
| 366 | (defmethod stream-filename ((s basic-file-stream)) |
|---|
| 367 | (basic-file-stream.filename s)) |
|---|
| 368 | |
|---|
| 369 | (defmethod stream-actual-filename ((s basic-file-stream)) |
|---|
| 370 | (basic-file-stream.actual-filename s)) |
|---|
| 371 | |
|---|
| 372 | (defmethod (setf stream-filename) (new (s basic-file-stream)) |
|---|
| 373 | (setf (basic-file-stream.filename s) new)) |
|---|
| 374 | |
|---|
| 375 | (defmethod (setf stream-actual-filename) (new (s basic-file-stream)) |
|---|
| 376 | (setf (basic-file-stream.actual-filename s) new)) |
|---|
| 377 | |
|---|
| 378 | (defmethod print-object ((s basic-file-stream) out) |
|---|
| 379 | (print-file-stream s out)) |
|---|
| 380 | |
|---|
| 381 | |
|---|
| 382 | (defmethod initialize-basic-stream ((s basic-file-stream) &key element-type external-format &allow-other-keys) |
|---|
| 383 | (setf (getf (basic-stream.info s) :element-type) element-type) |
|---|
| 384 | (setf (basic-file-stream.external-format s) external-format)) |
|---|
| 385 | |
|---|
| 386 | (defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key) |
|---|
| 387 | (declare (dynamic-extent args)) |
|---|
| 388 | (apply #'make-file-ioblock :stream stream args)) |
|---|
| 389 | |
|---|
| 390 | (defmethod stream-create-ioblock ((stream basic-file-stream) &rest args &key) |
|---|
| 391 | (declare (dynamic-extent args)) |
|---|
| 392 | (apply #'make-file-ioblock :stream stream args)) |
|---|
| 393 | |
|---|
| 394 | (defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream) |
|---|
| 395 | ()) |
|---|
| 396 | |
|---|
| 397 | (make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream) |
|---|
| 398 | |
|---|
| 399 | |
|---|
| 400 | (defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream) |
|---|
| 401 | ()) |
|---|
| 402 | |
|---|
| 403 | (make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream) |
|---|
| 404 | |
|---|
| 405 | (defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream) |
|---|
| 406 | ()) |
|---|
| 407 | |
|---|
| 408 | (make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream) |
|---|
| 409 | |
|---|
| 410 | |
|---|
| 411 | (defclass fundamental-file-character-input-stream (fundamental-file-input-stream |
|---|
| 412 | fd-character-input-stream) |
|---|
| 413 | ()) |
|---|
| 414 | |
|---|
| 415 | (make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream) |
|---|
| 416 | |
|---|
| 417 | |
|---|
| 418 | (defclass fundamental-file-character-output-stream (fundamental-file-output-stream |
|---|
| 419 | fd-character-output-stream) |
|---|
| 420 | ()) |
|---|
| 421 | |
|---|
| 422 | (make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream) |
|---|
| 423 | |
|---|
| 424 | (defclass fundamental-file-character-io-stream (fundamental-file-io-stream |
|---|
| 425 | fd-character-io-stream) |
|---|
| 426 | ()) |
|---|
| 427 | |
|---|
| 428 | (make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream) |
|---|
| 429 | |
|---|
| 430 | (defclass fundamental-file-binary-input-stream (fundamental-file-input-stream |
|---|
| 431 | fd-binary-input-stream) |
|---|
| 432 | ()) |
|---|
| 433 | |
|---|
| 434 | (make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream) |
|---|
| 435 | |
|---|
| 436 | (defclass fundamental-file-binary-output-stream (fundamental-file-output-stream |
|---|
| 437 | fd-binary-output-stream) |
|---|
| 438 | ()) |
|---|
| 439 | |
|---|
| 440 | (make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream) |
|---|
| 441 | |
|---|
| 442 | (defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream) |
|---|
| 443 | ()) |
|---|
| 444 | |
|---|
| 445 | (make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream) |
|---|
| 446 | |
|---|
| 447 | |
|---|
| 448 | |
|---|
| 449 | |
|---|
| 450 | ;;; This stuff is a lot simpler if we restrict the hair to the |
|---|
| 451 | ;;; case of file streams opened in :io mode (which have to worry |
|---|
| 452 | ;;; about flushing the shared buffer before filling it, and things |
|---|
| 453 | ;;; like that.) |
|---|
| 454 | |
|---|
| 455 | (defmethod stream-clear-input ((f fundamental-file-input-stream)) |
|---|
| 456 | (with-stream-ioblock-input (file-ioblock f :speedy t) |
|---|
| 457 | (call-next-method) |
|---|
| 458 | (synch-file-octet-filepos file-ioblock) |
|---|
| 459 | nil)) |
|---|
| 460 | |
|---|
| 461 | |
|---|
| 462 | (defmethod stream-clear-input ((f basic-file-input-stream)) |
|---|
| 463 | (let* ((file-ioblock (basic-stream-ioblock f))) |
|---|
| 464 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 465 | (call-next-method) |
|---|
| 466 | (synch-file-octet-filepos file-ioblock) |
|---|
| 467 | nil))) |
|---|
| 468 | |
|---|
| 469 | |
|---|
| 470 | (defmethod stream-clear-input ((f fundamental-file-io-stream)) |
|---|
| 471 | (with-stream-ioblock-input (file-ioblock f :speedy t) |
|---|
| 472 | (stream-force-output f) |
|---|
| 473 | (call-next-method) |
|---|
| 474 | (synch-file-octet-filepos file-ioblock) |
|---|
| 475 | nil)) |
|---|
| 476 | |
|---|
| 477 | (defmethod stream-clear-input ((f basic-file-io-stream)) |
|---|
| 478 | (let* ((file-ioblock (basic-stream-ioblock f))) |
|---|
| 479 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 480 | (call-next-method) |
|---|
| 481 | (synch-file-octet-filepos file-ioblock) |
|---|
| 482 | nil))) |
|---|
| 483 | |
|---|
| 484 | (defmethod stream-clear-output ((f fundamental-file-output-stream)) |
|---|
| 485 | (with-stream-ioblock-output (file-ioblock f :speedy t) |
|---|
| 486 | (call-next-method) |
|---|
| 487 | (synch-file-octet-filepos file-ioblock) |
|---|
| 488 | nil)) |
|---|
| 489 | |
|---|
| 490 | (defmethod stream-clear-output ((f basic-file-output-stream)) |
|---|
| 491 | (let* ((file-ioblock (basic-stream-ioblock f))) |
|---|
| 492 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 493 | (call-next-method) |
|---|
| 494 | (synch-file-octet-filepos file-ioblock) |
|---|
| 495 | nil))) |
|---|
| 496 | |
|---|
| 497 | |
|---|
| 498 | |
|---|
| 499 | ;;; If we've been reading, the file position where we're going |
|---|
| 500 | ;;; to read this time is (+ where-it-was-last-time what-we-read-last-time.) |
|---|
| 501 | (defun input-file-ioblock-advance (stream file-ioblock read-p) |
|---|
| 502 | (let* ((newpos (+ (file-ioblock-octet-pos file-ioblock) |
|---|
| 503 | (io-buffer-count (file-ioblock-inbuf file-ioblock))))) |
|---|
| 504 | (setf (file-ioblock-octet-pos file-ioblock) newpos) |
|---|
| 505 | (fd-stream-advance stream file-ioblock read-p))) |
|---|
| 506 | |
|---|
| 507 | ;;; If the buffer's dirty, we have to back up and rewrite it before |
|---|
| 508 | ;;; reading in a new buffer. |
|---|
| 509 | (defun io-file-ioblock-advance (stream file-ioblock read-p) |
|---|
| 510 | (let* ((curpos (file-ioblock-octet-pos file-ioblock)) |
|---|
| 511 | (count (io-buffer-count (file-ioblock-inbuf file-ioblock))) |
|---|
| 512 | (newpos (+ curpos |
|---|
| 513 | (ioblock-elements-to-octets file-ioblock count)))) |
|---|
| 514 | (when (ioblock-dirty file-ioblock) |
|---|
| 515 | (file-ioblock-seek file-ioblock curpos) |
|---|
| 516 | (fd-stream-force-output stream file-ioblock count nil)) |
|---|
| 517 | (unless (eql newpos (file-octet-filepos file-ioblock)) |
|---|
| 518 | (error "Expected newpos to be ~d, fd is at ~d" |
|---|
| 519 | newpos (file-octet-filepos file-ioblock))) |
|---|
| 520 | (setf (file-ioblock-octet-pos file-ioblock) newpos) |
|---|
| 521 | (fd-stream-advance stream file-ioblock read-p))) |
|---|
| 522 | |
|---|
| 523 | |
|---|
| 524 | (defun output-file-force-output (stream file-ioblock count finish-p) |
|---|
| 525 | (let* ((pos (%ioblock-output-file-position file-ioblock nil)) |
|---|
| 526 | (n (fd-stream-force-output stream file-ioblock count finish-p))) |
|---|
| 527 | (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) |
|---|
| 528 | (%ioblock-output-file-position file-ioblock pos) |
|---|
| 529 | n)) |
|---|
| 530 | |
|---|
| 531 | ;;; Can't be sure where the underlying fd is positioned, so seek first. |
|---|
| 532 | (defun io-file-force-output (stream file-ioblock count finish-p) |
|---|
| 533 | (let* ((pos (%ioblock-io-file-position file-ioblock nil))) |
|---|
| 534 | (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock)) |
|---|
| 535 | (let* ((n (fd-stream-force-output stream file-ioblock count finish-p))) |
|---|
| 536 | (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) |
|---|
| 537 | (%ioblock-io-file-position file-ioblock pos) |
|---|
| 538 | n))) |
|---|
| 539 | |
|---|
| 540 | |
|---|
| 541 | ;;; Invalidate both buffers and seek to the new position. The output |
|---|
| 542 | ;;; buffer's been flushed already if it needed to be. |
|---|
| 543 | |
|---|
| 544 | (defun file-ioblock-seek-and-reset (file-ioblock newoctetpos) |
|---|
| 545 | (let* ((inbuf (file-ioblock-inbuf file-ioblock)) |
|---|
| 546 | (outbuf (file-ioblock-outbuf file-ioblock))) |
|---|
| 547 | (setf (file-ioblock-dirty file-ioblock) nil) |
|---|
| 548 | (when inbuf |
|---|
| 549 | (setf (io-buffer-count inbuf) 0 |
|---|
| 550 | (io-buffer-idx inbuf) 0)) |
|---|
| 551 | (when outbuf |
|---|
| 552 | (setf (io-buffer-count outbuf) 0 |
|---|
| 553 | (io-buffer-idx outbuf) 0)) |
|---|
| 554 | (setf (file-ioblock-octet-pos file-ioblock) newoctetpos) |
|---|
| 555 | (file-ioblock-seek file-ioblock newoctetpos))) |
|---|
| 556 | |
|---|
| 557 | (defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos) |
|---|
| 558 | (with-stream-ioblock-input (file-ioblock stream :speedy t) |
|---|
| 559 | (%ioblock-input-file-position file-ioblock newpos))) |
|---|
| 560 | |
|---|
| 561 | |
|---|
| 562 | (defmethod stream-position ((stream basic-file-input-stream) &optional newpos) |
|---|
| 563 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 564 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 565 | (%ioblock-input-file-position file-ioblock newpos)))) |
|---|
| 566 | |
|---|
| 567 | (defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos) |
|---|
| 568 | (with-stream-ioblock-output (file-ioblock stream :speedy t) |
|---|
| 569 | (%ioblock-output-file-position file-ioblock newpos))) |
|---|
| 570 | |
|---|
| 571 | (defmethod stream-position ((stream basic-file-output-stream) &optional newpos) |
|---|
| 572 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 573 | (with-ioblock-output-locked (file-ioblock) |
|---|
| 574 | (%ioblock-output-file-position file-ioblock newpos)))) |
|---|
| 575 | |
|---|
| 576 | |
|---|
| 577 | (defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos) |
|---|
| 578 | (with-stream-ioblock-input (file-ioblock stream :speedy t) |
|---|
| 579 | (%ioblock-io-file-position file-ioblock newpos))) |
|---|
| 580 | |
|---|
| 581 | (defmethod stream-position ((stream basic-file-io-stream) &optional newpos) |
|---|
| 582 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 583 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 584 | (%ioblock-io-file-position file-ioblock newpos)))) |
|---|
| 585 | |
|---|
| 586 | |
|---|
| 587 | (defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen) |
|---|
| 588 | (with-stream-ioblock-input (file-ioblock stream :speedy t) |
|---|
| 589 | (let* ((res (%ioblock-input-file-length file-ioblock newlen))) |
|---|
| 590 | (and res (>= res 0) res)))) |
|---|
| 591 | |
|---|
| 592 | |
|---|
| 593 | (defmethod stream-length ((stream basic-file-input-stream) &optional newlen) |
|---|
| 594 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 595 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 596 | (let* ((res (%ioblock-input-file-length file-ioblock newlen))) |
|---|
| 597 | (and res (>= res 0) res))))) |
|---|
| 598 | |
|---|
| 599 | |
|---|
| 600 | (defmethod stream-length ((s fundamental-file-output-stream) &optional newlen) |
|---|
| 601 | (with-stream-ioblock-output (file-ioblock s :speedy t) |
|---|
| 602 | (let* ((res (%ioblock-output-file-length file-ioblock newlen))) |
|---|
| 603 | (and res (>= res 0) res)))) |
|---|
| 604 | |
|---|
| 605 | |
|---|
| 606 | (defmethod stream-length ((stream basic-file-output-stream) &optional newlen) |
|---|
| 607 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 608 | (with-ioblock-output-locked (file-ioblock) |
|---|
| 609 | (let* ((res (%ioblock-output-file-length file-ioblock newlen))) |
|---|
| 610 | (and res (>= res 0) res))))) |
|---|
| 611 | |
|---|
| 612 | (defmethod stream-length ((s fundamental-file-io-stream) &optional newlen) |
|---|
| 613 | (with-stream-ioblock-input (file-ioblock s :speedy t) |
|---|
| 614 | (let* ((res (%ioblock-output-file-length file-ioblock newlen))) |
|---|
| 615 | (and res (>= res 0) res)))) |
|---|
| 616 | |
|---|
| 617 | (defmethod stream-length ((stream basic-file-io-stream) &optional newlen) |
|---|
| 618 | (let* ((file-ioblock (basic-stream-ioblock stream))) |
|---|
| 619 | (with-ioblock-input-locked (file-ioblock) |
|---|
| 620 | (let* ((res (%ioblock-output-file-length file-ioblock newlen))) |
|---|
| 621 | (and res (>= res 0) res))))) |
|---|
| 622 | |
|---|
| 623 | (defun close-file-stream (s abort) |
|---|
| 624 | (when (open-stream-p s) |
|---|
| 625 | (let* ((ioblock (stream-ioblock s t)) |
|---|
| 626 | (filename (stream-filename s)) |
|---|
| 627 | (actual-filename (stream-actual-filename s))) |
|---|
| 628 | (when actual-filename ; t => created when opened |
|---|
| 629 | (if abort |
|---|
| 630 | (progn |
|---|
| 631 | (setf (ioblock-dirty ioblock) nil) |
|---|
| 632 | (fd-stream-close s ioblock) |
|---|
| 633 | (if (eq actual-filename t) |
|---|
| 634 | (delete-file filename) |
|---|
| 635 | (unix-rename (namestring actual-filename) (probe-file-x filename)))) |
|---|
| 636 | (unless (eq actual-filename t) |
|---|
| 637 | (delete-file actual-filename)))) |
|---|
| 638 | (remove-open-file-stream s)))) |
|---|
| 639 | |
|---|
| 640 | |
|---|
| 641 | (defmethod close ((s fundamental-file-stream) &key abort) |
|---|
| 642 | (close-file-stream s abort) |
|---|
| 643 | (call-next-method)) |
|---|
| 644 | |
|---|
| 645 | (defmethod close ((s basic-file-stream) &key abort) |
|---|
| 646 | (close-file-stream s abort) |
|---|
| 647 | (call-next-method)) |
|---|
| 648 | |
|---|
| 649 | (defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p) |
|---|
| 650 | (if char-p |
|---|
| 651 | (if (and in-p out-p) |
|---|
| 652 | 'fundamental-file-character-io-stream |
|---|
| 653 | (if in-p |
|---|
| 654 | 'fundamental-file-character-input-stream |
|---|
| 655 | (if out-p |
|---|
| 656 | 'fundamental-file-character-output-stream |
|---|
| 657 | 'fundamental-file-stream))) |
|---|
| 658 | (if (and in-p out-p) |
|---|
| 659 | 'fundamental-file-binary-io-stream |
|---|
| 660 | (if in-p |
|---|
| 661 | 'fundamental-file-binary-input-stream |
|---|
| 662 | (if out-p |
|---|
| 663 | 'fundamental-file-binary-output-stream |
|---|
| 664 | 'fundamental-file-stream))))) |
|---|
| 665 | |
|---|
| 666 | (defmethod select-stream-class ((class file-stream) in-p out-p char-p) |
|---|
| 667 | (if char-p |
|---|
| 668 | (if (and in-p out-p) |
|---|
| 669 | 'fundamental-file-character-io-stream |
|---|
| 670 | (if in-p |
|---|
| 671 | 'fundamental-file-character-input-stream |
|---|
| 672 | (if out-p |
|---|
| 673 | 'fundamental-file-character-output-stream |
|---|
| 674 | 'fundamental-file-stream))) |
|---|
| 675 | (if (and in-p out-p) |
|---|
| 676 | 'fundamental-file-binary-io-stream |
|---|
| 677 | (if in-p |
|---|
| 678 | 'fundamental-file-binary-input-stream |
|---|
| 679 | (if out-p |
|---|
| 680 | 'fundamental-file-binary-output-stream |
|---|
| 681 | 'fundamental-file-stream))))) |
|---|
| 682 | |
|---|
| 683 | (defmethod map-to-basic-stream-class-name ((name (eql 'fundamental-file-stream))) |
|---|
| 684 | 'basic-file-stream) |
|---|
| 685 | |
|---|
| 686 | (defmethod map-to-basic-stream-class-name ((name (eql 'file-stream))) |
|---|
| 687 | 'basic-file-stream) |
|---|
| 688 | |
|---|
| 689 | (defmethod select-stream-class ((class (eql 'basic-file-stream)) in-p out-p char-p) |
|---|
| 690 | (if char-p |
|---|
| 691 | (if (and in-p out-p) |
|---|
| 692 | 'basic-file-character-io-stream |
|---|
| 693 | (if in-p |
|---|
| 694 | 'basic-file-character-input-stream |
|---|
| 695 | (if out-p |
|---|
| 696 | 'basic-file-character-output-stream |
|---|
| 697 | 'basic-file-stream))) |
|---|
| 698 | (if (and in-p out-p) |
|---|
| 699 | 'basic-file-binary-io-stream |
|---|
| 700 | (if in-p |
|---|
| 701 | 'basic-file-binary-input-stream |
|---|
| 702 | (if out-p |
|---|
| 703 | 'basic-file-binary-output-stream |
|---|
| 704 | 'basic-file-stream))))) |
|---|
| 705 | |
|---|
| 706 | |
|---|
| 707 | (defmethod select-stream-advance-function ((s file-stream) direction) |
|---|
| 708 | (ecase direction |
|---|
| 709 | (:io 'io-file-ioblock-advance) |
|---|
| 710 | (:input 'input-file-ioblock-advance))) |
|---|
| 711 | |
|---|
| 712 | (defmethod select-stream-force-output-function ((s file-stream) direction) |
|---|
| 713 | (ecase direction |
|---|
| 714 | (:io 'io-file-force-output) |
|---|
| 715 | (:output 'output-file-force-output))) |
|---|
| 716 | |
|---|
| 717 | (defmethod select-stream-untyi-function ((s file-stream) (direction t)) |
|---|
| 718 | '%file-ioblock-untyi) |
|---|
| 719 | |
|---|
| 720 | ;;; Conceptually, decrement the stream's position by the number of octets |
|---|
| 721 | ;;; needed to encode CHAR. |
|---|
| 722 | ;;; Since we don't use IOBLOCK-UNTYI-CHAR, it's hard to detect the error |
|---|
| 723 | ;;; of calling UNREAD-CHAR twice in a row. |
|---|
| 724 | (defun %file-ioblock-untyi (ioblock char) |
|---|
| 725 | (let* ((inbuf (ioblock-inbuf ioblock)) |
|---|
| 726 | (idx (io-buffer-idx inbuf)) |
|---|
| 727 | (encoding (ioblock-encoding ioblock)) |
|---|
| 728 | (noctets (if encoding |
|---|
| 729 | (funcall (character-encoding-character-size-in-octets-function encoding) char) |
|---|
| 730 | 1))) |
|---|
| 731 | (declare (fixnum idx noctets)) |
|---|
| 732 | (if (>= idx noctets) |
|---|
| 733 | (setf (io-buffer-idx inbuf) (the fixnum (- idx noctets))) |
|---|
| 734 | (let* ((stream (ioblock-stream ioblock)) |
|---|
| 735 | (pos (stream-position stream)) |
|---|
| 736 | (newpos (- pos noctets))) |
|---|
| 737 | (if (< newpos 0) |
|---|
| 738 | (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)) |
|---|
| 739 | (stream-position stream newpos)))) |
|---|
| 740 | char)) |
|---|
| 741 | |
|---|
| 742 | |
|---|
| 743 | |
|---|
| 744 | (defun make-file-stream (filename |
|---|
| 745 | direction |
|---|
| 746 | element-type |
|---|
| 747 | if-exists |
|---|
| 748 | if-does-not-exist |
|---|
| 749 | class |
|---|
| 750 | external-format |
|---|
| 751 | sharing |
|---|
| 752 | basic) |
|---|
| 753 | (let* ((temp-name nil) |
|---|
| 754 | (created nil) |
|---|
| 755 | (dir (pathname-directory filename)) |
|---|
| 756 | (filename (if (eq (car dir) :relative) |
|---|
| 757 | (full-pathname filename) |
|---|
| 758 | filename)) |
|---|
| 759 | (pathname (pathname filename))) |
|---|
| 760 | (block open |
|---|
| 761 | (if (or (memq element-type '(:default character base-char)) |
|---|
| 762 | (subtypep element-type 'character)) |
|---|
| 763 | (if (eq element-type :default)(setq element-type 'character)) |
|---|
| 764 | (progn |
|---|
| 765 | (setq element-type (type-expand element-type)) |
|---|
| 766 | (cond ((equal element-type '#.(type-expand 'signed-byte)) |
|---|
| 767 | (setq element-type '(signed-byte 8))) |
|---|
| 768 | ((equal element-type '#.(type-expand 'unsigned-byte)) |
|---|
| 769 | (setq element-type '(unsigned-byte 8)))))) |
|---|
| 770 | (case direction |
|---|
| 771 | (:probe (setq if-exists :ignored)) |
|---|
| 772 | (:input (setq if-exists :ignored)) |
|---|
| 773 | ((:io :output) nil) |
|---|
| 774 | (t (report-bad-arg direction '(member :input :output :io :probe)))) |
|---|
| 775 | (check-pathname-not-wild filename) ;; probe-file-x misses wild versions.... |
|---|
| 776 | (multiple-value-bind (native-truename kind)(probe-file-x filename) |
|---|
| 777 | (tagbody retry |
|---|
| 778 | (if native-truename |
|---|
| 779 | (if (eq kind :directory) |
|---|
| 780 | (if (eq direction :probe) |
|---|
| 781 | (return-from open nil) |
|---|
| 782 | (signal-file-error (- #$EISDIR) filename)) |
|---|
| 783 | (if (setq filename (if-exists if-exists filename "Open ...")) |
|---|
| 784 | (progn |
|---|
| 785 | (multiple-value-setq (native-truename kind) (probe-file-x filename)) |
|---|
| 786 | (cond |
|---|
| 787 | ((not native-truename) |
|---|
| 788 | (setq native-truename (%create-file filename) |
|---|
| 789 | created t)) |
|---|
| 790 | ((memq direction '(:output :io)) |
|---|
| 791 | (when (eq if-exists :supersede) |
|---|
| 792 | (let ((truename (native-to-pathname native-truename))) |
|---|
| 793 | (setq temp-name (gen-file-name truename)) |
|---|
| 794 | (unix-rename native-truename (native-untranslated-namestring temp-name)) |
|---|
| 795 | (%create-file native-truename)))))) |
|---|
| 796 | (return-from open nil))) |
|---|
| 797 | (if (setq filename (if-does-not-exist if-does-not-exist filename)) |
|---|
| 798 | (progn |
|---|
| 799 | (unless (setq native-truename (%create-file filename :if-exists (case if-exists |
|---|
| 800 | ;; Let %create file handle these cases |
|---|
| 801 | ((:error :overwrite) if-exists) |
|---|
| 802 | (t nil)))) |
|---|
| 803 | ;; Somebody else created the file while we're trying to create it. |
|---|
| 804 | (when (null if-exists) (return-from open nil)) |
|---|
| 805 | (multiple-value-setq (native-truename kind) (probe-file-x filename)) |
|---|
| 806 | (unless native-truename ;; huh? Perhaps it disappeared again? |
|---|
| 807 | (error "Attempt to create ~s failed unexpectedly" filename)) |
|---|
| 808 | (go retry)) |
|---|
| 809 | (setq created t)) |
|---|
| 810 | (return-from open nil)))) |
|---|
| 811 | (let* ((fd (fd-open native-truename (case direction |
|---|
| 812 | ((:probe :input) #$O_RDONLY) |
|---|
| 813 | (:output #$O_WRONLY) |
|---|
| 814 | (:io #$O_RDWR))))) |
|---|
| 815 | (when (< fd 0) (signal-file-error fd filename)) |
|---|
| 816 | (let* ((fd-kind (%unix-fd-kind fd))) |
|---|
| 817 | (if (not (eq fd-kind :file)) |
|---|
| 818 | (make-fd-stream fd :direction direction |
|---|
| 819 | :element-type element-type |
|---|
| 820 | :sharing sharing |
|---|
| 821 | :basic basic) |
|---|
| 822 | (progn |
|---|
| 823 | (when basic |
|---|
| 824 | (setq class (map-to-basic-stream-class-name class)) |
|---|
| 825 | (setq basic (subtypep (find-class class) 'basic-stream))) |
|---|
| 826 | (let* ((in-p (member direction '(:io :input))) |
|---|
| 827 | (out-p (member direction '(:io :output))) |
|---|
| 828 | (io-p (eq direction :io)) |
|---|
| 829 | (char-p (or (eq element-type 'character) |
|---|
| 830 | (subtypep element-type 'character))) |
|---|
| 831 | (elements-per-buffer (optimal-buffer-size fd element-type)) |
|---|
| 832 | (real-external-format |
|---|
| 833 | (if char-p |
|---|
| 834 | (normalize-external-format :file external-format) |
|---|
| 835 | )) |
|---|
| 836 | (line-termination (if char-p (external-format-line-termination real-external-format))) |
|---|
| 837 | (encoding (if char-p (external-format-character-encoding real-external-format))) |
|---|
| 838 | (class-name (select-stream-class class in-p out-p char-p)) |
|---|
| 839 | (class (find-class class-name)) |
|---|
| 840 | (fstream (make-ioblock-stream |
|---|
| 841 | class |
|---|
| 842 | :insize (if in-p elements-per-buffer) |
|---|
| 843 | :outsize (if (and out-p (not io-p)) |
|---|
| 844 | elements-per-buffer) |
|---|
| 845 | :share-buffers-p io-p |
|---|
| 846 | :interactive nil |
|---|
| 847 | :direction direction |
|---|
| 848 | :element-type element-type |
|---|
| 849 | :direction direction |
|---|
| 850 | :listen-function 'fd-stream-listen |
|---|
| 851 | :close-function 'fd-stream-close |
|---|
| 852 | :advance-function |
|---|
| 853 | (if in-p (select-stream-advance-function class direction)) |
|---|
| 854 | :force-output-function |
|---|
| 855 | (if out-p (select-stream-force-output-function |
|---|
| 856 | class direction)) |
|---|
| 857 | :device fd |
|---|
| 858 | :encoding encoding |
|---|
| 859 | :external-format (or real-external-format :binary) |
|---|
| 860 | :sharing sharing |
|---|
| 861 | :line-termination line-termination |
|---|
| 862 | :character-p (or (eq element-type 'character) |
|---|
| 863 | (subtypep element-type 'character)))) |
|---|
| 864 | (ioblock (stream-ioblock fstream t))) |
|---|
| 865 | (setf (stream-filename fstream) (namestring pathname) |
|---|
| 866 | (stream-actual-filename fstream) (or temp-name created)) |
|---|
| 867 | (setf (file-ioblock-fileeof ioblock) |
|---|
| 868 | (ioblock-octets-to-elements ioblock (fd-size fd))) |
|---|
| 869 | (when (and in-p (eq line-termination :inferred)) |
|---|
| 870 | (infer-line-termination ioblock)) |
|---|
| 871 | (cond ((eq if-exists :append) |
|---|
| 872 | (file-position fstream :end)) |
|---|
| 873 | ((and (memq direction '(:io :output)) |
|---|
| 874 | (neq if-exists :overwrite)) |
|---|
| 875 | (stream-length fstream 0))) |
|---|
| 876 | (if (eq direction :probe) |
|---|
| 877 | (close fstream) |
|---|
| 878 | (note-open-file-stream fstream)) |
|---|
| 879 | fstream))))))))) |
|---|
| 880 | |
|---|
| 881 | |
|---|
| 882 | |
|---|
| 883 | |
|---|
| 884 | |
|---|
| 885 | |
|---|
| 886 | (defmethod stream-external-format ((s broadcast-stream)) |
|---|
| 887 | (let* ((last (last-broadcast-stream s))) |
|---|
| 888 | (if last |
|---|
| 889 | (stream-external-format s) |
|---|
| 890 | :default))) |
|---|
| 891 | |
|---|
| 892 | ;;; Under the circumstances, this is a very slow way of saying |
|---|
| 893 | ;;; "we don't support EXTENDED-CHARs". |
|---|
| 894 | (defun file-string-length (stream object) |
|---|
| 895 | "Return the delta in STREAM's FILE-POSITION that would be caused by writing |
|---|
| 896 | OBJECT to STREAM. Non-trivial only in implementations that support |
|---|
| 897 | international character sets." |
|---|
| 898 | (if (typep stream 'broadcast-stream) |
|---|
| 899 | (let* ((last (last-broadcast-stream stream))) |
|---|
| 900 | (if last |
|---|
| 901 | (file-string-length last object) |
|---|
| 902 | 1)) |
|---|
| 903 | (progn |
|---|
| 904 | (unless (and (typep stream 'file-stream) |
|---|
| 905 | (let* ((eltype (stream-element-type stream))) |
|---|
| 906 | (or (eq 'character eltype) |
|---|
| 907 | (eq 'base-char eltype) |
|---|
| 908 | (subtypep eltype 'character)))) |
|---|
| 909 | (error "~S is not a file stream capable of character output" stream)) |
|---|
| 910 | (if (typep object 'character) |
|---|
| 911 | (setq object (make-string 1 :initial-element object)) |
|---|
| 912 | (progn |
|---|
| 913 | (require-type object 'string))) |
|---|
| 914 | (let* ((start 0) |
|---|
| 915 | (end (length object))) |
|---|
| 916 | (multiple-value-bind (data offset) (array-data-and-offset object) |
|---|
| 917 | (unless (eq data object) |
|---|
| 918 | (setq object data) |
|---|
| 919 | (incf start offset) |
|---|
| 920 | (incf end offset))) |
|---|
| 921 | (let* ((external-format (stream-external-format stream)) |
|---|
| 922 | (encoding (get-character-encoding (external-format-character-encoding external-format))) |
|---|
| 923 | (line-termination (external-format-line-termination external-format))) |
|---|
| 924 | (- |
|---|
| 925 | (+ (funcall (character-encoding-octets-in-string-function encoding) |
|---|
| 926 | object |
|---|
| 927 | start |
|---|
| 928 | end) |
|---|
| 929 | (if (eq line-termination :crlf) |
|---|
| 930 | (* (count #\Newline object :start start :end end) |
|---|
| 931 | (file-string-length stream #\Return)) |
|---|
| 932 | 0)) |
|---|
| 933 | (if (eql (file-position stream) 0) |
|---|
| 934 | 0 |
|---|
| 935 | (length (character-encoding-bom-encoding encoding))))))))) |
|---|
| 936 | |
|---|
