source: trunk/source/level-1/l1-sysio.lisp @ 15018

Last change on this file since 15018 was 14683, checked in by rme, 9 years ago

Re-indent make-file-stream.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 37.0 KB
RevLine 
[6]1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]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
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
[2326]18(in-package "CCL")
19
[6]20(defstruct (file-ioblock (:include ioblock))
[11059]21  (octet-pos 0 )                       ; current io position in octets
22  (fileeof 0 )                          ; file length in elements
[5335]23  )
[6]24
25
[5293]26
[5335]27
[6]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
[5293]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)))
[5335]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))
[8170]65                     ((= i nchars) (if last-was-cr :cr))
[5335]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))))))))
[8170]76          (when line-termination
77            (install-ioblock-input-line-termination file-ioblock line-termination)
78            (when (file-ioblock-outbuf file-ioblock)
[12240]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))))
[6]82
[5293]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
[4993]93  "The value of this variable is used when :EXTERNAL-FORMAT is
94unspecified or specified as :DEFAULT. It can meaningfully be given any
[5335]95of the values :UNIX, :MACOS, :MSDOS, :UNICODE or :INFERRED, each of which is
[4993]96interpreted as described in the documentation.
[6]97
[2444]98Because there's some risk that unsolicited newline translation could have
[13066]99undesirable consequences, the initial value of this variable in Clozure CL
[2444]100is :UNIX.")
101
[5352]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))
[5304]106
[5352]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))))
[5304]110
[5352]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*)
[5570]121    (error "~S is not a known line-termination format." line-termination))
122
[5352]123  (if (eq character-encoding :default)
124    (setq character-encoding
125          (default-character-encoding domain)))
126  (unless (lookup-character-encoding character-encoding)
[13426]127    (error "~S is not the name of a known character encoding."
[5352]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
[5293]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))
[5352]142         (normalize-external-format domain (apply #'make-external-format :domain domain  external-format)))
[5304]143        ((typep external-format 'external-format)
[5352]144         external-format)
[5293]145        ((eq external-format :default)
[5414]146         (normalize-external-format domain *default-external-format*))
[5293]147        ((lookup-character-encoding external-format)
148         (normalize-external-format domain `(:character-encoding ,external-format)))
[5335]149        ((assq external-format *canonical-line-termination-conventions*)
[5293]150         (normalize-external-format domain `(:line-termination ,external-format)))
151        (t
152         (error "Invalid external-format: ~s" external-format))))
153               
154           
155   
[6]156
[5293]157
[6]158
[5335]159
[6]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)
[11628]184      curpos
[6]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
[5361]208        (unless (= newpos 0)
209          (setf (ioblock-pending-byte-order-mark file-ioblock) nil))
[6]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)
[5335]219              (fd-stream-force-output (file-ioblock-stream file-ioblock)
220                                      file-ioblock
221                                      (io-buffer-count outbuf)
222                                      nil)
[6]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)
[11628]248      curpos
[6]249      (let* ((incount (io-buffer-count outbuf)))
[5361]250        (unless (= newpos 0)
251          (setf (ioblock-pending-byte-order-mark file-ioblock) nil))       
[6]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)
[5335]269             (fd-stream-force-output (file-ioblock-stream file-ioblock)
270                                     file-ioblock
271                                     (io-buffer-count outbuf)
272                                     nil))
[6]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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[4904]333(defclass fundamental-file-stream (fd-stream file-stream)
[6]334    ((filename :initform nil :initarg :filename :accessor file-stream-filename)
[2500]335     (actual-filename :initform nil :initarg :actual-filename)
[6]336     (external-format :initform :default :initarg :external-format
337                      :accessor file-stream-external-format)))
[4925]338
[6]339 
340
[4904]341(defmethod stream-filename ((s fundamental-file-stream))
[6]342  (file-stream-filename s))
343
[2500]344(defmethod stream-actual-filename ((s file-stream))
345  (slot-value s 'actual-filename))
[6]346
[4904]347(defmethod (setf stream-filename) (new (s fundamental-file-stream))
[6]348  (setf (file-stream-filename s) new))
349
[4904]350(defmethod (setf stream-actual-filename) (new (s fundamental-file-stream))
[2500]351  (setf (slot-value s 'actual-filename) new))
[6]352
[4925]353(defun print-file-stream (s out)
[6]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
[5255]358        (format out "~d ~a)" (file-ioblock-device file-ioblock) (encoding-name (ioblock-encoding file-ioblock)))
[6]359        (format out ":closed")))))
[4925]360   
361(defmethod print-object ((s fundamental-file-stream) out)
362  (print-file-stream s out))
363
[5276]364(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream)
[4925]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
[5320]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
[4904]386(defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key)
[6]387  (declare (dynamic-extent args))
388  (apply #'make-file-ioblock :stream stream args))
389
[4925]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
[4904]394(defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream)
[6]395    ())
396
[4925]397(make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream)
398
399
[4904]400(defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream)
[6]401    ())
402
[4925]403(make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream)
404
[4904]405(defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream)
[6]406    ())
407
[4925]408(make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream)
409
410
[4904]411(defclass fundamental-file-character-input-stream (fundamental-file-input-stream
[6]412                                          fd-character-input-stream)
413    ())
414
[4925]415(make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream)
416
417
[4904]418(defclass fundamental-file-character-output-stream (fundamental-file-output-stream
419                                                    fd-character-output-stream)
[6]420    ())
421
[4925]422(make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream)
423
[4904]424(defclass fundamental-file-character-io-stream (fundamental-file-io-stream
[6]425                                       fd-character-io-stream)
426    ())
427
[4925]428(make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream)
429
[4904]430(defclass fundamental-file-binary-input-stream (fundamental-file-input-stream
431                                                fd-binary-input-stream)
[6]432    ())
433
[4925]434(make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream)
435
[4904]436(defclass fundamental-file-binary-output-stream (fundamental-file-output-stream
437                                                 fd-binary-output-stream)
[6]438    ())
439
[4925]440(make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream)
441
[4904]442(defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream)
[6]443    ())
444
[4925]445(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream)
446
447
[5276]448
449
[6]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
[4904]455(defmethod stream-clear-input ((f fundamental-file-input-stream))
[6]456  (with-stream-ioblock-input (file-ioblock f :speedy t)
457    (call-next-method)
458    (synch-file-octet-filepos file-ioblock)
459    nil))
[4925]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
[6]469   
[4904]470(defmethod stream-clear-input ((f fundamental-file-io-stream))
[6]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
[4925]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
[4904]484(defmethod stream-clear-output ((f fundamental-file-output-stream))
[6]485  (with-stream-ioblock-output (file-ioblock f :speedy t)
486    (call-next-method)
487    (synch-file-octet-filepos file-ioblock)
488    nil))
489
[4925]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
[5335]497
[6]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)
[9869]503                    (io-buffer-count (file-ioblock-inbuf file-ioblock)))))
[6]504    (setf (file-ioblock-octet-pos file-ioblock) newpos)
[5335]505    (fd-stream-advance stream file-ioblock read-p)))
[6]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)
[5335]516      (fd-stream-force-output stream file-ioblock count nil))
[6]517    (unless (eql newpos (file-octet-filepos file-ioblock))
[7734]518      (error "Expected newpos to be ~d, fd is at ~d"
[6]519             newpos (file-octet-filepos file-ioblock)))
520    (setf (file-ioblock-octet-pos file-ioblock) newpos)
[5335]521    (fd-stream-advance stream file-ioblock read-p)))
[6]522
523                   
524(defun output-file-force-output (stream file-ioblock count finish-p)
[11628]525  (let* ((pos (%ioblock-output-file-position file-ioblock nil))
526         (n (fd-stream-force-output stream file-ioblock count finish-p)))
[9869]527    (incf (file-ioblock-octet-pos file-ioblock) (or n 0))
[11628]528    (%ioblock-output-file-position file-ioblock pos)
[9869]529    n))
[6]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)
[11628]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)))
[6]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
[4904]557(defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos)
[6]558  (with-stream-ioblock-input (file-ioblock stream :speedy t)
559    (%ioblock-input-file-position file-ioblock newpos)))
560
561
[4925]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))))
[6]566
[4904]567(defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos)
[6]568  (with-stream-ioblock-output (file-ioblock stream :speedy t)
569    (%ioblock-output-file-position file-ioblock newpos)))
570
[4925]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))))
[6]575
576
[4904]577(defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos)
[6]578  (with-stream-ioblock-input (file-ioblock stream :speedy t)
579    (%ioblock-io-file-position file-ioblock newpos)))
580
[4925]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))))
[6]585
586
[4904]587(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen)
[6]588  (with-stream-ioblock-input (file-ioblock stream :speedy t)
[11059]589    (let* ((res (%ioblock-input-file-length file-ioblock newlen)))
590      (and res (>= res 0) res))))
[6]591
[11059]592
[4925]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)
[11059]596      (let* ((res (%ioblock-input-file-length file-ioblock newlen)))
597        (and res (>= res 0) res)))))
[6]598
599
[4904]600(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen)
[6]601  (with-stream-ioblock-output (file-ioblock s :speedy t)
[11059]602    (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
603      (and res (>= res 0) res))))
[6]604
[4925]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)
[11059]609      (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
610        (and res (>= res 0) res)))))
[4925]611
[4904]612(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen)
[6]613  (with-stream-ioblock-input (file-ioblock s :speedy t)
[11059]614    (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
615      (and res (>= res 0) res))))
[6]616
[4925]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)
[11059]620      (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
621        (and res (>= res 0) res)))))
[4925]622
623(defun close-file-stream (s abort)
[6]624  (when (open-stream-p s)
[4900]625    (let* ((ioblock (stream-ioblock s t))
[6]626           (filename (stream-filename s))
[2500]627           (actual-filename (stream-actual-filename s)))
[8699]628      (when actual-filename ; t => created when opened
[6]629        (if abort
630          (progn
631            (setf (ioblock-dirty ioblock) nil)
632            (fd-stream-close s ioblock)
[8699]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))))
[6019]638      (remove-open-file-stream s))))
[6]639
[4925]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
[4915]649(defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p)
[6]650  (if char-p
651    (if (and in-p out-p)
[4904]652      'fundamental-file-character-io-stream
[6]653      (if in-p
[4904]654        'fundamental-file-character-input-stream
[6]655        (if out-p
[4904]656          'fundamental-file-character-output-stream
657          'fundamental-file-stream)))
[6]658    (if (and in-p out-p)
[4904]659      'fundamental-file-binary-io-stream
[6]660      (if in-p
[4904]661        'fundamental-file-binary-input-stream
[6]662        (if out-p
[4904]663          'fundamental-file-binary-output-stream
664          'fundamental-file-stream)))))
[6]665
[5265]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
[4929]683(defmethod map-to-basic-stream-class-name ((name (eql 'fundamental-file-stream)))
684  'basic-file-stream)
685
[5265]686(defmethod map-to-basic-stream-class-name ((name (eql 'file-stream)))
687  'basic-file-stream)
688
[4929]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
[5276]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
[11628]717(defmethod select-stream-untyi-function ((s file-stream) (direction t))
718  '%file-ioblock-untyi)
[5276]719
[11628]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))
[5276]741
742
[11628]743
[6]744(defun make-file-stream (filename
745                         direction
746                         element-type
747                         if-exists
748                         if-does-not-exist
749                         class
[4890]750                         external-format
[4929]751                         sharing
752                         basic)
[6]753  (let* ((temp-name nil)
[8699]754         (created nil)
[2500]755         (dir (pathname-directory filename))
756         (filename (if (eq (car dir) :relative)
[4929]757                     (full-pathname filename)
758                     filename))
[2500]759         (pathname (pathname filename))) 
[6]760    (block open
761      (if (or (memq element-type '(:default character base-char))
762              (subtypep element-type 'character))
[14683]763        (if (eq element-type :default) (setq element-type 'character))
[6]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
[442]771        (:probe (setq if-exists :ignored))
[6]772        (:input (setq if-exists :ignored))
773        ((:io :output) nil)
774        (t (report-bad-arg direction '(member :input :output :io :probe))))
[9048]775      (check-pathname-not-wild filename) ;; probe-file-x misses wild versions....
[14683]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))))
[6]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))
[14683]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)))
[4929]826                (let* ((in-p (member direction '(:io :input)))
[5276]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)))
[8584]831                       (elements-per-buffer (optimal-buffer-size fd element-type))
[5276]832                       (real-external-format
[5293]833                        (if char-p
834                          (normalize-external-format :file external-format)
[5304]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)))
[5276]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
[14683]856                                            class direction))
[5276]857                                 :device fd
[5293]858                                 :encoding encoding
[5304]859                                 :external-format (or real-external-format :binary)
[5276]860                                 :sharing sharing
[5320]861                                 :line-termination line-termination
[5276]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)
[8699]866                        (stream-actual-filename fstream) (or temp-name created))
[5276]867                  (setf (file-ioblock-fileeof ioblock)
868                        (ioblock-octets-to-elements ioblock (fd-size fd)))
[5335]869                  (when (and in-p (eq line-termination :inferred))
870                    (infer-line-termination ioblock))
[5276]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)
[6019]878                    (note-open-file-stream fstream))
[5276]879                  fstream)))))))))
[6]880
881
[4925]882
[4993]883
884
885
[943]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
[6]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)
[929]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."
[442]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))
[5361]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)))))))))
[442]936 
Note: See TracBrowser for help on using the repository browser.