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

  ViewVC Help
Powered by ViewVC 1.1.5