source: branches/qres/ccl/level-1/l1-sysio.lisp @ 15278

Last change on this file since 15278 was 13502, checked in by gz, 10 years ago

From trunk: formatting tweaks, non-linux changes, doc and error message fixes

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