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

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

Rearrange a few things; pass :line-termination option to MAKE-FD-STREAM.

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