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

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

FILE-STRING-LENGTH actually does something.

Clear the pending-bom flag when seeking.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.4 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        (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      (if (file-ioblock-untyi-char file-ioblock)
248        (1- curpos)
249        curpos)
250      (let* ((incount (io-buffer-count outbuf)))
251        (unless (= newpos 0)
252          (setf (ioblock-pending-byte-order-mark file-ioblock) nil))       
253        (when (file-ioblock-untyi-char file-ioblock)
254          (setf (file-ioblock-untyi-char file-ioblock) nil)
255          (if (> curidx 0)
256            (decf curpos)))
257        (cond 
258          ((and (>= newpos element-base)
259                (<= newpos curpos))
260           ;; If we've read less than we've written, make what's
261           ;; been written available for subsequent input.
262           (when (> curidx incount)
263             (setf (io-buffer-count outbuf) curidx))
264           (setf (io-buffer-idx outbuf) (- newpos element-base)))
265          ((and (>= newpos element-base)
266                (< newpos (+ element-base incount)))
267           (setf (io-buffer-idx outbuf) (- newpos element-base)))
268          (t
269           (let* ((maxpos (+ element-base (io-buffer-count outbuf))))
270             (when (> maxpos (file-ioblock-fileeof file-ioblock))
271               (setf (file-ioblock-fileeof file-ioblock) maxpos)))
272           (when (file-ioblock-dirty file-ioblock)
273             (file-ioblock-seek file-ioblock octet-base)
274             (fd-stream-force-output (file-ioblock-stream file-ioblock)
275                                     file-ioblock
276                                     (io-buffer-count outbuf)
277                                     nil))
278           (file-ioblock-seek-and-reset file-ioblock
279                                        (ioblock-elements-to-octets
280                                         file-ioblock newpos))))
281        newpos))))
282
283;;; Again, it's simplest to define this in terms of the stream's direction.
284;;; Note that we can't change the size of file descriptors open for input
285;;; only.
286
287(defun %ioblock-input-file-length (file-ioblock newlen)
288  (unless newlen
289    (file-ioblock-fileeof file-ioblock)))
290 
291(defun %ioblock-output-file-length (file-ioblock newlen)
292  (let* ((octet-base (file-ioblock-octet-pos file-ioblock))
293         (element-base (ioblock-octets-to-elements file-ioblock octet-base))
294         (outbuf (file-ioblock-outbuf file-ioblock)) 
295         (curidx (io-buffer-idx outbuf))
296         (maxpos (+ element-base (io-buffer-count outbuf)))
297         (curlen (file-ioblock-fileeof file-ioblock)))
298    (if (> maxpos curlen)
299      (setf (file-ioblock-fileeof file-ioblock) (setq curlen maxpos)))
300    (if (null newlen)
301      curlen
302      (let* ((fd (file-ioblock-device file-ioblock))
303             (new-octet-eof (ioblock-elements-to-octets file-ioblock newlen))
304             (cur-octet-pos (fd-tell fd)))
305        (cond ((> newlen curlen)
306               ;; Extend the file; maintain the current position.
307               ;; ftruncate isn't guaranteed to extend a file past
308               ;; its current EOF.  Seeking to the new EOF, then
309               ;; writing, is guaranteed to do so.  Seek to the
310               ;; new EOF, write a random byte, truncate to the
311               ;; specified length, then seek back to where we
312               ;; were and pretend that nothing happened.
313               (file-ioblock-seek file-ioblock new-octet-eof)
314               (%stack-block ((buf 1))
315                             (fd-write fd buf 1))
316               (fd-ftruncate fd new-octet-eof)
317               (file-ioblock-seek file-ioblock cur-octet-pos))
318              ((> newlen maxpos)
319               ;; Make the file shorter.  Doesn't affect
320               ;; our position or anything that we have buffered.
321               (fd-ftruncate fd new-octet-eof))
322              ((< newlen element-base)
323               ;; Discard any buffered output.  Truncate the
324               ;; file, then seek to the new EOF.
325               (fd-ftruncate fd new-octet-eof)
326               (setf (file-ioblock-untyi-char file-ioblock) nil)
327               (file-ioblock-seek-and-reset file-ioblock new-octet-eof))
328              (t
329               (fd-ftruncate fd new-octet-eof)
330               (let* ((newidx (- newlen element-base)))
331                 (when (> maxpos newlen)
332                   (setf (io-buffer-count outbuf) newidx))
333                 (when (> curidx newidx)
334                   (setf (io-buffer-idx outbuf) newidx)))))
335        (setf (file-ioblock-fileeof file-ioblock) newlen)))))
336
337
338;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339(defclass fundamental-file-stream (fd-stream file-stream)
340    ((filename :initform nil :initarg :filename :accessor file-stream-filename)
341     (actual-filename :initform nil :initarg :actual-filename)
342     (external-format :initform :default :initarg :external-format
343                      :accessor file-stream-external-format)))
344
345 
346
347(defmethod stream-filename ((s fundamental-file-stream))
348  (file-stream-filename s))
349
350(defmethod stream-actual-filename ((s file-stream))
351  (slot-value s 'actual-filename))
352
353(defmethod (setf stream-filename) (new (s fundamental-file-stream))
354  (setf (file-stream-filename s) new))
355
356(defmethod (setf stream-actual-filename) (new (s fundamental-file-stream))
357  (setf (slot-value s 'actual-filename) new))
358
359(defun print-file-stream (s out)
360  (print-unreadable-object (s out :type t :identity t)
361    (let* ((file-ioblock (stream-ioblock s nil)))
362      (format out "(~s/" (stream-filename s))
363      (if file-ioblock
364        (format out "~d ~a)" (file-ioblock-device file-ioblock) (encoding-name (ioblock-encoding file-ioblock)))
365        (format out ":closed")))))
366   
367(defmethod print-object ((s fundamental-file-stream) out)
368  (print-file-stream s out))
369
370(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream)
371
372(defmethod stream-filename ((s basic-file-stream))
373  (basic-file-stream.filename s))
374
375(defmethod stream-actual-filename ((s basic-file-stream))
376  (basic-file-stream.actual-filename s))
377
378(defmethod (setf stream-filename) (new (s basic-file-stream))
379  (setf (basic-file-stream.filename s) new))
380
381(defmethod (setf stream-actual-filename) (new (s basic-file-stream))
382  (setf (basic-file-stream.actual-filename s) new))
383
384(defmethod print-object ((s basic-file-stream) out)
385  (print-file-stream s out))
386
387
388(defmethod initialize-basic-stream ((s basic-file-stream) &key element-type external-format &allow-other-keys)
389  (setf (getf (basic-stream.info s) :element-type) element-type)
390  (setf (basic-file-stream.external-format s) external-format))
391
392(defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key)
393  (declare (dynamic-extent args))
394  (apply #'make-file-ioblock :stream stream args))
395
396(defmethod stream-create-ioblock ((stream basic-file-stream) &rest args &key)
397  (declare (dynamic-extent args))
398  (apply #'make-file-ioblock :stream stream args))
399
400(defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream)
401    ())
402
403(make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream)
404
405
406(defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream)
407    ())
408
409(make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream)
410
411(defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream)
412    ())
413
414(make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream)
415
416
417(defclass fundamental-file-character-input-stream (fundamental-file-input-stream
418                                          fd-character-input-stream)
419    ())
420
421(make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream)
422
423
424(defclass fundamental-file-character-output-stream (fundamental-file-output-stream
425                                                    fd-character-output-stream)
426    ())
427
428(make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream)
429
430(defclass fundamental-file-character-io-stream (fundamental-file-io-stream
431                                       fd-character-io-stream)
432    ())
433
434(make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream)
435
436(defclass fundamental-file-binary-input-stream (fundamental-file-input-stream
437                                                fd-binary-input-stream)
438    ())
439
440(make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream)
441
442(defclass fundamental-file-binary-output-stream (fundamental-file-output-stream
443                                                 fd-binary-output-stream)
444    ())
445
446(make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream)
447
448(defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream)
449    ())
450
451(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream)
452
453
454
455
456;;; This stuff is a lot simpler if we restrict the hair to the
457;;; case of file streams opened in :io mode (which have to worry
458;;; about flushing the shared buffer before filling it, and things
459;;; like that.)
460
461(defmethod stream-clear-input ((f fundamental-file-input-stream))
462  (with-stream-ioblock-input (file-ioblock f :speedy t)
463    (call-next-method)
464    (synch-file-octet-filepos file-ioblock)
465    nil))
466
467
468(defmethod stream-clear-input ((f basic-file-input-stream))
469  (let* ((file-ioblock (basic-stream-ioblock f)))
470    (with-ioblock-input-locked (file-ioblock)
471      (call-next-method)
472      (synch-file-octet-filepos file-ioblock)
473      nil)))
474
475   
476(defmethod stream-clear-input ((f fundamental-file-io-stream))
477  (with-stream-ioblock-input (file-ioblock f :speedy t)
478    (stream-force-output f)             
479    (call-next-method)
480    (synch-file-octet-filepos file-ioblock)
481    nil))
482
483(defmethod stream-clear-input ((f basic-file-io-stream))
484  (let* ((file-ioblock (basic-stream-ioblock f)))
485    (with-ioblock-input-locked (file-ioblock)
486      (call-next-method)
487      (synch-file-octet-filepos file-ioblock)
488      nil)))
489
490(defmethod stream-clear-output ((f fundamental-file-output-stream))
491  (with-stream-ioblock-output (file-ioblock f :speedy t)
492    (call-next-method)
493    (synch-file-octet-filepos file-ioblock)
494    nil))
495
496(defmethod stream-clear-output ((f basic-file-output-stream))
497  (let* ((file-ioblock (basic-stream-ioblock f)))
498    (with-ioblock-input-locked (file-ioblock)
499      (call-next-method)
500      (synch-file-octet-filepos file-ioblock)
501      nil)))
502
503
504 
505;;; If we've been reading, the file position where we're going
506;;; to read this time is (+ where-it-was-last-time what-we-read-last-time.)
507(defun input-file-ioblock-advance (stream file-ioblock read-p)
508  (let* ((newpos (+ (file-ioblock-octet-pos file-ioblock)
509                    (io-buffer-count (file-ioblock-inbuf file-ioblock))))
510         (curpos (ioblock-octets-to-elements
511                  file-ioblock
512                  (file-octet-filepos file-ioblock))))
513    (unless (eql newpos curpos)
514      (break "Expected newpos to be ~d, fd is at ~d" newpos curpos))
515    (setf (file-ioblock-octet-pos file-ioblock) newpos)
516    (fd-stream-advance stream file-ioblock read-p)))
517
518;;; If the buffer's dirty, we have to back up and rewrite it before
519;;; reading in a new buffer.
520(defun io-file-ioblock-advance (stream file-ioblock read-p)
521  (let* ((curpos (file-ioblock-octet-pos file-ioblock))
522         (count (io-buffer-count (file-ioblock-inbuf file-ioblock)))
523         (newpos (+ curpos 
524                    (ioblock-elements-to-octets file-ioblock count))))
525    (when (ioblock-dirty file-ioblock)
526      (file-ioblock-seek file-ioblock curpos)
527      (fd-stream-force-output stream file-ioblock count nil))
528    (unless (eql newpos (file-octet-filepos file-ioblock))
529      (break "Expected newpos to be ~d, fd is at ~d"
530             newpos (file-octet-filepos file-ioblock)))
531    (setf (file-ioblock-octet-pos file-ioblock) newpos)
532    (fd-stream-advance stream file-ioblock read-p)))
533
534                   
535(defun output-file-force-output (stream file-ioblock count finish-p)
536  ;; Check to see if we're where we think we should be.
537  (let* ((curpos (file-ioblock-octet-pos file-ioblock)))
538    (unless (eql curpos (file-octet-filepos file-ioblock))
539      (break "Expected newpos to be ~d, fd is at ~d"
540             curpos (file-octet-filepos file-ioblock)))
541    (let* ((n (fd-stream-force-output stream file-ioblock count finish-p)))
542      (incf (file-ioblock-octet-pos file-ioblock) (or n 0))
543      n)))
544
545;;; Can't be sure where the underlying fd is positioned, so seek first.
546(defun io-file-force-output (stream file-ioblock count finish-p)
547  (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock))
548  (output-file-force-output stream file-ioblock count finish-p))
549
550
551;;; Invalidate both buffers and seek to the new position.  The output
552;;; buffer's been flushed already if it needed to be.
553
554(defun file-ioblock-seek-and-reset (file-ioblock newoctetpos)
555  (let* ((inbuf (file-ioblock-inbuf file-ioblock))
556         (outbuf (file-ioblock-outbuf file-ioblock)))
557    (setf (file-ioblock-untyi-char file-ioblock) nil)
558    (setf (file-ioblock-dirty file-ioblock) nil)
559    (when inbuf
560      (setf (io-buffer-count inbuf) 0
561            (io-buffer-idx inbuf) 0))
562    (when outbuf
563      (setf (io-buffer-count outbuf) 0
564            (io-buffer-idx outbuf) 0))
565    (setf (file-ioblock-octet-pos file-ioblock) newoctetpos)
566    (file-ioblock-seek file-ioblock newoctetpos)))
567
568(defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos)
569  (with-stream-ioblock-input (file-ioblock stream :speedy t)
570    (%ioblock-input-file-position file-ioblock newpos)))
571
572
573(defmethod stream-position ((stream basic-file-input-stream) &optional newpos)
574  (let* ((file-ioblock (basic-stream-ioblock stream)))
575    (with-ioblock-input-locked (file-ioblock)
576      (%ioblock-input-file-position file-ioblock newpos))))
577
578(defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos)
579  (with-stream-ioblock-output (file-ioblock stream :speedy t)
580    (%ioblock-output-file-position file-ioblock newpos)))
581
582(defmethod stream-position ((stream basic-file-output-stream) &optional newpos)
583  (let* ((file-ioblock (basic-stream-ioblock stream)))
584    (with-ioblock-output-locked (file-ioblock)
585      (%ioblock-output-file-position file-ioblock newpos))))
586
587
588(defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos)
589  (with-stream-ioblock-input (file-ioblock stream :speedy t)
590    (%ioblock-io-file-position file-ioblock newpos)))
591
592(defmethod stream-position ((stream basic-file-io-stream) &optional newpos)
593  (let* ((file-ioblock (basic-stream-ioblock stream)))
594    (with-ioblock-input-locked (file-ioblock)
595      (%ioblock-io-file-position file-ioblock newpos))))
596
597
598(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen)
599  (with-stream-ioblock-input (file-ioblock stream :speedy t)
600    (%ioblock-input-file-length file-ioblock newlen)))
601
602(defmethod stream-length ((stream basic-file-input-stream) &optional newlen)
603  (let* ((file-ioblock (basic-stream-ioblock stream)))
604    (with-ioblock-input-locked (file-ioblock)
605      (%ioblock-input-file-length file-ioblock newlen))))
606
607
608(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen)
609  (with-stream-ioblock-output (file-ioblock s :speedy t)
610    (%ioblock-output-file-length file-ioblock newlen)))
611
612
613(defmethod stream-length ((stream basic-file-output-stream) &optional newlen)
614  (let* ((file-ioblock (basic-stream-ioblock stream)))
615    (with-ioblock-output-locked (file-ioblock)
616      (%ioblock-output-file-length file-ioblock newlen))))
617
618(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen)
619  (with-stream-ioblock-input (file-ioblock s :speedy t)
620    (%ioblock-output-file-length file-ioblock newlen)))
621
622(defmethod stream-length ((stream basic-file-io-stream) &optional newlen)
623  (let* ((file-ioblock (basic-stream-ioblock stream)))
624    (with-ioblock-input-locked (file-ioblock)
625      (%ioblock-output-file-length file-ioblock newlen))))
626
627(defun close-file-stream (s abort)
628  (when (open-stream-p s)
629    (let* ((ioblock (stream-ioblock s t))
630           (filename (stream-filename s))
631           (actual-filename (stream-actual-filename s)))
632      (when actual-filename
633        (if abort
634          (progn
635            (setf (ioblock-dirty ioblock) nil)
636            (fd-stream-close s ioblock)
637            (unix-rename (namestring actual-filename) (probe-file-x filename)))
638          (delete-file actual-filename)))
639      (setq *open-file-streams* (nremove s *open-file-streams*)))))
640
641
642(defmethod close ((s fundamental-file-stream) &key abort)
643  (close-file-stream s abort)
644  (call-next-method))
645
646(defmethod close ((s basic-file-stream) &key abort)
647  (close-file-stream s abort)
648  (call-next-method))
649
650(defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p)
651  (if char-p
652    (if (and in-p out-p)
653      'fundamental-file-character-io-stream
654      (if in-p
655        'fundamental-file-character-input-stream
656        (if out-p
657          'fundamental-file-character-output-stream
658          'fundamental-file-stream)))
659    (if (and in-p out-p)
660      'fundamental-file-binary-io-stream
661      (if in-p
662        'fundamental-file-binary-input-stream
663        (if out-p
664          'fundamental-file-binary-output-stream
665          'fundamental-file-stream)))))
666
667(defmethod select-stream-class ((class file-stream) in-p out-p char-p)
668  (if char-p
669    (if (and in-p out-p)
670      'fundamental-file-character-io-stream
671      (if in-p
672        'fundamental-file-character-input-stream
673        (if out-p
674          'fundamental-file-character-output-stream
675          'fundamental-file-stream)))
676    (if (and in-p out-p)
677      'fundamental-file-binary-io-stream
678      (if in-p
679        'fundamental-file-binary-input-stream
680        (if out-p
681          'fundamental-file-binary-output-stream
682          'fundamental-file-stream)))))
683
684(defmethod map-to-basic-stream-class-name ((name (eql 'fundamental-file-stream)))
685  'basic-file-stream)
686
687(defmethod map-to-basic-stream-class-name ((name (eql 'file-stream)))
688  'basic-file-stream)
689
690(defmethod select-stream-class ((class (eql 'basic-file-stream)) in-p out-p char-p)
691  (if char-p
692    (if (and in-p out-p)
693      'basic-file-character-io-stream
694      (if in-p
695        'basic-file-character-input-stream
696        (if out-p
697          'basic-file-character-output-stream
698          'basic-file-stream)))
699    (if (and in-p out-p)
700      'basic-file-binary-io-stream
701      (if in-p
702        'basic-file-binary-input-stream
703        (if out-p
704          'basic-file-binary-output-stream
705          'basic-file-stream)))))
706
707
708(defmethod select-stream-advance-function ((s file-stream) direction)
709  (ecase direction
710    (:io 'io-file-ioblock-advance)
711    (:input 'input-file-ioblock-advance)))
712
713(defmethod select-stream-force-output-function ((s file-stream) direction)
714  (ecase direction
715    (:io 'io-file-force-output)
716    (:output 'output-file-force-output)))
717
718
719
720
721(defun make-file-stream (filename
722                         direction
723                         element-type
724                         if-exists
725                         if-does-not-exist
726                         elements-per-buffer
727                         class
728                         external-format
729                         sharing
730                         basic)
731
732  (let* ((temp-name nil)
733         (dir (pathname-directory filename))
734         (filename (if (eq (car dir) :relative)
735                     (full-pathname filename)
736                     filename))
737         (pathname (pathname filename))) 
738    (block open
739      (if (or (memq element-type '(:default character base-char))
740              (subtypep element-type 'character))
741        (if (eq element-type :default)(setq element-type 'character))
742        (progn
743          (setq element-type (type-expand element-type))
744          (cond ((equal element-type '#.(type-expand 'signed-byte))
745                 (setq element-type '(signed-byte 8)))
746                ((equal element-type '#.(type-expand 'unsigned-byte))
747                 (setq element-type '(unsigned-byte 8))))))
748      (case direction
749        (:probe (setq if-exists :ignored))
750        (:input (setq if-exists :ignored))
751        ((:io :output) nil)
752        (t (report-bad-arg direction '(member :input :output :io :probe))))
753      (multiple-value-bind (native-truename kind)(probe-file-x filename)
754        (if native-truename
755          (if (eq kind :directory)
756            (if (eq direction :probe)
757              (return-from open nil)
758              (signal-file-error (- #$EISDIR)  filename))
759            (if (setq filename (if-exists if-exists filename "Open ..."))
760              (progn
761                (multiple-value-setq (native-truename kind) (probe-file-x filename))
762                (cond 
763                  ((not native-truename)
764                   (setq native-truename (%create-file filename)))
765                  ((memq direction '(:output :io))
766                   (when (eq if-exists :supersede)
767                     (let ((truename (native-to-pathname native-truename)))
768                       (setq temp-name (gen-file-name truename))
769                       (unix-rename native-truename (namestring temp-name))
770                       (%create-file native-truename))))))
771              (return-from open nil)))
772          (if (setq filename (if-does-not-exist if-does-not-exist filename))
773            (setq native-truename (%create-file filename))
774            (return-from open nil)))
775        (let* ((fd (fd-open native-truename (case direction
776                                              ((:probe :input) #$O_RDONLY)
777                                              (:output #$O_WRONLY)
778                                              (:io #$O_RDWR)))))
779          (when (< fd 0)  (signal-file-error fd filename))
780          (let* ((fd-kind (%unix-fd-kind fd)))
781            (if (not (eq fd-kind :file))
782              (make-fd-stream fd :direction direction
783                              :element-type element-type
784                              :elements-per-buffer elements-per-buffer
785                              :sharing sharing
786                              :basic basic)
787              (progn
788                (when basic
789                  (setq class (map-to-basic-stream-class-name class))
790                  (setq basic (subtypep (find-class class) 'basic-stream)))
791                (let* ((in-p (member direction '(:io :input)))
792                       (out-p (member direction '(:io :output)))
793                       (io-p (eq direction :io))
794                       (char-p (or (eq element-type 'character)
795                                   (subtypep element-type 'character)))
796                       (real-external-format
797                        (if char-p
798                          (normalize-external-format :file external-format)
799                          ))
800                       (line-termination (if char-p (external-format-line-termination real-external-format)))
801                       (encoding (if char-p (external-format-character-encoding real-external-format)))
802                       (class-name (select-stream-class class in-p out-p char-p))
803                       (class (find-class class-name))
804                       (fstream (make-ioblock-stream
805                                 class
806                                 :insize (if in-p elements-per-buffer)
807                                 :outsize (if (and out-p (not io-p))
808                                            elements-per-buffer)
809                                 :share-buffers-p io-p
810                                 :interactive nil
811                                 :direction direction
812                                 :element-type element-type
813                                 :direction direction
814                                 :listen-function 'fd-stream-listen
815                                 :close-function 'fd-stream-close
816                                 :advance-function
817                                 (if in-p (select-stream-advance-function class direction))
818                                 :force-output-function
819                                 (if out-p (select-stream-force-output-function
820                                           class direction))
821                                 :device fd
822                                 :encoding encoding
823                                 :external-format (or real-external-format :binary)
824                                 :sharing sharing
825                                 :line-termination line-termination
826                                 :character-p (or (eq element-type 'character)
827                                                  (subtypep element-type 'character))))
828                       (ioblock (stream-ioblock fstream t)))
829                  (setf (stream-filename fstream) (namestring pathname)
830                        (stream-actual-filename fstream) temp-name)
831                  (setf (file-ioblock-fileeof ioblock)
832                        (ioblock-octets-to-elements ioblock (fd-size fd)))
833                  (when (and in-p (eq line-termination :inferred))
834                    (infer-line-termination ioblock))
835                  (cond ((eq if-exists :append)
836                         (file-position fstream :end))
837                        ((and (memq direction '(:io :output))
838                              (neq if-exists :overwrite))
839                         (stream-length fstream 0)))
840                  (if (eq direction :probe)
841                    (close fstream)
842                    (push fstream *open-file-streams*))
843                  fstream)))))))))
844
845
846
847
848
849
850(defmethod stream-external-format ((s broadcast-stream))
851  (let* ((last (last-broadcast-stream s)))
852    (if last
853        (stream-external-format s)
854        :default)))
855
856;;; Under the circumstances, this is a very slow way of saying
857;;; "we don't support EXTENDED-CHARs".
858(defun file-string-length (stream object)
859  "Return the delta in STREAM's FILE-POSITION that would be caused by writing
860   OBJECT to STREAM. Non-trivial only in implementations that support
861   international character sets."
862  (if (typep stream 'broadcast-stream)
863    (let* ((last (last-broadcast-stream stream)))
864      (if last
865        (file-string-length last object)
866        1))
867    (progn
868      (unless (and (typep stream 'file-stream)
869                   (let* ((eltype (stream-element-type stream)))
870                     (or (eq 'character eltype)
871                         (eq 'base-char eltype)
872                         (subtypep eltype 'character))))
873        (error "~S is not a file stream capable of character output" stream))
874      (if (typep object 'character)
875        (setq object (make-string 1 :initial-element object))
876        (progn
877          (require-type object 'string)))
878      (let* ((start 0)
879             (end (length object)))
880        (multiple-value-bind (data offset) (array-data-and-offset object)
881          (unless (eq data object)
882            (setq object data)
883            (incf start offset)
884            (incf end offset)))
885        (let* ((external-format (stream-external-format stream))
886               (encoding (get-character-encoding (external-format-character-encoding external-format)))
887               (line-termination (external-format-line-termination external-format)))
888          (-
889           (+ (funcall (character-encoding-octets-in-string-function encoding)
890                       object
891                       start
892                       end)
893              (if (eq line-termination :crlf)
894                (* (count #\Newline object :start start :end end)
895                   (file-string-length stream #\Return))
896                0))
897           (if (eql (file-position stream) 0)
898             0
899             (length (character-encoding-bom-encoding encoding)))))))))
900 
Note: See TracBrowser for help on using the repository browser.