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

Last change on this file since 12763 was 12240, checked in by gb, 10 years ago

(experimentally) change the semantics of streams' :sharing :private
option: stream is "owned" by the first thread to do I/O on it, not
necessarily the creating thread.

INFER-LINE-TERMINATION on file streams: if the creating thread does
I/O (to infer line termination), renounce ownership after doing so.

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