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

Last change on this file since 9048 was 9048, checked in by gz, 11 years ago

Make make-file-stream rejected wildcarded pathnames.

Various tweaks to make meta-. work when using pathnames relative to the file system's "current directory".

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