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

Last change on this file since 4925 was 4925, checked in by gb, 14 years ago

Most BASIC-FILE-STREAM stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 30.3 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 :type fixnum)            ; current io position in octets
21  (fileeof 0 :type fixnum)              ; file length in elements
22)
23
24
25;;; The file-ioblock-octet-pos field is the (octet) position
26;;; at which the next I/O operation will begin (e.g., where the
27;;; input came from and/or where the output's going.)  There are
28;;; cases (e.g., after a STREAM-CLEAR-INPUT) when this can't be
29;;; determined (based on its previous value and the logical size
30;;; of the buffer) so we'll have to ask the OS.
31
32(defun file-octet-filepos (file-ioblock)
33  (fd-tell (file-ioblock-device file-ioblock)))
34
35(defun synch-file-octet-filepos (file-ioblock)
36  (setf (file-ioblock-octet-pos file-ioblock)
37        (file-octet-filepos file-ioblock)))
38
39(defun translate-cr-to-lf (file-ioblock)
40  (let* ((inbuf (file-ioblock-inbuf file-ioblock))
41         (string (io-buffer-buffer inbuf))
42         (n (io-buffer-count inbuf)))
43    (declare (simple-base-string string)
44             (fixnum n))
45    (dotimes (i n n)
46      (if (eq (schar string i) #\Return)
47        (setf (schar string i) #\Linefeed)))))
48
49(defun translate-lf-to-cr (file-ioblock n)
50  (declare (fixnum n))
51  (let* ((outbuf (file-ioblock-outbuf file-ioblock))
52         (string (io-buffer-buffer outbuf)))
53    (declare (simple-base-string string))
54    (dotimes (i n n)
55      (if (eq (schar string i) #\Linefeed)
56        (setf (schar string i) #\Return)))))
57
58(defun infer-external-format (file-stream)
59  (with-stream-ioblock-input (ioblock file-stream :speedy t)
60    (setf (file-stream-external-format file-stream)
61          (if (eq (%ioblock-peek-char ioblock) :eof)
62            :unix
63            (let* ((inbuf (ioblock-inbuf ioblock))
64                   (string (io-buffer-buffer inbuf))
65                   (n (io-buffer-count inbuf)))
66              (declare (simple-base-string string)
67                       (fixnum n))
68              (dotimes (i n :unix)
69                (let* ((ch (schar string i)))
70                  (if (eq ch #\Linefeed)
71                    (return :unix))
72                  (when (eq ch #\Return)
73                    (translate-cr-to-lf ioblock)
74                    (return :macos)))))))))
75
76(defvar *default-external-format* :unix
77  "The value of this variable is used when :EXTERNAL-FORMAT is unspecified
78or specified as :DEFAULT. It can meaningfully be given any of the values
79:UNIX, :MACOS, or :INFERRED, each of which is interpreted as described above.
80
81Because there's some risk that unsolicited newline translation could have
82undesirable consequences, the initial value of this variable in OpenMCL
83is :UNIX.")
84
85(defparameter *external-format-translations*
86  '((:unix nil nil)
87    (:macos translate-cr-to-lf translate-lf-to-cr))
88  "an alist: external-format-name, input-translation-function (or NIL),
89   output-translation-function (or NIL)")
90
91(defun file-stream-force-output (stream ioblock count finish-p)
92  (let* ((filter (caddr (assoc (file-stream-external-format stream)
93                               *external-format-translations*
94                               :test #'eq))))
95    (when filter
96      (funcall filter ioblock count))
97    (fd-stream-force-output stream ioblock count finish-p)))
98
99;;; Establish a new position for the specified file-stream.
100(defun file-ioblock-seek (file-ioblock newoctetpos)
101  (let* ((result (fd-lseek
102                  (file-ioblock-device file-ioblock) newoctetpos #$SEEK_SET)))
103    (if (< result 0)
104      (error 'simple-stream-error
105             :stream (file-ioblock-stream file-ioblock)
106             :format-control (format nil "Can't set file position to ~d: ~a"
107                                     newoctetpos (%strerror result)))
108      newoctetpos)))
109
110;;; For input streams, getting/setting the position is fairly simple.
111;;; Getting the position is a simple matter of adding the buffer
112;;; origin to the current position within the buffer.
113;;; Setting the position involves either adjusting the buffer index
114;;; (if the new position is within the current buffer) or seeking
115;;; to a new position.
116
117(defun %ioblock-input-file-position (file-ioblock newpos)
118  (let* ((octet-base (file-ioblock-octet-pos file-ioblock))
119         (element-base (ioblock-octets-to-elements file-ioblock octet-base))
120         (inbuf (file-ioblock-inbuf file-ioblock))
121         (curpos (+ element-base (io-buffer-idx inbuf))))
122    (if (null newpos)
123      (if (file-ioblock-untyi-char file-ioblock)
124        (1- curpos)
125        curpos)
126      (progn
127        (setf (file-ioblock-untyi-char file-ioblock) nil)
128        (if (and (>= newpos element-base)
129                 (< newpos (+ element-base (io-buffer-count inbuf))))
130          (setf (io-buffer-idx inbuf) (- newpos element-base))
131          (file-ioblock-seek-and-reset file-ioblock
132                                       (ioblock-elements-to-octets
133                                        file-ioblock
134                                        newpos)))
135        newpos))))
136
137;;; For (pure) output streams, it's a little more complicated.  If we
138;;; have to seek to a new origin, we may need to flush the buffer
139;;; first.
140
141(defun %ioblock-output-file-position (file-ioblock newpos)
142  (let* ((octet-base (file-ioblock-octet-pos file-ioblock))
143         (element-base (ioblock-octets-to-elements file-ioblock octet-base))
144         (outbuf (file-ioblock-outbuf file-ioblock))
145         (curpos (+ element-base (io-buffer-idx outbuf)))
146         (maxpos (+ element-base (io-buffer-count outbuf))))
147    (if (null newpos)
148      curpos
149      (progn
150        (if (and (>= newpos element-base)
151                 (<= newpos maxpos))
152          ;; Backing up is easy.  Skipping forward (without flushing
153          ;; and seeking) would be hard, 'cause we can't tell what
154          ;; we're skipping over.
155          (let* ((newidx (- newpos element-base)))
156            (setf (io-buffer-idx outbuf) newidx))
157          (progn
158            (when (file-ioblock-dirty file-ioblock)
159              (file-stream-force-output (file-ioblock-stream file-ioblock)
160                                        file-ioblock
161                                        (io-buffer-count outbuf)
162                                        nil)
163              ;; May have just extended the file; may need to update
164              ;; fileeof.
165              (when (> maxpos (file-ioblock-fileeof file-ioblock))
166                (setf (file-ioblock-fileeof file-ioblock) maxpos)))
167            (file-ioblock-seek-and-reset file-ioblock
168                                         (ioblock-elements-to-octets
169                                          file-ioblock
170                                          newpos))))
171        newpos))))
172
173;;; For I/O file streams, there's an additional complication: if we
174;;; back up within the (shared) buffer and the old position was beyond
175;;; the buffer's input count, we have to set the input count to the
176;;; old position.  (Consider the case of writing a single element at
177;;; the end-of-file, backing up one element, then reading the element
178;;; we wrote.)  We -can- skip forward over stuff that's been read;
179;;; if the buffer's dirty, we'll eventually write it back out.
180
181(defun %ioblock-io-file-position (file-ioblock newpos)
182  (let* ((octet-base (file-ioblock-octet-pos file-ioblock))
183         (element-base (ioblock-octets-to-elements file-ioblock octet-base))
184         (outbuf (file-ioblock-outbuf file-ioblock)) ; outbuf = inbuf
185         (curidx (io-buffer-idx outbuf))
186         (curpos (+ element-base curidx)))
187    (if (null newpos)
188      (if (file-ioblock-untyi-char file-ioblock)
189        (1- curpos)
190        curpos)
191      (let* ((incount (io-buffer-count outbuf)))
192        (when (file-ioblock-untyi-char file-ioblock)
193          (setf (file-ioblock-untyi-char file-ioblock) nil)
194          (if (> curidx 0)
195            (decf curpos)))
196        (cond 
197          ((and (>= newpos element-base)
198                (<= newpos curpos))
199           ;; If we've read less than we've written, make what's
200           ;; been written available for subsequent input.
201           (when (> curidx incount)
202             (setf (io-buffer-count outbuf) curidx))
203           (setf (io-buffer-idx outbuf) (- newpos element-base)))
204          ((and (>= newpos element-base)
205                (< newpos (+ element-base incount)))
206           (setf (io-buffer-idx outbuf) (- newpos element-base)))
207          (t
208           (let* ((maxpos (+ element-base (io-buffer-count outbuf))))
209             (when (> maxpos (file-ioblock-fileeof file-ioblock))
210               (setf (file-ioblock-fileeof file-ioblock) maxpos)))
211           (when (file-ioblock-dirty file-ioblock)
212             (file-ioblock-seek file-ioblock octet-base)
213             (file-stream-force-output (file-ioblock-stream file-ioblock)
214                                       file-ioblock
215                                       (io-buffer-count outbuf)
216                                       nil))
217           (file-ioblock-seek-and-reset file-ioblock
218                                        (ioblock-elements-to-octets
219                                         file-ioblock newpos))))
220        newpos))))
221
222;;; Again, it's simplest to define this in terms of the stream's direction.
223;;; Note that we can't change the size of file descriptors open for input
224;;; only.
225
226(defun %ioblock-input-file-length (file-ioblock newlen)
227  (unless newlen
228    (file-ioblock-fileeof file-ioblock)))
229 
230(defun %ioblock-output-file-length (file-ioblock newlen)
231  (let* ((octet-base (file-ioblock-octet-pos file-ioblock))
232         (element-base (ioblock-octets-to-elements file-ioblock octet-base))
233         (outbuf (file-ioblock-outbuf file-ioblock)) 
234         (curidx (io-buffer-idx outbuf))
235         (maxpos (+ element-base (io-buffer-count outbuf)))
236         (curlen (file-ioblock-fileeof file-ioblock)))
237    (if (> maxpos curlen)
238      (setf (file-ioblock-fileeof file-ioblock) (setq curlen maxpos)))
239    (if (null newlen)
240      curlen
241      (let* ((fd (file-ioblock-device file-ioblock))
242             (new-octet-eof (ioblock-elements-to-octets file-ioblock newlen))
243             (cur-octet-pos (fd-tell fd)))
244        (cond ((> newlen curlen)
245               ;; Extend the file; maintain the current position.
246               ;; ftruncate isn't guaranteed to extend a file past
247               ;; its current EOF.  Seeking to the new EOF, then
248               ;; writing, is guaranteed to do so.  Seek to the
249               ;; new EOF, write a random byte, truncate to the
250               ;; specified length, then seek back to where we
251               ;; were and pretend that nothing happened.
252               (file-ioblock-seek file-ioblock new-octet-eof)
253               (%stack-block ((buf 1))
254                             (fd-write fd buf 1))
255               (fd-ftruncate fd new-octet-eof)
256               (file-ioblock-seek file-ioblock cur-octet-pos))
257              ((> newlen maxpos)
258               ;; Make the file shorter.  Doesn't affect
259               ;; our position or anything that we have buffered.
260               (fd-ftruncate fd new-octet-eof))
261              ((< newlen element-base)
262               ;; Discard any buffered output.  Truncate the
263               ;; file, then seek to the new EOF.
264               (fd-ftruncate fd new-octet-eof)
265               (setf (file-ioblock-untyi-char file-ioblock) nil)
266               (file-ioblock-seek-and-reset file-ioblock new-octet-eof))
267              (t
268               (fd-ftruncate fd new-octet-eof)
269               (let* ((newidx (- newlen element-base)))
270                 (when (> maxpos newlen)
271                   (setf (io-buffer-count outbuf) newidx))
272                 (when (> curidx newidx)
273                   (setf (io-buffer-idx outbuf) newidx)))))
274        (setf (file-ioblock-fileeof file-ioblock) newlen)))))
275
276
277;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
278(defclass fundamental-file-stream (fd-stream file-stream)
279    ((filename :initform nil :initarg :filename :accessor file-stream-filename)
280     (actual-filename :initform nil :initarg :actual-filename)
281     (external-format :initform :default :initarg :external-format
282                      :accessor file-stream-external-format)))
283
284 
285
286(defmethod stream-filename ((s fundamental-file-stream))
287  (file-stream-filename s))
288
289(defmethod stream-actual-filename ((s file-stream))
290  (slot-value s 'actual-filename))
291
292(defmethod (setf stream-filename) (new (s fundamental-file-stream))
293  (setf (file-stream-filename s) new))
294
295(defmethod (setf stream-actual-filename) (new (s fundamental-file-stream))
296  (setf (slot-value s 'actual-filename) new))
297
298(defun print-file-stream (s out)
299  (print-unreadable-object (s out :type t :identity t)
300    (let* ((file-ioblock (stream-ioblock s nil)))
301      (format out "(~s/" (stream-filename s))
302      (if file-ioblock
303        (format out "~d)" (file-ioblock-device file-ioblock))
304        (format out ":closed")))))
305   
306(defmethod print-object ((s fundamental-file-stream) out)
307  (print-file-stream s out))
308
309(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
310
311(defmethod stream-filename ((s basic-file-stream))
312  (basic-file-stream.filename s))
313
314(defmethod stream-actual-filename ((s basic-file-stream))
315  (basic-file-stream.actual-filename s))
316
317(defmethod (setf stream-filename) (new (s basic-file-stream))
318  (setf (basic-file-stream.filename s) new))
319
320(defmethod (setf stream-actual-filename) (new (s basic-file-stream))
321  (setf (basic-file-stream.actual-filename s) new))
322
323(defmethod print-object ((s basic-file-stream) out)
324  (print-file-stream s out))
325
326(defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key)
327  (declare (dynamic-extent args))
328  (apply #'make-file-ioblock :stream stream args))
329
330(defmethod stream-create-ioblock ((stream basic-file-stream) &rest args &key)
331  (declare (dynamic-extent args))
332  (apply #'make-file-ioblock :stream stream args))
333
334(defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream)
335    ())
336
337(make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream)
338
339
340(defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream)
341    ())
342
343(make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream)
344
345(defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream)
346    ())
347
348(make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream)
349
350
351(defclass fundamental-file-character-input-stream (fundamental-file-input-stream
352                                          fd-character-input-stream)
353    ())
354
355(make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream)
356
357
358(defclass fundamental-file-character-output-stream (fundamental-file-output-stream
359                                                    fd-character-output-stream)
360    ())
361
362(make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream)
363
364(defclass fundamental-file-character-io-stream (fundamental-file-io-stream
365                                       fd-character-io-stream)
366    ())
367
368(make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream)
369
370(defclass fundamental-file-binary-input-stream (fundamental-file-input-stream
371                                                fd-binary-input-stream)
372    ())
373
374(make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream)
375
376(defclass fundamental-file-binary-output-stream (fundamental-file-output-stream
377                                                 fd-binary-output-stream)
378    ())
379
380(make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream)
381
382(defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream)
383    ())
384
385(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream)
386
387
388;;; This stuff is a lot simpler if we restrict the hair to the
389;;; case of file streams opened in :io mode (which have to worry
390;;; about flushing the shared buffer before filling it, and things
391;;; like that.)
392
393(defmethod stream-clear-input ((f fundamental-file-input-stream))
394  (with-stream-ioblock-input (file-ioblock f :speedy t)
395    (call-next-method)
396    (synch-file-octet-filepos file-ioblock)
397    nil))
398
399
400(defmethod stream-clear-input ((f basic-file-input-stream))
401  (let* ((file-ioblock (basic-stream-ioblock f)))
402    (with-ioblock-input-locked (file-ioblock)
403      (call-next-method)
404      (synch-file-octet-filepos file-ioblock)
405      nil)))
406
407   
408(defmethod stream-clear-input ((f fundamental-file-io-stream))
409  (with-stream-ioblock-input (file-ioblock f :speedy t)
410    (stream-force-output f)             
411    (call-next-method)
412    (synch-file-octet-filepos file-ioblock)
413    nil))
414
415(defmethod stream-clear-input ((f basic-file-io-stream))
416  (let* ((file-ioblock (basic-stream-ioblock f)))
417    (with-ioblock-input-locked (file-ioblock)
418      (call-next-method)
419      (synch-file-octet-filepos file-ioblock)
420      nil)))
421
422(defmethod stream-clear-output ((f fundamental-file-output-stream))
423  (with-stream-ioblock-output (file-ioblock f :speedy t)
424    (call-next-method)
425    (synch-file-octet-filepos file-ioblock)
426    nil))
427
428(defmethod stream-clear-output ((f basic-file-output-stream))
429  (let* ((file-ioblock (basic-stream-ioblock f)))
430    (with-ioblock-input-locked (file-ioblock)
431      (call-next-method)
432      (synch-file-octet-filepos file-ioblock)
433      nil)))
434
435;;; Fill the input buffer, possibly doing newline translation.
436(defun file-stream-advance (stream file-ioblock read-p)
437  (let* ((n (fd-stream-advance stream file-ioblock read-p))
438           (filter (cadr (assoc (stream-external-format stream)
439                                *external-format-translations*
440                                :test #'eq))))
441      (if filter
442        (funcall filter file-ioblock))
443      n))
444 
445;;; If we've been reading, the file position where we're going
446;;; to read this time is (+ where-it-was-last-time what-we-read-last-time.)
447(defun input-file-ioblock-advance (stream file-ioblock read-p)
448  (let* ((newpos (+ (file-ioblock-octet-pos file-ioblock)
449                    (io-buffer-count (file-ioblock-inbuf file-ioblock))))
450         (curpos (ioblock-octets-to-elements
451                  file-ioblock
452                  (file-octet-filepos file-ioblock))))
453    (unless (eql newpos curpos)
454      (break "Expected newpos to be ~d, fd is at ~d" newpos curpos))
455    (setf (file-ioblock-octet-pos file-ioblock) newpos)
456    (file-stream-advance stream file-ioblock read-p)))
457
458;;; If the buffer's dirty, we have to back up and rewrite it before
459;;; reading in a new buffer.
460(defun io-file-ioblock-advance (stream file-ioblock read-p)
461  (let* ((curpos (file-ioblock-octet-pos file-ioblock))
462         (count (io-buffer-count (file-ioblock-inbuf file-ioblock)))
463         (newpos (+ curpos 
464                    (ioblock-elements-to-octets file-ioblock count))))
465    (when (ioblock-dirty file-ioblock)
466      (file-ioblock-seek file-ioblock curpos)
467      (file-stream-force-output stream file-ioblock count nil))
468    (unless (eql newpos (file-octet-filepos file-ioblock))
469      (break "Expected newpos to be ~d, fd is at ~d"
470             newpos (file-octet-filepos file-ioblock)))
471    (setf (file-ioblock-octet-pos file-ioblock) newpos)
472    (file-stream-advance stream file-ioblock read-p)))
473
474                   
475(defun output-file-force-output (stream file-ioblock count finish-p)
476  ;; Check to see if we're where we think we should be.
477  (let* ((curpos (file-ioblock-octet-pos file-ioblock)))
478    (unless (eql curpos (file-octet-filepos file-ioblock))
479      (break "Expected newpos to be ~d, fd is at ~d"
480             curpos (file-octet-filepos file-ioblock)))
481    (let* ((n (file-stream-force-output stream file-ioblock count finish-p)))
482      (incf (file-ioblock-octet-pos file-ioblock) (or n 0))
483      n)))
484
485;;; Can't be sure where the underlying fd is positioned, so seek first.
486(defun io-file-force-output (stream file-ioblock count finish-p)
487  (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock))
488  (output-file-force-output stream file-ioblock count finish-p))
489
490
491;;; Invalidate both buffers and seek to the new position.  The output
492;;; buffer's been flushed already if it needed to be.
493
494(defun file-ioblock-seek-and-reset (file-ioblock newoctetpos)
495  (let* ((inbuf (file-ioblock-inbuf file-ioblock))
496         (outbuf (file-ioblock-outbuf file-ioblock)))
497    (setf (file-ioblock-untyi-char file-ioblock) nil)
498    (setf (file-ioblock-dirty file-ioblock) nil)
499    (when inbuf
500      (setf (io-buffer-count inbuf) 0
501            (io-buffer-idx inbuf) 0))
502    (when outbuf
503      (setf (io-buffer-count outbuf) 0
504            (io-buffer-idx outbuf) 0))
505    (setf (file-ioblock-octet-pos file-ioblock) newoctetpos)
506    (file-ioblock-seek file-ioblock newoctetpos)))
507
508(defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos)
509  (with-stream-ioblock-input (file-ioblock stream :speedy t)
510    (%ioblock-input-file-position file-ioblock newpos)))
511
512
513(defmethod stream-position ((stream basic-file-input-stream) &optional newpos)
514  (let* ((file-ioblock (basic-stream-ioblock stream)))
515    (with-ioblock-input-locked (file-ioblock)
516      (%ioblock-input-file-position file-ioblock newpos))))
517
518(defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos)
519  (with-stream-ioblock-output (file-ioblock stream :speedy t)
520    (%ioblock-output-file-position file-ioblock newpos)))
521
522(defmethod stream-position ((stream basic-file-output-stream) &optional newpos)
523  (let* ((file-ioblock (basic-stream-ioblock stream)))
524    (with-ioblock-output-locked (file-ioblock)
525      (%ioblock-output-file-position file-ioblock newpos))))
526
527
528(defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos)
529  (with-stream-ioblock-input (file-ioblock stream :speedy t)
530    (%ioblock-io-file-position file-ioblock newpos)))
531
532(defmethod stream-position ((stream basic-file-io-stream) &optional newpos)
533  (let* ((file-ioblock (basic-stream-ioblock stream)))
534    (with-ioblock-input-locked (file-ioblock)
535      (%ioblock-io-file-position file-ioblock newpos))))
536
537
538(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen)
539  (with-stream-ioblock-input (file-ioblock stream :speedy t)
540    (%ioblock-input-file-length file-ioblock newlen)))
541
542(defmethod stream-length ((stream basic-file-input-stream) &optional newlen)
543  (let* ((file-ioblock (basic-stream-ioblock stream)))
544    (with-ioblock-input-locked (file-ioblock)
545      (%ioblock-input-file-length file-ioblock newlen))))
546
547
548(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen)
549  (with-stream-ioblock-output (file-ioblock s :speedy t)
550    (%ioblock-output-file-length file-ioblock newlen)))
551
552
553(defmethod stream-length ((stream basic-file-output-stream) &optional newlen)
554  (let* ((file-ioblock (basic-stream-ioblock stream)))
555    (with-ioblock-output-locked (file-ioblock)
556      (%ioblock-output-file-length file-ioblock newlen))))
557
558(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen)
559  (with-stream-ioblock-input (file-ioblock s :speedy t)
560    (%ioblock-output-file-length file-ioblock newlen)))
561
562(defmethod stream-length ((stream basic-file-io-stream) &optional newlen)
563  (let* ((file-ioblock (basic-stream-ioblock stream)))
564    (with-ioblock-input-locked (file-ioblock)
565      (%ioblock-output-file-length file-ioblock newlen))))
566
567(defun close-file-stream (s abort)
568  (when (open-stream-p s)
569    (let* ((ioblock (stream-ioblock s t))
570           (filename (stream-filename s))
571           (actual-filename (stream-actual-filename s)))
572      (when actual-filename
573        (if abort
574          (progn
575            (setf (ioblock-dirty ioblock) nil)
576            (fd-stream-close s ioblock)
577            (unix-rename (namestring actual-filename) (probe-file-x filename)))
578          (delete-file actual-filename)))
579      (setq *open-file-streams* (nremove s *open-file-streams*)))))
580
581
582(defmethod close ((s fundamental-file-stream) &key abort)
583  (close-file-stream s abort)
584  (call-next-method))
585
586(defmethod close ((s basic-file-stream) &key abort)
587  (close-file-stream s abort)
588  (call-next-method))
589
590(defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p)
591  (if char-p
592    (if (and in-p out-p)
593      'fundamental-file-character-io-stream
594      (if in-p
595        'fundamental-file-character-input-stream
596        (if out-p
597          'fundamental-file-character-output-stream
598          'fundamental-file-stream)))
599    (if (and in-p out-p)
600      'fundamental-file-binary-io-stream
601      (if in-p
602        'fundamental-file-binary-input-stream
603        (if out-p
604          'fundamental-file-binary-output-stream
605          'fundamental-file-stream)))))
606
607(defun make-file-stream (filename
608                         direction
609                         element-type
610                         if-exists
611                         if-does-not-exist
612                         elements-per-buffer
613                         class
614                         external-format
615                         sharing)
616
617  (let* ((temp-name nil)
618         (dir (pathname-directory filename))
619         (filename (if (eq (car dir) :relative)
620                       (full-pathname filename)
621                       filename))
622         (pathname (pathname filename))) 
623    (block open
624      (if (or (memq element-type '(:default character base-char))
625              (subtypep element-type 'character))
626        (if (eq element-type :default)(setq element-type 'character))
627        (progn
628          (setq element-type (type-expand element-type))
629          (cond ((equal element-type '#.(type-expand 'signed-byte))
630                 (setq element-type '(signed-byte 8)))
631                ((equal element-type '#.(type-expand 'unsigned-byte))
632                 (setq element-type '(unsigned-byte 8))))))
633      (case direction
634        (:probe (setq if-exists :ignored))
635        (:input (setq if-exists :ignored))
636        ((:io :output) nil)
637        (t (report-bad-arg direction '(member :input :output :io :probe))))
638      (multiple-value-bind (native-truename kind)(probe-file-x filename)
639        (if native-truename
640          (if (eq kind :directory)
641            (if (eq direction :probe)
642              (return-from open nil)
643              (signal-file-error (- #$EISDIR)  filename))
644            (if (setq filename (if-exists if-exists filename "Open ..."))
645              (progn
646                (multiple-value-setq (native-truename kind) (probe-file-x filename))
647                (cond 
648                  ((not native-truename)
649                   (setq native-truename (%create-file filename)))
650                  ((memq direction '(:output :io))
651                   #| ;;
652                   ;; this prevents us from writing a file that is open for anything           
653                   ;;l but does not protect against reading a file that is open for :output
654                   (when (and bits (eq direction :output)(neq 0 (logand bits #x81)))
655                   (signal-file-error EBUSY filename))
656                   |#
657                   (when (eq if-exists :supersede)
658                     (let ((truename (native-to-pathname native-truename)))
659                       (setq temp-name (gen-file-name truename))
660                       (unix-rename native-truename (namestring temp-name))
661                       (%create-file native-truename))))))
662              (return-from open nil)))
663          (if (setq filename (if-does-not-exist if-does-not-exist filename))
664            (setq native-truename (%create-file filename))
665            (return-from open nil)))
666        (let* ((fd (fd-open native-truename (case direction
667                                              ((:probe :input) #$O_RDONLY)
668                                              (:output #$O_WRONLY)
669                                              (:io #$O_RDWR)))))
670          (when (< fd 0)  (signal-file-error fd filename))
671          (let* ((fd-kind (%unix-fd-kind fd)))
672            (if (not (eq fd-kind :file))
673              (make-fd-stream fd :direction direction
674                              :element-type element-type
675                              :elements-per-buffer elements-per-buffer
676                              :sharing sharing)
677              (let* ((in-p (member direction '(:io :input)))
678                     (out-p (member direction '(:io :output)))
679                     (io-p (eq direction :io))
680                     (char-p (or (eq element-type 'character)
681                                 (subtypep element-type 'character)))
682                     (infer nil)
683                     (real-external-format
684                      (if (and char-p in-p)
685                        (progn
686                          (if (eq external-format :default)
687                            (setq external-format *default-external-format*))
688                          (if (eq external-format :inferred)
689                            (setq infer t external-format :unix)
690                            (unless (assoc external-format
691                                           *external-format-translations*
692                                           :test #'eq)
693                              (setq external-format :unix)))
694                          external-format)
695                        :binary))
696                     (fstream (make-ioblock-stream
697                               (select-stream-class class in-p out-p char-p)
698                               :insize (if in-p elements-per-buffer)
699                               :outsize (if (and out-p (not io-p))
700                                          elements-per-buffer)
701                               :share-buffers-p io-p
702                               :interactive nil
703                               :direction direction
704                               :element-type element-type
705                               :direction direction
706                               :listen-function 'fd-stream-listen
707                               :close-function 'fd-stream-close
708                               :advance-function
709                               (if io-p
710                                 'io-file-ioblock-advance
711                                 (if in-p
712                                   'input-file-ioblock-advance))
713                               :force-output-function
714                               (if io-p
715                                 'io-file-force-output
716                                 (if out-p
717                                   'output-file-force-output))
718                               :device fd
719                               :external-format real-external-format
720                               :sharing sharing
721                               :character-p (or (eq element-type 'character)
722                                                (subtypep element-type 'character))))
723                     (ioblock (stream-ioblock fstream t)))
724                (setf (stream-filename fstream) (namestring pathname)
725                      (stream-actual-filename fstream) temp-name)
726                (setf (file-ioblock-fileeof ioblock)
727                      (ioblock-octets-to-elements ioblock (fd-size fd)))
728                (if infer
729                  (infer-external-format fstream))
730                (cond ((eq if-exists :append)
731                       (file-position fstream :end))
732                      ((and (memq direction '(:io :output))
733                            (neq if-exists :overwrite))
734                       (stream-length fstream 0)))
735                (if (eq direction :probe)
736                  (close fstream)
737                  (push fstream *open-file-streams*))
738                fstream))))))))
739
740(defmethod stream-external-format ((s fundamental-file-stream))
741  (file-stream-external-format s))
742
743(defmethod stream-external-format ((s basic-file-stream))
744  (basic-file-stream.external-format s))
745
746(defmethod stream-external-format ((s broadcast-stream))
747  (let* ((last (last-broadcast-stream s)))
748    (if last
749        (stream-external-format s)
750        :default)))
751
752;;; Under the circumstances, this is a very slow way of saying
753;;; "we don't support EXTENDED-CHARs".
754(defun file-string-length (stream object)
755  "Return the delta in STREAM's FILE-POSITION that would be caused by writing
756   OBJECT to STREAM. Non-trivial only in implementations that support
757   international character sets."
758  (if (typep stream 'broadcast-stream)
759    (let* ((last (last-broadcast-stream stream)))
760      (if last
761        (file-string-length last object)
762        1))
763    (progn
764      (unless (and (typep stream 'file-stream)
765                   (let* ((eltype (stream-element-type stream)))
766                     (or (eq 'character eltype)
767                         (eq 'base-char eltype)
768                         (subtypep eltype 'character))))
769        (error "~S is not a file stream capable of character output" stream))
770      (etypecase object
771        (character 1)
772        (string (length object))))))
773 
Note: See TracBrowser for help on using the repository browser.