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

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

Handle newline translation differenly (at the character I/O level, not the buffer level).

All character encoding/decoding functions operate on octets, not necessarily code
units. (The stream encode/decode functions are an exception; serialization and
byte ordering are handled by the stream.)

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