/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Contents of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (show annotations)
Fri Apr 23 03:26:44 2004 UTC (9 years, 11 months ago) by rtoy
Branch: MAIN
Changes since 1.77: +5 -1 lines
The CLHS says OPEN should signal a FILE-ERROR if the pathname is
WILD-PATHNAME-P.
1 ;;; -*- Log: code.log; Package: LISP -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fd-stream.lisp,v 1.78 2004/04/23 03:26:44 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Streams for UNIX file descriptors.
13 ;;;
14 ;;; Written by William Lott, July 1989 - January 1990.
15 ;;; Some tuning by Rob MacLachlan.
16 ;;;
17 ;;; **********************************************************************
18
19
20 (in-package "SYSTEM")
21
22 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
23 io-timeout beep *beep-function* output-raw-bytes
24 *tty* *stdin* *stdout* *stderr*))
25
26
27 (in-package "EXTENSIONS")
28
29 (export '(*backup-extension*))
30
31
32 (in-package "LISP")
33
34 (export '(file-stream file-string-length))
35
36
37 ;;;; Buffer manipulation routines.
38
39 (defvar *available-buffers* ()
40 "List of available buffers. Each buffer is an sap pointing to
41 bytes-per-buffer of memory.")
42
43 (defconstant bytes-per-buffer (* 4 1024)
44 "Number of bytes per buffer.")
45
46 ;;; NEXT-AVAILABLE-BUFFER -- Internal.
47 ;;;
48 ;;; Returns the next available buffer, creating one if necessary.
49 ;;;
50 (declaim (inline next-available-buffer))
51 ;;;
52 (defun next-available-buffer ()
53 (if *available-buffers*
54 (pop *available-buffers*)
55 (allocate-system-memory bytes-per-buffer)))
56
57
58 ;;;; The FD-STREAM structure.
59
60 ;;;; Superclass defined by the ANSI Spec
61 (defstruct (file-stream
62 (:include lisp-stream)
63 (:constructor nil)
64 (:copier nil)))
65
66 (defstruct (fd-stream
67 (:print-function %print-fd-stream)
68 (:constructor %make-fd-stream)
69 (:include file-stream
70 (misc #'fd-stream-misc-routine)))
71
72 (name nil) ; The name of this stream
73 (file nil) ; The file this stream is for
74 ;;
75 ;; The backup file namestring for the old file, for :if-exists :rename or
76 ;; :rename-and-delete.
77 (original nil :type (or simple-string null))
78 (delete-original nil) ; for :if-exists :rename-and-delete
79 ;;
80 ;;; Number of bytes per element.
81 (element-size 1 :type index)
82 (element-type 'base-char) ; The type of element being transfered.
83 (fd -1 :type fixnum) ; The file descriptor
84 ;;
85 ;; Controls when the output buffer is flushed.
86 (buffering :full :type (member :full :line :none))
87 ;;
88 ;; Character position if known.
89 (char-pos nil :type (or index null))
90 ;;
91 ;; T if input is waiting on FD. :EOF if we hit EOF.
92 (listen nil :type (member nil t :eof))
93 ;;
94 ;; The input buffer.
95 (unread nil)
96 (ibuf-sap nil :type (or system-area-pointer null))
97 (ibuf-length nil :type (or index null))
98 (ibuf-head 0 :type index)
99 (ibuf-tail 0 :type index)
100
101 ;; The output buffer.
102 (obuf-sap nil :type (or system-area-pointer null))
103 (obuf-length nil :type (or index null))
104 (obuf-tail 0 :type index)
105
106 ;; Output flushed, but not written due to non-blocking io.
107 (output-later nil)
108 (handler nil)
109 ;;
110 ;; Timeout specified for this stream, or NIL if none.
111 (timeout nil :type (or index null))
112 ;;
113 ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
114 (pathname nil :type (or pathname null)))
115
116 (defun %print-fd-stream (fd-stream stream depth)
117 (declare (ignore depth) (stream stream))
118 (format stream "#<Stream for ~A>"
119 (fd-stream-name fd-stream)))
120
121
122 (define-condition io-timeout (stream-error)
123 ((direction :reader io-timeout-direction :initarg :direction))
124 (:report
125 (lambda (condition stream)
126 (declare (stream stream))
127 (format stream "Timeout ~(~A~)ing ~S."
128 (io-timeout-direction condition)
129 (stream-error-stream condition)))))
130
131
132 ;;;; Output routines and related noise.
133
134 (defvar *output-routines* ()
135 "List of all available output routines. Each element is a list of the
136 element-type output, the kind of buffering, the function name, and the number
137 of bytes per element.")
138
139 ;;; DO-OUTPUT-LATER -- internal
140 ;;;
141 ;;; Called by the server when we can write to the given file descriptor.
142 ;;; Attempt to write the data again. If it worked, remove the data from the
143 ;;; output-later list. If it didn't work, something is wrong.
144 ;;;
145 (defun do-output-later (stream)
146 (let* ((stuff (pop (fd-stream-output-later stream)))
147 (base (car stuff))
148 (start (cadr stuff))
149 (end (caddr stuff))
150 (reuse-sap (cadddr stuff))
151 (length (- end start)))
152 (declare (type index start end length))
153 (multiple-value-bind
154 (count errno)
155 (unix:unix-write (fd-stream-fd stream)
156 base
157 start
158 length)
159 (cond ((not count)
160 (if (= errno unix:ewouldblock)
161 (error "Write would have blocked, but SERVER told us to go.")
162 (error "While writing ~S: ~A"
163 stream (unix:get-unix-error-msg errno))))
164 ((eql count length) ; Hot damn, it worked.
165 (when reuse-sap
166 (push base *available-buffers*)))
167 ((not (null count)) ; Sorta worked.
168 (push (list base
169 (the index (+ start count))
170 end)
171 (fd-stream-output-later stream))))))
172 (unless (fd-stream-output-later stream)
173 (system:remove-fd-handler (fd-stream-handler stream))
174 (setf (fd-stream-handler stream) nil)))
175
176 ;;; OUTPUT-LATER -- internal
177 ;;;
178 ;;; Arrange to output the string when we can write on the file descriptor.
179 ;;;
180 (defun output-later (stream base start end reuse-sap)
181 (cond ((null (fd-stream-output-later stream))
182 (setf (fd-stream-output-later stream)
183 (list (list base start end reuse-sap)))
184 (setf (fd-stream-handler stream)
185 (system:add-fd-handler (fd-stream-fd stream)
186 :output
187 #'(lambda (fd)
188 (declare (ignore fd))
189 (do-output-later stream)))))
190 (t
191 (nconc (fd-stream-output-later stream)
192 (list (list base start end reuse-sap)))))
193 (when reuse-sap
194 (let ((new-buffer (next-available-buffer)))
195 (setf (fd-stream-obuf-sap stream) new-buffer)
196 (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
197
198 ;;; DO-OUTPUT -- internal
199 ;;;
200 ;;; Output the given noise. Check to see if there are any pending writes. If
201 ;;; so, just queue this one. Otherwise, try to write it. If this would block,
202 ;;; queue it.
203 ;;;
204 (defun do-output (stream base start end reuse-sap)
205 (declare (type fd-stream stream)
206 (type (or system-area-pointer (simple-array * (*))) base)
207 (type index start end))
208 (if (not (null (fd-stream-output-later stream))) ; something buffered.
209 (progn
210 (output-later stream base start end reuse-sap)
211 ;; ### check to see if any of this noise can be output
212 )
213 (let ((length (- end start)))
214 (multiple-value-bind
215 (count errno)
216 (unix:unix-write (fd-stream-fd stream) base start length)
217 (cond ((not count)
218 (if (= errno unix:ewouldblock)
219 (output-later stream base start end reuse-sap)
220 (error 'simple-stream-error
221 :stream stream
222 :format-control "while writing: ~A"
223 :format-arguments (list (unix:get-unix-error-msg errno)))))
224 ((not (eql count length))
225 (output-later stream base (the index (+ start count))
226 end reuse-sap)))))))
227
228
229 ;;; FLUSH-OUTPUT-BUFFER -- internal
230 ;;;
231 ;;; Flush any data in the output buffer.
232 ;;;
233 (defun flush-output-buffer (stream)
234 (let ((length (fd-stream-obuf-tail stream)))
235 (unless (= length 0)
236 (do-output stream (fd-stream-obuf-sap stream) 0 length t)
237 (setf (fd-stream-obuf-tail stream) 0))))
238
239 ;;; DEF-OUTPUT-ROUTINES -- internal
240 ;;;
241 ;;; Define output routines that output numbers size bytes long for the
242 ;;; given bufferings. Use body to do the actual output.
243 ;;;
244 (defmacro def-output-routines ((name size &rest bufferings) &body body)
245 (declare (optimize (speed 1)))
246 (cons 'progn
247 (mapcar
248 #'(lambda (buffering)
249 (let ((function
250 (intern (let ((*print-case* :upcase))
251 (format nil name (car buffering))))))
252 `(progn
253 (defun ,function (stream byte)
254 ,(unless (eq (car buffering) :none)
255 `(when (< (fd-stream-obuf-length stream)
256 (+ (fd-stream-obuf-tail stream)
257 ,size))
258 (flush-output-buffer stream)))
259 ;;
260 ;; If there is any input read from UNIX but not
261 ;; supplied to the user of the stream, reposition
262 ;; to the real file position as seen from Lisp.
263 ,(unless (eq (car buffering) :none)
264 `(when (> (fd-stream-ibuf-tail stream)
265 (fd-stream-ibuf-head stream))
266 (file-position stream (file-position stream))))
267 ,@body
268 (incf (fd-stream-obuf-tail stream) ,size)
269 ,(ecase (car buffering)
270 (:none
271 `(flush-output-buffer stream))
272 (:line
273 `(when (eq (char-code byte) (char-code #\Newline))
274 (flush-output-buffer stream)))
275 (:full
276 ))
277 (values))
278 (setf *output-routines*
279 (nconc *output-routines*
280 ',(mapcar
281 #'(lambda (type)
282 (list type
283 (car buffering)
284 function
285 size))
286 (cdr buffering)))))))
287 bufferings)))
288
289 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
290 1
291 (:none character)
292 (:line character)
293 (:full character))
294 (if (char= byte #\Newline)
295 (setf (fd-stream-char-pos stream) 0)
296 (incf (fd-stream-char-pos stream)))
297 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
298 (char-code byte)))
299
300 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
301 1
302 (:none (unsigned-byte 8))
303 (:full (unsigned-byte 8)))
304 (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
305 byte))
306
307 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
308 1
309 (:none (signed-byte 8))
310 (:full (signed-byte 8)))
311 (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
312 (fd-stream-obuf-tail stream))
313 byte))
314
315 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
316 2
317 (:none (unsigned-byte 16))
318 (:full (unsigned-byte 16)))
319 (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
320 byte))
321
322 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
323 2
324 (:none (signed-byte 16))
325 (:full (signed-byte 16)))
326 (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
327 (fd-stream-obuf-tail stream))
328 byte))
329
330 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
331 4
332 (:none (unsigned-byte 32))
333 (:full (unsigned-byte 32)))
334 (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
335 byte))
336
337 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
338 4
339 (:none (signed-byte 32))
340 (:full (signed-byte 32)))
341 (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
342 (fd-stream-obuf-tail stream))
343 byte))
344
345
346 ;;; OUTPUT-RAW-BYTES -- public
347 ;;;
348 ;;; Does the actual output. If there is space to buffer the string, buffer
349 ;;; it. If the string would normally fit in the buffer, but doesn't because
350 ;;; of other stuff in the buffer, flush the old noise out of the buffer and
351 ;;; put the string in it. Otherwise we have a very long string, so just
352 ;;; send it directly (after flushing the buffer, of course).
353 ;;;
354 (defun output-raw-bytes (stream thing &optional start end)
355 "Output THING to stream. THING can be any kind of vector or a sap. If THING
356 is a SAP, END must be supplied (as length won't work)."
357 (let ((start (or start 0))
358 (end (or end (length (the (simple-array * (*)) thing)))))
359 (declare (type index start end))
360 ;;
361 ;; If there is any input read from UNIX but not
362 ;; supplied to the user of the stream, reposition
363 ;; to the real file position as seen from Lisp.
364 (when (> (fd-stream-ibuf-tail stream)
365 (fd-stream-ibuf-head stream))
366 (file-position stream (file-position stream)))
367 (let* ((len (fd-stream-obuf-length stream))
368 (tail (fd-stream-obuf-tail stream))
369 (space (- len tail))
370 (bytes (- end start))
371 (newtail (+ tail bytes)))
372 (cond ((minusp bytes) ; Error case
373 (cerror "Just go on as if nothing happened..."
374 "~S called with :END before :START!"
375 'output-raw-bytes))
376 ((zerop bytes)) ; Easy case
377 ((<= bytes space)
378 (if (system-area-pointer-p thing)
379 (system-area-copy thing
380 (* start vm:byte-bits)
381 (fd-stream-obuf-sap stream)
382 (* tail vm:byte-bits)
383 (* bytes vm:byte-bits))
384 (copy-to-system-area thing
385 (+ (* start vm:byte-bits)
386 (* vm:vector-data-offset vm:word-bits))
387 (fd-stream-obuf-sap stream)
388 (* tail vm:byte-bits)
389 (* bytes vm:byte-bits)))
390 (setf (fd-stream-obuf-tail stream) newtail))
391 ((<= bytes len)
392 (flush-output-buffer stream)
393 (if (system-area-pointer-p thing)
394 (system-area-copy thing
395 (* start vm:byte-bits)
396 (fd-stream-obuf-sap stream)
397 0
398 (* bytes vm:byte-bits))
399 (copy-to-system-area thing
400 (+ (* start vm:byte-bits)
401 (* vm:vector-data-offset vm:word-bits))
402 (fd-stream-obuf-sap stream)
403 0
404 (* bytes vm:byte-bits)))
405 (setf (fd-stream-obuf-tail stream) bytes))
406 (t
407 (flush-output-buffer stream)
408 (do-output stream thing start end nil))))))
409
410 ;;; FD-SOUT -- internal
411 ;;;
412 ;;; Routine to use to output a string. If the stream is unbuffered, slam
413 ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
414 ;;; buffer the string. Update charpos by checking to see where the last newline
415 ;;; was.
416 ;;;
417 ;;; Note: some bozos (the FASL dumper) call write-string with things other
418 ;;; than strings. Therefore, we must make sure we have a string before calling
419 ;;; position on it.
420 ;;;
421 (defun fd-sout (stream thing start end)
422 (let ((start (or start 0))
423 (end (or end (length (the vector thing)))))
424 (declare (type index start end))
425 (if (stringp thing)
426 (let ((last-newline (and (find #\newline (the simple-string thing)
427 :start start :end end)
428 (position #\newline (the simple-string thing)
429 :from-end t
430 :start start
431 :end end))))
432 (ecase (fd-stream-buffering stream)
433 (:full
434 (output-raw-bytes stream thing start end))
435 (:line
436 (output-raw-bytes stream thing start end)
437 (when last-newline
438 (flush-output-buffer stream)))
439 (:none
440 (do-output stream thing start end nil)))
441 (if last-newline
442 (setf (fd-stream-char-pos stream)
443 (- end last-newline 1))
444 (incf (fd-stream-char-pos stream)
445 (- end start))))
446 (ecase (fd-stream-buffering stream)
447 ((:line :full)
448 (output-raw-bytes stream thing start end))
449 (:none
450 (do-output stream thing start end nil))))))
451
452 ;;; PICK-OUTPUT-ROUTINE -- internal
453 ;;;
454 ;;; Find an output routine to use given the type and buffering. Return as
455 ;;; multiple values the routine, the real type transfered, and the number of
456 ;;; bytes per element.
457 ;;;
458 (defun pick-output-routine (type buffering)
459 (dolist (entry *output-routines*)
460 (when (and (subtypep type (car entry))
461 (eq buffering (cadr entry)))
462 (return (values (symbol-function (caddr entry))
463 (car entry)
464 (cadddr entry))))))
465
466
467 ;;;; Input routines and related noise.
468
469 (defvar *input-routines* ()
470 "List of all available input routines. Each element is a list of the
471 element-type input, the function name, and the number of bytes per element.")
472
473 ;;; DO-INPUT -- internal
474 ;;;
475 ;;; Fills the input buffer, and returns the first character. Throws to
476 ;;; eof-input-catcher if the eof was reached. Drops into system:server if
477 ;;; necessary.
478 ;;;
479 (defun do-input (stream)
480 (let ((fd (fd-stream-fd stream))
481 (ibuf-sap (fd-stream-ibuf-sap stream))
482 (buflen (fd-stream-ibuf-length stream))
483 (head (fd-stream-ibuf-head stream))
484 (tail (fd-stream-ibuf-tail stream)))
485 (declare (type index head tail))
486 (unless (zerop head)
487 (cond ((eql head tail)
488 (setf head 0)
489 (setf tail 0)
490 (setf (fd-stream-ibuf-head stream) 0)
491 (setf (fd-stream-ibuf-tail stream) 0))
492 (t
493 (decf tail head)
494 (system-area-copy ibuf-sap (* head vm:byte-bits)
495 ibuf-sap 0 (* tail vm:byte-bits))
496 (setf head 0)
497 (setf (fd-stream-ibuf-head stream) 0)
498 (setf (fd-stream-ibuf-tail stream) tail))))
499 (setf (fd-stream-listen stream) nil)
500 (multiple-value-bind
501 (count errno)
502 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
503 (unix:fd-zero read-fds)
504 (unix:fd-set fd read-fds)
505 (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0))
506 ;; Wait if input is not available or if interrupted.
507 (when (or (eql count 0)
508 (and (not count) (eql errno unix:eintr)))
509 (unless #-mp (system:wait-until-fd-usable
510 fd :input (fd-stream-timeout stream))
511 #+mp (mp:process-wait-until-fd-usable
512 fd :input (fd-stream-timeout stream))
513 (error 'io-timeout :stream stream :direction :read))))
514 (multiple-value-bind
515 (count errno)
516 (unix:unix-read fd
517 (system:int-sap (+ (system:sap-int ibuf-sap) tail))
518 (- buflen tail))
519 (cond ((null count)
520 (if (eql errno unix:ewouldblock)
521 (progn
522 (unless #-mp (system:wait-until-fd-usable
523 fd :input (fd-stream-timeout stream))
524 #+mp (mp:process-wait-until-fd-usable
525 fd :input (fd-stream-timeout stream))
526 (error 'io-timeout :stream stream :direction :read))
527 (do-input stream))
528 (error "Error reading ~S: ~A"
529 stream
530 (unix:get-unix-error-msg errno))))
531 ((zerop count)
532 (setf (fd-stream-listen stream) :eof)
533 (throw 'eof-input-catcher nil))
534 (t
535 (incf (fd-stream-ibuf-tail stream) count))))))
536
537 ;;; INPUT-AT-LEAST -- internal
538 ;;;
539 ;;; Makes sure there are at least ``bytes'' number of bytes in the input
540 ;;; buffer. Keeps calling do-input until that condition is met.
541 ;;;
542 (defmacro input-at-least (stream bytes)
543 (let ((stream-var (gensym))
544 (bytes-var (gensym)))
545 `(let ((,stream-var ,stream)
546 (,bytes-var ,bytes))
547 (loop
548 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
549 (fd-stream-ibuf-head ,stream-var))
550 ,bytes-var)
551 (return))
552 (do-input ,stream-var)))))
553
554 ;;; INPUT-WRAPPER -- intenal
555 ;;;
556 ;;; Macro to wrap around all input routines to handle eof-error noise.
557 ;;;
558 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
559 (let ((stream-var (gensym))
560 (element-var (gensym)))
561 `(let ((,stream-var ,stream))
562 (if (fd-stream-unread ,stream-var)
563 (prog1
564 (fd-stream-unread ,stream-var)
565 (setf (fd-stream-unread ,stream-var) nil)
566 (setf (fd-stream-listen ,stream-var) nil))
567 (let ((,element-var
568 (catch 'eof-input-catcher
569 (input-at-least ,stream-var ,bytes)
570 ,@read-forms)))
571 (cond (,element-var
572 (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
573 ,element-var)
574 (t
575 (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
576
577 ;;; DEF-INPUT-ROUTINE -- internal
578 ;;;
579 ;;; Defines an input routine.
580 ;;;
581 (defmacro def-input-routine (name
582 (type size sap head)
583 &rest body)
584 `(progn
585 (defun ,name (stream eof-error eof-value)
586 (input-wrapper (stream ,size eof-error eof-value)
587 (let ((,sap (fd-stream-ibuf-sap stream))
588 (,head (fd-stream-ibuf-head stream)))
589 ,@body)))
590 (setf *input-routines*
591 (nconc *input-routines*
592 (list (list ',type ',name ',size))))))
593
594 ;;; INPUT-CHARACTER -- internal
595 ;;;
596 ;;; Routine to use in stream-in slot for reading string chars.
597 ;;;
598 (def-input-routine input-character
599 (character 1 sap head)
600 (code-char (sap-ref-8 sap head)))
601
602 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
603 ;;;
604 ;;; Routine to read in an unsigned 8 bit number.
605 ;;;
606 (def-input-routine input-unsigned-8bit-byte
607 ((unsigned-byte 8) 1 sap head)
608 (sap-ref-8 sap head))
609
610 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
611 ;;;
612 ;;; Routine to read in a signed 8 bit number.
613 ;;;
614 (def-input-routine input-signed-8bit-number
615 ((signed-byte 8) 1 sap head)
616 (signed-sap-ref-8 sap head))
617
618 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
619 ;;;
620 ;;; Routine to read in an unsigned 16 bit number.
621 ;;;
622 (def-input-routine input-unsigned-16bit-byte
623 ((unsigned-byte 16) 2 sap head)
624 (sap-ref-16 sap head))
625
626 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
627 ;;;
628 ;;; Routine to read in a signed 16 bit number.
629 ;;;
630 (def-input-routine input-signed-16bit-byte
631 ((signed-byte 16) 2 sap head)
632 (signed-sap-ref-16 sap head))
633
634 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
635 ;;;
636 ;;; Routine to read in a unsigned 32 bit number.
637 ;;;
638 (def-input-routine input-unsigned-32bit-byte
639 ((unsigned-byte 32) 4 sap head)
640 (sap-ref-32 sap head))
641
642 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
643 ;;;
644 ;;; Routine to read in a signed 32 bit number.
645 ;;;
646 (def-input-routine input-signed-32bit-byte
647 ((signed-byte 32) 4 sap head)
648 (signed-sap-ref-32 sap head))
649
650 ;;; PICK-INPUT-ROUTINE -- internal
651 ;;;
652 ;;; Find an input routine to use given the type. Return as multiple values
653 ;;; the routine, the real type transfered, and the number of bytes per element.
654 ;;;
655 (defun pick-input-routine (type)
656 (dolist (entry *input-routines*)
657 (when (subtypep type (car entry))
658 (return (values (symbol-function (cadr entry))
659 (car entry)
660 (caddr entry))))))
661
662 ;;; STRING-FROM-SAP -- internal
663 ;;;
664 ;;; Returns a string constructed from the sap, start, and end.
665 ;;;
666 (defun string-from-sap (sap start end)
667 (declare (type index start end))
668 (let* ((length (- end start))
669 (string (make-string length)))
670 (copy-from-system-area sap (* start vm:byte-bits)
671 string (* vm:vector-data-offset vm:word-bits)
672 (* length vm:byte-bits))
673 string))
674
675 #|
676 ;;; FD-STREAM-READ-N-BYTES -- internal
677 ;;;
678 ;;; This version waits using server. I changed to the non-server version
679 ;;; because it allows this method to be used by CLX w/o confusing serve-event.
680 ;;; The non-server method is also significantly more efficient for large
681 ;;; reads. -- Ram
682 ;;;
683 ;;; The n-bin routine.
684 ;;;
685 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
686 (declare (type stream stream) (type index start requested))
687 (let* ((sap (fd-stream-ibuf-sap stream))
688 (elsize (fd-stream-element-size stream))
689 (offset (* elsize start))
690 (bytes (* elsize requested))
691 (result
692 (catch 'eof-input-catcher
693 (loop
694 (input-at-least stream 1)
695 (let* ((head (fd-stream-ibuf-head stream))
696 (tail (fd-stream-ibuf-tail stream))
697 (available (- tail head))
698 (copy (min available bytes)))
699 (if (typep buffer 'system-area-pointer)
700 (system-area-copy sap (* head vm:byte-bits)
701 buffer (* offset vm:byte-bits)
702 (* copy vm:byte-bits))
703 (copy-from-system-area sap (* head vm:byte-bits)
704 buffer (+ (* offset vm:byte-bits)
705 (* vm:vector-data-offset
706 vm:word-bits))
707 (* copy vm:byte-bits)))
708 (incf (fd-stream-ibuf-head stream) copy)
709 (incf offset copy)
710 (decf bytes copy))
711 (when (zerop bytes)
712 (return requested))))))
713 (or result
714 (eof-or-lose stream eof-error-p
715 (- requested (/ bytes elsize))))))
716 |#
717
718
719 ;;; FD-STREAM-READ-N-BYTES -- internal
720 ;;;
721 ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks
722 ;;; in UNIX-READ. This allows the method to be used to implementing reading
723 ;;; for CLX. It is generally used where there is a definite amount of reading
724 ;;; to be done, so blocking isn't too problematical.
725 ;;;
726 ;;; We copy buffered data into the buffer. If there is enough, just return.
727 ;;; Otherwise, we see if the amount of additional data needed will fit in the
728 ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer
729 ;;; argument), and read directly into the user supplied buffer. Otherwise,
730 ;;; read a buffer-full into the stream buffer and then copy the amount we need
731 ;;; out.
732 ;;;
733 ;;; We loop doing the reads until we either get enough bytes or hit EOF. We
734 ;;; must loop when eof-errorp is T because some streams (like pipes) may return
735 ;;; a partial amount without hitting EOF.
736 ;;;
737 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
738 (declare (type stream stream) (type index start requested))
739 (let* ((sap (fd-stream-ibuf-sap stream))
740 (offset start)
741 (head (fd-stream-ibuf-head stream))
742 (tail (fd-stream-ibuf-tail stream))
743 (available (- tail head))
744 (copy (min requested available)))
745 (declare (type index offset head tail available copy))
746 ;;
747 ;; If something has been unread, put that at buffer + start,
748 ;; and read the rest to start + 1.
749 (when (fd-stream-unread stream)
750 (etypecase buffer
751 (system-area-pointer
752 (assert (= 1 (fd-stream-element-size stream)))
753 (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
754 (vector
755 (setf (aref buffer start) (read-char stream))))
756 (return-from fd-stream-read-n-bytes
757 (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
758 eof-error-p))))
759 ;;
760 (unless (zerop copy)
761 (if (typep buffer 'system-area-pointer)
762 (system-area-copy sap (* head vm:byte-bits)
763 buffer (* offset vm:byte-bits)
764 (* copy vm:byte-bits))
765 (copy-from-system-area sap (* head vm:byte-bits)
766 buffer (+ (* offset vm:byte-bits)
767 (* vm:vector-data-offset
768 vm:word-bits))
769 (* copy vm:byte-bits)))
770 (incf (fd-stream-ibuf-head stream) copy))
771 (cond
772 ((or (= copy requested)
773 (and (not eof-error-p) (/= copy 0)))
774 copy)
775 (t
776 (setf (fd-stream-ibuf-head stream) 0)
777 (setf (fd-stream-ibuf-tail stream) 0)
778 (setf (fd-stream-listen stream) nil)
779 (let ((now-needed (- requested copy))
780 (len (fd-stream-ibuf-length stream)))
781 (declare (type index now-needed len))
782 (cond
783 ((> now-needed len)
784 ;;
785 ;; If the desired amount is greater than the stream buffer size, then
786 ;; read directly into the destination, incrementing the start
787 ;; accordingly. In this case, we never leave anything in the stream
788 ;; buffer.
789 (system:without-gcing
790 (loop
791 (multiple-value-bind
792 (count err)
793 (unix:unix-read (fd-stream-fd stream)
794 (sap+ (if (typep buffer 'system-area-pointer)
795 buffer
796 (vector-sap buffer))
797 (+ offset copy))
798 now-needed)
799 (declare (type (or index null) count))
800 (unless count
801 (error "Error reading ~S: ~A" stream
802 (unix:get-unix-error-msg err)))
803 (decf now-needed count)
804 (if eof-error-p
805 (when (zerop count)
806 (error 'end-of-file :stream stream))
807 (return (- requested now-needed)))
808 (when (zerop now-needed) (return requested))
809 (incf offset count)))))
810 (t
811 ;;
812 ;; If we want less than the buffer size, then loop trying to fill the
813 ;; stream buffer and copying what we get into the destination. When
814 ;; we have enough, we leave what's left in the stream buffer.
815 (loop
816 (multiple-value-bind
817 (count err)
818 (unix:unix-read (fd-stream-fd stream) sap len)
819 (declare (type (or index null) count))
820 (unless count
821 (error "Error reading ~S: ~A" stream
822 (unix:get-unix-error-msg err)))
823 (when (and eof-error-p (zerop count))
824 (error 'end-of-file :stream stream))
825
826 (let* ((copy (min now-needed count))
827 (copy-bits (* copy vm:byte-bits))
828 (buffer-start-bits
829 (* (+ offset available) vm:byte-bits)))
830 (declare (type index copy copy-bits buffer-start-bits))
831 (if (typep buffer 'system-area-pointer)
832 (system-area-copy sap 0
833 buffer buffer-start-bits
834 copy-bits)
835 (copy-from-system-area sap 0
836 buffer (+ buffer-start-bits
837 (* vm:vector-data-offset
838 vm:word-bits))
839 copy-bits))
840
841 (decf now-needed copy)
842 (when (or (zerop now-needed) (not eof-error-p))
843 (setf (fd-stream-ibuf-head stream) copy)
844 (setf (fd-stream-ibuf-tail stream) count)
845 (return (- requested now-needed)))
846 (incf offset copy)))))))))))
847
848
849 ;;;; Utility functions (misc routines, etc)
850
851 ;;; SET-ROUTINES -- internal
852 ;;;
853 ;;; Fill in the various routine slots for the given type. Input-p and
854 ;;; output-p indicate what slots to fill. The buffering slot must be set prior
855 ;;; to calling this routine.
856 ;;;
857 (defun set-routines (stream type input-p output-p buffer-p)
858 (let ((target-type (case type
859 ((:default unsigned-byte)
860 '(unsigned-byte 8))
861 (signed-byte
862 '(signed-byte 8))
863 (t
864 type)))
865 (input-type nil)
866 (output-type nil)
867 (input-size nil)
868 (output-size nil))
869
870 (when (fd-stream-obuf-sap stream)
871 (push (fd-stream-obuf-sap stream) *available-buffers*)
872 (setf (fd-stream-obuf-sap stream) nil))
873 (when (fd-stream-ibuf-sap stream)
874 (push (fd-stream-ibuf-sap stream) *available-buffers*)
875 (setf (fd-stream-ibuf-sap stream) nil))
876
877 (when input-p
878 (multiple-value-bind
879 (routine type size)
880 (pick-input-routine target-type)
881 (unless routine
882 (error "Could not find any input routine for ~S" target-type))
883 (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
884 (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
885 (setf (fd-stream-ibuf-tail stream) 0)
886 (if (subtypep type 'character)
887 (setf (fd-stream-in stream) routine
888 (fd-stream-bin stream) #'ill-bin)
889 (setf (fd-stream-in stream) #'ill-in
890 (fd-stream-bin stream) routine))
891 (when (or (eql size 1)
892 (eql size 2)
893 (eql size 4))
894 ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
895 (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
896 (when (and buffer-p (eql size 1)
897 (or (eq type 'unsigned-byte)
898 (eq type :default)))
899 ;; We only create this buffer for streams of type
900 ;; (unsigned-byte 8). Because there's no buffer, the
901 ;; other element-types will dispatch to the appropriate
902 ;; input (output) routine in fast-read-byte.
903 (setf (lisp-stream-in-buffer stream)
904 (make-array in-buffer-length
905 :element-type '(unsigned-byte 8)))))
906 (setf input-size size)
907 (setf input-type type)))
908
909 (when output-p
910 (multiple-value-bind
911 (routine type size)
912 (pick-output-routine target-type (fd-stream-buffering stream))
913 (unless routine
914 (error "Could not find any output routine for ~S buffered ~S."
915 (fd-stream-buffering stream)
916 target-type))
917 (setf (fd-stream-obuf-sap stream) (next-available-buffer))
918 (setf (fd-stream-obuf-length stream) bytes-per-buffer)
919 (setf (fd-stream-obuf-tail stream) 0)
920 (if (subtypep type 'character)
921 (setf (fd-stream-out stream) routine
922 (fd-stream-bout stream) #'ill-bout)
923 (setf (fd-stream-out stream)
924 (or (if (eql size 1)
925 (pick-output-routine 'base-char
926 (fd-stream-buffering stream)))
927 #'ill-out)
928 (fd-stream-bout stream) routine))
929 (setf (fd-stream-sout stream)
930 (if (eql size 1) #'fd-sout #'ill-out))
931 (setf (fd-stream-char-pos stream) 0)
932 (setf output-size size)
933 (setf output-type type)))
934
935 (when (and input-size output-size
936 (not (eq input-size output-size)))
937 (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
938 input-type input-size
939 output-type output-size))
940 (setf (fd-stream-element-size stream)
941 (or input-size output-size))
942
943 (setf (fd-stream-element-type stream)
944 (cond ((equal input-type output-type)
945 input-type)
946 ((null output-type)
947 input-type)
948 ((null input-type)
949 output-type)
950 ((subtypep input-type output-type)
951 input-type)
952 ((subtypep output-type input-type)
953 output-type)
954 (t
955 (error "Input type (~S) and output type (~S) are unrelated?"
956 input-type
957 output-type))))))
958
959 ;;; REVERT-FILE -- internal
960 ;;;
961 ;;; Revert a file, if possible; otherwise just delete it. Used during
962 ;;; CLOSE when the abort flag is set.
963 ;;;
964 (defun revert-file (filename original)
965 (declare (type simple-base-string filename)
966 (type (or simple-base-string null) original))
967 (if original
968 (multiple-value-bind (okay err) (unix:unix-rename original filename)
969 (unless okay
970 (cerror "Go on as if nothing bad happened."
971 "Could not restore ~S to its original contents: ~A"
972 filename (unix:get-unix-error-msg err))))
973 (multiple-value-bind (okay err) (unix:unix-unlink filename)
974 (unless okay
975 (cerror "Go on as if nothing bad happened."
976 "Could not remove ~S: ~A"
977 filename (unix:get-unix-error-msg err))))))
978
979 ;;; DELETE-ORIGINAL -- internal
980 ;;;
981 ;;; Delete a backup file. Used during CLOSE.
982 ;;;
983 (defun delete-original (filename original)
984 (declare (type simple-base-string filename)
985 (type (or simple-base-string null) original))
986 (when original
987 (multiple-value-bind (okay err) (unix:unix-unlink original)
988 (unless okay
989 (cerror "Go on as if nothing bad happened."
990 "Could not delete ~S during close of ~S: ~A"
991 original filename (unix:get-unix-error-msg err))))))
992
993 ;;; FD-STREAM-MISC-ROUTINE -- input
994 ;;;
995 ;;; Handle the various misc operations on fd-stream.
996 ;;;
997 (defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
998 (declare (ignore arg2))
999 (case operation
1000 (:listen
1001 (or (not (eql (fd-stream-ibuf-head stream)
1002 (fd-stream-ibuf-tail stream)))
1003 (fd-stream-listen stream)
1004 (setf (fd-stream-listen stream)
1005 (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1006 (unix:fd-zero read-fds)
1007 (unix:fd-set (fd-stream-fd stream) read-fds)
1008 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1009 (alien:addr read-fds) nil nil
1010 0 0))
1011 1))))
1012 (:unread
1013 (setf (fd-stream-unread stream) arg1)
1014 (setf (fd-stream-listen stream) t))
1015 (:close
1016 (cond (arg1
1017 ;; We got us an abort on our hands.
1018 (when (fd-stream-handler stream)
1019 (system:remove-fd-handler (fd-stream-handler stream))
1020 (setf (fd-stream-handler stream) nil))
1021 (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
1022 (revert-file (fd-stream-file stream)
1023 (fd-stream-original stream))))
1024 (t
1025 (fd-stream-misc-routine stream :finish-output)
1026 (when (fd-stream-delete-original stream)
1027 (delete-original (fd-stream-file stream)
1028 (fd-stream-original stream)))))
1029 (when (fboundp 'cancel-finalization)
1030 (cancel-finalization stream))
1031 (unix:unix-close (fd-stream-fd stream))
1032 (when (fd-stream-obuf-sap stream)
1033 (push (fd-stream-obuf-sap stream) *available-buffers*)
1034 (setf (fd-stream-obuf-sap stream) nil))
1035 (when (fd-stream-ibuf-sap stream)
1036 (push (fd-stream-ibuf-sap stream) *available-buffers*)
1037 (setf (fd-stream-ibuf-sap stream) nil))
1038 (lisp::set-closed-flame stream))
1039 (:clear-input
1040 (setf (fd-stream-unread stream) nil)
1041 (setf (fd-stream-ibuf-head stream) 0)
1042 (setf (fd-stream-ibuf-tail stream) 0)
1043 (catch 'eof-input-catcher
1044 (loop
1045 (multiple-value-bind
1046 (count errno)
1047 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1048 (unix:fd-zero read-fds)
1049 (unix:fd-set (fd-stream-fd stream) read-fds)
1050 (unix:unix-fast-select (1+ (fd-stream-fd stream))
1051 (alien:addr read-fds) nil nil 0 0))
1052 (cond ((eql count 1)
1053 (do-input stream)
1054 (setf (fd-stream-ibuf-head stream) 0)
1055 (setf (fd-stream-ibuf-tail stream) 0))
1056 ((and (not count) (eql errno unix:eintr)))
1057 (t
1058 (return t)))))))
1059 (:force-output
1060 (flush-output-buffer stream))
1061 (:finish-output
1062 (flush-output-buffer stream)
1063 (do ()
1064 ((null (fd-stream-output-later stream)))
1065 (system:serve-all-events)))
1066 (:element-type
1067 (fd-stream-element-type stream))
1068 (:interactive-p
1069 (unix:unix-isatty (fd-stream-fd stream)))
1070 (:line-length
1071 80)
1072 (:charpos
1073 (fd-stream-char-pos stream))
1074 (:file-length
1075 (unless (fd-stream-file stream)
1076 (error 'simple-type-error
1077 :datum stream
1078 :expected-type 'file-stream
1079 :format-control "~s is not a stream associated with a file."
1080 :format-arguments (list stream)))
1081 (multiple-value-bind
1082 (okay dev ino mode nlink uid gid rdev size
1083 atime mtime ctime blksize blocks)
1084 (unix:unix-fstat (fd-stream-fd stream))
1085 (declare (ignore ino nlink uid gid rdev
1086 atime mtime ctime blksize blocks))
1087 (unless okay
1088 (error 'simple-file-error
1089 :format-control "Error fstating ~S: ~A"
1090 :format-arguments (list stream (unix:get-unix-error-msg dev))))
1091 (if (zerop mode)
1092 nil
1093 (values (truncate size (fd-stream-element-size stream))))))
1094 (:file-position
1095 (fd-stream-file-position stream arg1))))
1096
1097
1098 ;;; FD-STREAM-FILE-POSITION -- internal.
1099 ;;;
1100 (defun fd-stream-file-position (stream &optional newpos)
1101 (declare (type fd-stream stream)
1102 (type (or (integer 0) (member nil :start :end)) newpos))
1103 (if (null newpos)
1104 (system:without-interrupts
1105 ;; First, find the position of the UNIX file descriptor in the file.
1106 (multiple-value-bind
1107 (posn errno)
1108 (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
1109 (declare (type (or (integer 0) null) posn))
1110 (cond (posn
1111 ;; Adjust for buffered output:
1112 ;; If there is any output buffered, the *real* file position
1113 ;; will be larger than reported by lseek because lseek
1114 ;; obviously cannot take into account output we have not
1115 ;; sent yet.
1116 (dolist (later (fd-stream-output-later stream))
1117 (incf posn (- (the index (caddr later))
1118 (the index (cadr later)))))
1119 (incf posn (fd-stream-obuf-tail stream))
1120 ;; Adjust for unread input:
1121 ;; If there is any input read from UNIX but not supplied to
1122 ;; the user of the stream, the *real* file position will
1123 ;; smaller than reported, because we want to look like the
1124 ;; unread stuff is still available.
1125 (decf posn (- (fd-stream-ibuf-tail stream)
1126 (fd-stream-ibuf-head stream)))
1127 (when (fd-stream-unread stream)
1128 (decf posn))
1129 ;; Divide bytes by element size.
1130 (truncate posn (fd-stream-element-size stream)))
1131 ((eq errno unix:espipe)
1132 nil)
1133 (t
1134 (system:with-interrupts
1135 (error "Error lseek'ing ~S: ~A"
1136 stream
1137 (unix:get-unix-error-msg errno)))))))
1138 (let ((offset 0)
1139 origin)
1140 (declare (type (integer 0) offset))
1141 ;; Make sure we don't have any output pending, because if we move the
1142 ;; file pointer before writing this stuff, it will be written in the
1143 ;; wrong location.
1144 (flush-output-buffer stream)
1145 (do ()
1146 ((null (fd-stream-output-later stream)))
1147 (system:serve-all-events))
1148 ;; Clear out any pending input to force the next read to go to the
1149 ;; disk.
1150 (setf (fd-stream-unread stream) nil)
1151 (setf (fd-stream-ibuf-head stream) 0)
1152 (setf (fd-stream-ibuf-tail stream) 0)
1153 ;; Trash cached value for listen, so that we check next time.
1154 (setf (fd-stream-listen stream) nil)
1155 ;; Now move it.
1156 (cond ((eq newpos :start)
1157 (setf offset 0
1158 origin unix:l_set))
1159 ((eq newpos :end)
1160 (setf offset 0
1161 origin unix:l_xtnd))
1162 ((typep newpos '(integer 0))
1163 (setf offset (* newpos (fd-stream-element-size stream))
1164 origin unix:l_set))
1165 (t
1166 (error "Invalid position given to file-position: ~S" newpos)))
1167 (multiple-value-bind
1168 (posn errno)
1169 (unix:unix-lseek (fd-stream-fd stream) offset origin)
1170 (cond (posn
1171 t)
1172 ((eq errno unix:espipe)
1173 nil)
1174 (t
1175 (error "Error lseek'ing ~S: ~A"
1176 stream
1177 (unix:get-unix-error-msg errno))))))))
1178
1179
1180
1181 ;;;; Creation routines (MAKE-FD-STREAM and OPEN)
1182
1183 ;;; MAKE-FD-STREAM -- Public.
1184 ;;;
1185 ;;; Returns a FD-STREAM on the given file.
1186 ;;;
1187 (defun make-fd-stream (fd
1188 &key
1189 (input nil input-p)
1190 (output nil output-p)
1191 (element-type 'base-char)
1192 (buffering :full)
1193 timeout
1194 file
1195 original
1196 delete-original
1197 pathname
1198 input-buffer-p
1199 (name (if file
1200 (format nil "file ~S" file)
1201 (format nil "descriptor ~D" fd)))
1202 auto-close)
1203 (declare (type index fd) (type (or index null) timeout)
1204 (type (member :none :line :full) buffering))
1205 "Create a stream for the given unix file descriptor.
1206 If input is non-nil, allow input operations.
1207 If output is non-nil, allow output operations.
1208 If neither input nor output are specified, default to allowing input.
1209 Element-type indicates the element type to use (as for open).
1210 Buffering indicates the kind of buffering to use.
1211 Timeout (if true) is the number of seconds to wait for input. If NIL (the
1212 default), then wait forever. When we time out, we signal IO-TIMEOUT.
1213 File is the name of the file (will be returned by PATHNAME).
1214 Name is used to identify the stream when printed."
1215 (cond ((not (or input-p output-p))
1216 (setf input t))
1217 ((not (or input output))
1218 (error "File descriptor must be opened either for input or output.")))
1219 (let ((stream (%make-fd-stream :fd fd
1220 :name name
1221 :file file
1222 :original original
1223 :delete-original delete-original
1224 :pathname pathname
1225 :buffering buffering
1226 :timeout timeout)))
1227 (set-routines stream element-type input output input-buffer-p)
1228 (when (and auto-close (fboundp 'finalize))
1229 (finalize stream
1230 #'(lambda ()
1231 (unix:unix-close fd)
1232 (format *terminal-io* "** Closed ~A~%" name)
1233 (when original
1234 (revert-file file original)))))
1235 stream))
1236
1237
1238 ;;; PICK-BACKUP-NAME -- internal
1239 ;;;
1240 ;;; Pick a name to use for the backup file.
1241 ;;;
1242 (defvar *backup-extension* ".BAK"
1243 "This is a string that OPEN tacks on the end of a file namestring to produce
1244 a name for the :if-exists :rename-and-delete and :rename options. Also,
1245 this can be a function that takes a namestring and returns a complete
1246 namestring.")
1247 ;;;
1248 (defun pick-backup-name (name)
1249 (declare (type simple-string name))
1250 (let ((ext *backup-extension*))
1251 (etypecase ext
1252 (simple-string (concatenate 'simple-string name ext))
1253 (function (funcall ext name)))))
1254
1255 ;;; NEXT-VERSION -- internal
1256 ;;;
1257 ;;; Find the next available versioned name for a file.
1258 ;;;
1259 (defun next-version (name)
1260 (declare (type simple-string name))
1261 (let* ((sep (position #\/ name :from-end t))
1262 (base (if sep (subseq name 0 (1+ sep)) ""))
1263 (dir (unix:open-dir base)))
1264 (multiple-value-bind (name type version)
1265 (extract-name-type-and-version name (if sep (1+ sep) 0) (length name))
1266 (let ((version (if (symbolp version) 1 (1+ version)))
1267 (match (if type
1268 (concatenate 'string name "." type ".~")
1269 (concatenate 'string name ".~"))))
1270 (when dir
1271 (unwind-protect
1272 (loop
1273 (let ((name (unix:read-dir dir)))
1274 (cond ((null name) (return))
1275 ((and (> (length name) (length match))
1276 (string= name match :end1 (length match)))
1277 (multiple-value-bind (v e)
1278 (parse-integer name :start (length match)
1279 :junk-allowed t)
1280 (when (and v
1281 (= (length name) (1+ e))
1282 (char= (schar name e) #\~))
1283 (setq version (max version (1+ v)))))))))
1284 (unix:close-dir dir)))
1285 (concatenate 'string base
1286 match (quick-integer-to-string version) "~")))))
1287
1288 ;;; ASSURE-ONE-OF -- internal
1289 ;;;
1290 ;;; Assure that the given arg is one of the given list of valid things.
1291 ;;; Allow the user to fix any problems.
1292 ;;;
1293 (defun assure-one-of (item list what)
1294 (unless (member item list)
1295 (loop
1296 (cerror "Enter new value for ~*~S"
1297 "~S is invalid for ~S. Must be one of~{ ~S~}"
1298 item
1299 what
1300 list)
1301 (format (the stream *query-io*) "Enter new value for ~S: " what)
1302 (force-output *query-io*)
1303 (setf item (read *query-io*))
1304 (when (member item list)
1305 (return))))
1306 item)
1307
1308 ;;; DO-OLD-RENAME -- Internal
1309 ;;;
1310 ;;; Rename Namestring to Original. First, check if we have write access,
1311 ;;; since we don't want to trash unwritable files even if we technically can.
1312 ;;; We return true if we succeed in renaming.
1313 ;;;
1314 (defun do-old-rename (namestring original)
1315 (unless (unix:unix-access namestring unix:w_ok)
1316 (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
1317 (multiple-value-bind
1318 (okay err)
1319 (unix:unix-rename namestring original)
1320 (cond (okay t)
1321 (t
1322 (cerror "Use :SUPERSEDE instead."
1323 "Could not rename ~S to ~S: ~A."
1324 namestring
1325 original
1326 (unix:get-unix-error-msg err))
1327 nil))))
1328
1329 ;;; FD-OPEN -- Internal
1330 ;;;
1331 ;;; Open a file.
1332 ;;;
1333 (defun fd-open (pathname direction if-exists if-exists-given
1334 if-does-not-exist if-does-not-exist-given)
1335 (declare (type pathname pathname)
1336 (type (member :input :output :io :probe) direction)
1337 (type (member :error :new-version :rename :rename-and-delete
1338 :overwrite :append :supersede nil) if-exists)
1339 (type (member :error :create nil) if-does-not-exist))
1340 (multiple-value-bind (input output mask)
1341 (ecase direction
1342 (:input (values t nil unix:o_rdonly))
1343 (:output (values nil t unix:o_wronly))
1344 (:io (values t t unix:o_rdwr))
1345 (:probe (values t nil unix:o_rdonly)))
1346 (declare (type index mask))
1347 ;; Process if-exists argument if we are doing any output.
1348 (cond (output
1349 (unless if-exists-given
1350 (setf if-exists
1351 (if (eq (pathname-version pathname) :newest)
1352 :new-version
1353 :error)))
1354 (case if-exists
1355 ((:error nil)
1356 (setf mask (logior mask unix:o_excl)))
1357 ((:new-version :rename :rename-and-delete)
1358 (setf mask (logior mask unix:o_creat)))
1359 (:supersede
1360 (setf mask (logior mask unix:o_trunc)))))
1361 (t
1362 (setf if-exists nil))) ; :ignore-this-arg
1363
1364 (unless if-does-not-exist-given
1365 (setf if-does-not-exist
1366 (cond ((eq direction :input) :error)
1367 ((and output
1368 (member if-exists '(:overwrite :append)))
1369 :error)
1370 ((eq direction :probe)
1371 nil)
1372 (t
1373 :create))))
1374 (if (eq if-does-not-exist :create)
1375 (setf mask (logior mask unix:o_creat)))
1376
1377 (let ((name (cond ((unix-namestring pathname input))
1378 ((and input (eq if-does-not-exist :create))
1379 (unix-namestring pathname nil)))))
1380 (let ((original (cond ((eq if-exists :new-version)
1381 (next-version name))
1382 ((member if-exists '(:rename :rename-and-delete))
1383 (pick-backup-name name))))
1384 (delete-original (eq if-exists :rename-and-delete))
1385 (mode #o666))
1386 (when original
1387 ;; We are doing a :rename or :rename-and-delete.
1388 ;; Determine if the file already exists, make sure the original
1389 ;; file is not a directory and keep the mode
1390 (let ((exists
1391 (and name
1392 (multiple-value-bind
1393 (okay err/dev inode orig-mode)
1394 (unix:unix-stat name)
1395 (declare (ignore inode)
1396 (type (or index null) orig-mode))
1397 (cond
1398 (okay
1399 (when (and output (= (logand orig-mode #o170000)
1400 #o40000))
1401 (error 'simple-file-error
1402 :pathname pathname
1403 :format-control
1404 "Cannot open ~S for output: Is a directory."
1405 :format-arguments (list name)))
1406 (setf mode (logand orig-mode #o777))
1407 t)
1408 ((eql err/dev unix:enoent)
1409 nil)
1410 (t
1411 (error 'simple-file-error
1412 :pathname pathname
1413 :format-control "Cannot find ~S: ~A"
1414 :format-arguments
1415 (list name
1416 (unix:get-unix-error-msg err/dev)))))))))
1417 (unless (and exists
1418 (do-old-rename name original))
1419 (setf original nil)
1420 (setf delete-original nil)
1421 ;; In order to use SUPERSEDE instead, we have
1422 ;; to make sure unix:o_creat corresponds to
1423 ;; if-does-not-exist. unix:o_creat was set
1424 ;; before because of if-exists being :rename.
1425 (unless (eq if-does-not-exist :create)
1426 (setf mask (logior (logandc2 mask unix:o_creat)
1427 unix:o_trunc)))
1428 (setf if-exists :supersede))))
1429
1430 ;; Okay, now we can try the actual open.
1431 (loop
1432 (multiple-value-bind (fd errno)
1433 (if name
1434 (unix:unix-open name mask mode)
1435 (values nil unix:enoent))
1436 (cond ((fixnump fd)
1437 (when (eq if-exists :append)
1438 (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END
1439 (return (values fd name original delete-original)))
1440 ((eql errno unix:enoent)
1441 (case if-does-not-exist
1442 (:error
1443 (cerror "Return NIL."
1444 'simple-file-error
1445 :pathname pathname
1446 :format-control "Error opening ~S, ~A."
1447 :format-arguments
1448 (list pathname
1449 (unix:get-unix-error-msg errno))))
1450 (:create
1451 (cerror "Return NIL."
1452 'simple-file-error
1453 :pathname pathname
1454 :format-control
1455 "Error creating ~S, path does not exist."
1456 :format-arguments (list pathname))))
1457 (return nil))
1458 ((eql errno unix:eexist)
1459 (unless (eq nil if-exists)
1460 (cerror "Return NIL."
1461 'simple-file-error
1462 :pathname pathname
1463 :format-control "Error opening ~S, ~A."
1464 :format-arguments
1465 (list pathname
1466 (unix:get-unix-error-msg errno))))
1467 (return nil))
1468 ((eql errno unix:eacces)
1469 (cerror "Try again."
1470 'simple-file-error
1471 :pathname pathname
1472 :format-control "Error opening ~S, ~A."
1473 :format-arguments
1474 (list pathname
1475 (unix:get-unix-error-msg errno))))
1476 (t
1477 (cerror "Return NIL."
1478 'simple-file-error
1479 :pathname pathname
1480 :format-control "Error opening ~S, ~A."
1481 :format-arguments
1482 (list pathname
1483 (unix:get-unix-error-msg errno)))
1484 (return nil)))))))))
1485
1486 ;;; OPEN-FD-STREAM -- Internal
1487 ;;;
1488 ;;; Open an fd-stream connected to a file.
1489 ;;;
1490 (defun open-fd-stream (pathname &key (direction :input)
1491 (element-type 'base-char)
1492 (if-exists nil if-exists-given)
1493 (if-does-not-exist nil if-does-not-exist-given)
1494 (external-format :default))
1495 (declare (type pathname pathname)
1496 (type (member :input :output :io :probe) direction)
1497 (type (member :error :new-version :rename :rename-and-delete
1498 :overwrite :append :supersede nil) if-exists)
1499 (type (member :error :create nil) if-does-not-exist)
1500 (ignore external-format))
1501 (multiple-value-bind (fd namestring original delete-original)
1502 (fd-open pathname direction if-exists if-exists-given
1503 if-does-not-exist if-does-not-exist-given)
1504 (when fd
1505 (case direction
1506 ((:input :output :io)
1507 (make-fd-stream fd
1508 :input (member direction '(:input :io))
1509 :output (member direction '(:output :io))
1510 :element-type element-type
1511 :file namestring
1512 :original original
1513 :delete-original delete-original
1514 :pathname pathname
1515 :input-buffer-p t
1516 :auto-close t))
1517 (:probe
1518 (let ((stream (%make-fd-stream :name namestring :fd fd
1519 :pathname pathname
1520 :element-type element-type)))
1521 (close stream)
1522 stream))))))
1523
1524 ;;; OPEN -- public
1525 ;;;
1526 ;;; Open the given file.
1527 ;;;
1528 (defun open (filename &rest options
1529 &key (direction :input)
1530 (element-type 'base-char element-type-given)
1531 (if-exists nil if-exists-given)
1532 (if-does-not-exist nil if-does-not-exist-given)
1533 (external-format :default)
1534 class mapped input-handle output-handle
1535 &allow-other-keys
1536 &aux ; Squelch assignment warning.
1537 (direction direction)
1538 (if-does-not-exist if-does-not-exist)
1539 (if-exists if-exists))
1540 "Return a stream which reads from or writes to Filename.
1541 Defined keywords:
1542 :direction - one of :input, :output, :io, or :probe
1543 :element-type - Type of object to read or write, default BASE-CHAR
1544 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1545 :overwrite, :append, :supersede or nil
1546 :if-does-not-exist - one of :error, :create or nil
1547 :external-format - :default
1548 See the manual for details."
1549 (declare (ignore external-format input-handle output-handle))
1550
1551 ;; OPEN signals a file-error if the filename is wild.
1552 (when (wild-pathname-p filename)
1553 (error 'file-error :pathname filename))
1554
1555 ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
1556 (setq direction
1557 (assure-one-of direction
1558 '(:input :output :io :probe)
1559 :direction))
1560 (setf (getf options :direction) direction)
1561
1562 (when (and if-exists-given (member direction '(:output :io)))
1563 (setq if-exists
1564 (assure-one-of if-exists
1565 '(:error :new-version :rename
1566 :rename-and-delete :overwrite
1567 :append :supersede nil)
1568 :if-exists))
1569 (setf (getf options :if-exists) if-exists))
1570
1571 (when if-does-not-exist-given
1572 (setq if-does-not-exist
1573 (assure-one-of if-does-not-exist
1574 '(:error :create nil)
1575 :if-does-not-exist))
1576 (setf (getf options :if-does-not-exist) if-does-not-exist))
1577
1578 (let ((filespec (pathname filename))
1579 (options (copy-list options))
1580 (class (or class 'fd-stream)))
1581 (cond ((eq class 'fd-stream)
1582 (remf options :class)
1583 (remf options :mapped)
1584 (remf options :input-handle)
1585 (remf options :output-handle)
1586 (apply #'open-fd-stream filespec options))
1587 ((subtypep class 'stream:simple-stream)
1588 (when element-type-given
1589 (cerror "Do it anyway."
1590 "Can't create simple-streams with an element-type."))
1591 (when (and (eq class 'stream:file-simple-stream) mapped)
1592 (setq class 'stream:mapped-file-simple-stream)
1593 (setf (getf options :class) 'stream:mapped-file-simple-stream))
1594 (when (subtypep class 'stream:file-simple-stream)
1595 (when (eq direction :probe)
1596 (setq class 'stream:probe-simple-stream)))
1597 (apply #'make-instance class :filename filespec options))
1598 ((subtypep class 'ext:fundamental-stream)
1599 (remf options :class)
1600 (remf options :mapped)
1601 (remf options :input-handle)
1602 (remf options :output-handle)
1603 (let ((stream (apply #'open-fd-stream filespec options)))
1604 (when stream
1605 (make-instance class :lisp-stream stream))))
1606 (t
1607 (error "Unable to open streams of class ~S." class)))))
1608
1609 ;;;; Initialization.
1610
1611 (defvar *tty* nil
1612 "The stream connected to the controlling terminal or NIL if there is none.")
1613 (defvar *stdin* nil
1614 "The stream connected to the standard input (file descriptor 0).")
1615 (defvar *stdout* nil
1616 "The stream connected to the standard output (file descriptor 1).")
1617 (defvar *stderr* nil
1618 "The stream connected to the standard error output (file descriptor 2).")
1619
1620 ;;; STREAM-INIT -- internal interface
1621 ;;;
1622 ;;; Called when the cold load is first started up.
1623 ;;;
1624 (defun stream-init ()
1625 (stream-reinit)
1626 (setf *terminal-io* (make-synonym-stream '*tty*))
1627 (setf *standard-output* (make-synonym-stream '*stdout*))
1628 (setf *standard-input*
1629 (make-two-way-stream (make-synonym-stream '*stdin*)
1630 *standard-output*))
1631 (setf *error-output* (make-synonym-stream '*stderr*))
1632 (setf *query-io* (make-synonym-stream '*terminal-io*))
1633 (setf *debug-io* *query-io*)
1634 (setf *trace-output* *standard-output*)
1635 nil)
1636
1637 ;;; STREAM-REINIT -- internal interface
1638 ;;;
1639 ;;; Called whenever a saved core is restarted.
1640 ;;;
1641 (defun stream-reinit ()
1642 (setf *available-buffers* nil)
1643 (setf *stdin*
1644 (make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
1645 (setf *stdout*
1646 (make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
1647 (setf *stderr*
1648 (make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
1649 (let ((tty (and (not *batch-mode*)
1650 (unix:unix-open "/dev/tty" unix:o_rdwr #o666))))
1651 (setf *tty*
1652 (if tty
1653 (make-fd-stream tty :name "the Terminal" :input t :output t
1654 :buffering :line :auto-close t)
1655 (make-two-way-stream *stdin* *stdout*))))
1656 nil)
1657
1658
1659 ;;;; Beeping.
1660
1661 (defun default-beep-function (stream)
1662 (write-char #\bell stream)
1663 (finish-output stream))
1664
1665 (defvar *beep-function* #'default-beep-function
1666 "This is called in BEEP to feep the user. It takes a stream.")
1667
1668 (defun beep (&optional (stream *terminal-io*))
1669 (funcall *beep-function* stream))
1670
1671
1672 ;;; File-Name -- internal interface
1673 ;;;
1674 ;;; Kind of like File-Position, but is an internal hack used by the filesys
1675 ;;; stuff to get and set the file name.
1676 ;;;
1677 (defun file-name (stream &optional new-name)
1678 (typecase stream
1679 (stream:simple-stream
1680 (if new-name
1681 (stream::%file-rename stream new-name)
1682 (stream::%file-name stream)))
1683 (fd-stream
1684 (cond (new-name
1685 (setf (fd-stream-pathname stream) new-name)
1686 (setf (fd-stream-file stream)
1687 (unix-namestring new-name nil))
1688 t)
1689 (t
1690 (fd-stream-pathname stream))))))
1691
1692
1693 ;;;; Degenerate international character support:
1694
1695 (defun file-string-length (stream object)
1696 (declare (type (or string character) object)
1697 (type (or file-stream broadcast-stream stream:simple-stream) stream))
1698 "Return the delta in Stream's FILE-POSITION that would be caused by writing
1699 Object to Stream. Non-trivial only in implementations that support
1700 international character sets."
1701 (typecase stream
1702 (stream:simple-stream (stream::%file-string-length stream object))
1703 (broadcast-stream
1704 ;; CLHS says we must return 1 in this case
1705 1)
1706 (t
1707 (etypecase object
1708 (character 1)
1709 (string (length object))))))

  ViewVC Help
Powered by ViewVC 1.1.5