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 |
---|
94 | unspecified or specified as :DEFAULT. It can meaningfully be given any |
---|
95 | of the values :UNIX, :MACOS, :MSDOS, :UNICODE or :INFERRED, each of which is |
---|
96 | interpreted as described in the documentation. |
---|
97 | |
---|
98 | Because there's some risk that unsolicited newline translation could have |
---|
99 | undesirable consequences, the initial value of this variable in Clozure CL |
---|
100 | is :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 | (tagbody retry |
---|
778 | (if native-truename |
---|
779 | (if (eq kind :directory) |
---|
780 | (if (eq direction :probe) |
---|
781 | (return-from open nil) |
---|
782 | (signal-file-error (- #$EISDIR) filename)) |
---|
783 | (if (setq filename (if-exists if-exists filename "Open ...")) |
---|
784 | (progn |
---|
785 | (multiple-value-setq (native-truename kind) (probe-file-x filename)) |
---|
786 | (cond |
---|
787 | ((not native-truename) |
---|
788 | (setq native-truename (%create-file filename) |
---|
789 | created t)) |
---|
790 | ((memq direction '(:output :io)) |
---|
791 | (when (eq if-exists :supersede) |
---|
792 | (let ((truename (native-to-pathname native-truename))) |
---|
793 | (setq temp-name (gen-file-name truename)) |
---|
794 | (unix-rename native-truename (native-untranslated-namestring temp-name)) |
---|
795 | (%create-file native-truename)))))) |
---|
796 | (return-from open nil))) |
---|
797 | (if (setq filename (if-does-not-exist if-does-not-exist filename)) |
---|
798 | (progn |
---|
799 | (unless (setq native-truename (%create-file filename :if-exists (case if-exists |
---|
800 | ;; Let %create file handle these cases |
---|
801 | ((:error :overwrite) if-exists) |
---|
802 | (t nil)))) |
---|
803 | ;; Somebody else created the file while we're trying to create it. |
---|
804 | (when (null if-exists) (return-from open nil)) |
---|
805 | (multiple-value-setq (native-truename kind) (probe-file-x filename)) |
---|
806 | (unless native-truename ;; huh? Perhaps it disappeared again? |
---|
807 | (error "Attempt to create ~s failed unexpectedly" filename)) |
---|
808 | (go retry)) |
---|
809 | (setq created t)) |
---|
810 | (return-from open nil)))) |
---|
811 | (let* ((fd (fd-open native-truename (case direction |
---|
812 | ((:probe :input) #$O_RDONLY) |
---|
813 | (:output #$O_WRONLY) |
---|
814 | (:io #$O_RDWR))))) |
---|
815 | (when (< fd 0) (signal-file-error fd filename)) |
---|
816 | (let* ((fd-kind (%unix-fd-kind fd))) |
---|
817 | (if (not (eq fd-kind :file)) |
---|
818 | (make-fd-stream fd :direction direction |
---|
819 | :element-type element-type |
---|
820 | :sharing sharing |
---|
821 | :basic basic) |
---|
822 | (progn |
---|
823 | (when basic |
---|
824 | (setq class (map-to-basic-stream-class-name class)) |
---|
825 | (setq basic (subtypep (find-class class) 'basic-stream))) |
---|
826 | (let* ((in-p (member direction '(:io :input))) |
---|
827 | (out-p (member direction '(:io :output))) |
---|
828 | (io-p (eq direction :io)) |
---|
829 | (char-p (or (eq element-type 'character) |
---|
830 | (subtypep element-type 'character))) |
---|
831 | (elements-per-buffer (optimal-buffer-size fd element-type)) |
---|
832 | (real-external-format |
---|
833 | (if char-p |
---|
834 | (normalize-external-format :file external-format) |
---|
835 | )) |
---|
836 | (line-termination (if char-p (external-format-line-termination real-external-format))) |
---|
837 | (encoding (if char-p (external-format-character-encoding real-external-format))) |
---|
838 | (class-name (select-stream-class class in-p out-p char-p)) |
---|
839 | (class (find-class class-name)) |
---|
840 | (fstream (make-ioblock-stream |
---|
841 | class |
---|
842 | :insize (if in-p elements-per-buffer) |
---|
843 | :outsize (if (and out-p (not io-p)) |
---|
844 | elements-per-buffer) |
---|
845 | :share-buffers-p io-p |
---|
846 | :interactive nil |
---|
847 | :direction direction |
---|
848 | :element-type element-type |
---|
849 | :direction direction |
---|
850 | :listen-function 'fd-stream-listen |
---|
851 | :close-function 'fd-stream-close |
---|
852 | :advance-function |
---|
853 | (if in-p (select-stream-advance-function class direction)) |
---|
854 | :force-output-function |
---|
855 | (if out-p (select-stream-force-output-function |
---|
856 | class direction)) |
---|
857 | :device fd |
---|
858 | :encoding encoding |
---|
859 | :external-format (or real-external-format :binary) |
---|
860 | :sharing sharing |
---|
861 | :line-termination line-termination |
---|
862 | :character-p (or (eq element-type 'character) |
---|
863 | (subtypep element-type 'character)))) |
---|
864 | (ioblock (stream-ioblock fstream t))) |
---|
865 | (setf (stream-filename fstream) (namestring pathname) |
---|
866 | (stream-actual-filename fstream) (or temp-name created)) |
---|
867 | (setf (file-ioblock-fileeof ioblock) |
---|
868 | (ioblock-octets-to-elements ioblock (fd-size fd))) |
---|
869 | (when (and in-p (eq line-termination :inferred)) |
---|
870 | (infer-line-termination ioblock)) |
---|
871 | (cond ((eq if-exists :append) |
---|
872 | (file-position fstream :end)) |
---|
873 | ((and (memq direction '(:io :output)) |
---|
874 | (neq if-exists :overwrite)) |
---|
875 | (stream-length fstream 0))) |
---|
876 | (if (eq direction :probe) |
---|
877 | (close fstream) |
---|
878 | (note-open-file-stream fstream)) |
---|
879 | fstream))))))))) |
---|
880 | |
---|
881 | |
---|
882 | |
---|
883 | |
---|
884 | |
---|
885 | |
---|
886 | (defmethod stream-external-format ((s broadcast-stream)) |
---|
887 | (let* ((last (last-broadcast-stream s))) |
---|
888 | (if last |
---|
889 | (stream-external-format s) |
---|
890 | :default))) |
---|
891 | |
---|
892 | ;;; Under the circumstances, this is a very slow way of saying |
---|
893 | ;;; "we don't support EXTENDED-CHARs". |
---|
894 | (defun file-string-length (stream object) |
---|
895 | "Return the delta in STREAM's FILE-POSITION that would be caused by writing |
---|
896 | OBJECT to STREAM. Non-trivial only in implementations that support |
---|
897 | international character sets." |
---|
898 | (if (typep stream 'broadcast-stream) |
---|
899 | (let* ((last (last-broadcast-stream stream))) |
---|
900 | (if last |
---|
901 | (file-string-length last object) |
---|
902 | 1)) |
---|
903 | (progn |
---|
904 | (unless (and (typep stream 'file-stream) |
---|
905 | (let* ((eltype (stream-element-type stream))) |
---|
906 | (or (eq 'character eltype) |
---|
907 | (eq 'base-char eltype) |
---|
908 | (subtypep eltype 'character)))) |
---|
909 | (error "~S is not a file stream capable of character output" stream)) |
---|
910 | (if (typep object 'character) |
---|
911 | (setq object (make-string 1 :initial-element object)) |
---|
912 | (progn |
---|
913 | (require-type object 'string))) |
---|
914 | (let* ((start 0) |
---|
915 | (end (length object))) |
---|
916 | (multiple-value-bind (data offset) (array-data-and-offset object) |
---|
917 | (unless (eq data object) |
---|
918 | (setq object data) |
---|
919 | (incf start offset) |
---|
920 | (incf end offset))) |
---|
921 | (let* ((external-format (stream-external-format stream)) |
---|
922 | (encoding (get-character-encoding (external-format-character-encoding external-format))) |
---|
923 | (line-termination (external-format-line-termination external-format))) |
---|
924 | (- |
---|
925 | (+ (funcall (character-encoding-octets-in-string-function encoding) |
---|
926 | object |
---|
927 | start |
---|
928 | end) |
---|
929 | (if (eq line-termination :crlf) |
---|
930 | (* (count #\Newline object :start start :end end) |
---|
931 | (file-string-length stream #\Return)) |
---|
932 | 0)) |
---|
933 | (if (eql (file-position stream) 0) |
---|
934 | 0 |
---|
935 | (length (character-encoding-bom-encoding encoding))))))))) |
---|
936 | |
---|