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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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