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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

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