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

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

EXTERNAL-FORMATs are immutable, interned.

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