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

Last change on this file since 12219 was 11628, checked in by gb, 11 years ago

File-ioblocks don't maintain IOBLOCK-UNTYI-CHAR (since it
interacts poorly with/complicates FILE-POSITION and operations
on :io file streams.) Note that the error of calling UNREAD-CHAR
twice in succession is harder to detect.
Implement UNREAD-CHAR by decrementing the file position by the
number of octets needed to encode the character.
Ensure that FORCE-OUTPUT on file streams maintains the file's
position.

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