3 ;;; This code is in the public domain.
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain. Sbcl port by Rudi
9 (in-package "SB-SIMPLE-STREAMS")
15 (defmethod print-object ((object file-simple-stream
) stream
)
16 (print-unreadable-object (object stream
:type t
:identity t
)
17 (format stream
"for ~S" (slot-value object
'filename
))))
19 (defun make-control-table (&rest inits
)
20 (let ((table (make-array 32 :initial-element nil
)))
21 (do* ((char (pop inits
) (pop inits
))
22 (func (pop inits
) (pop inits
)))
24 (when (< (char-code char
) 32)
25 (setf (aref table
(char-code char
)) func
)))
28 (defun std-newline-out-handler (stream character
)
29 (declare (ignore character
))
30 (with-stream-class (simple-stream stream
)
31 (setf (sm charpos stream
) -
1)
34 (defun std-tab-out-handler (stream character
)
35 (declare (ignore character
))
36 (with-stream-class (simple-stream stream
)
37 (let ((col (sm charpos stream
)))
39 (setf (sm charpos stream
) (1- (* 8 (1+ (floor col
8)))))))
42 (defun std-dc-newline-in-handler (stream character
)
43 (with-stream-class (dual-channel-simple-stream stream
)
44 (setf (sm charpos stream
) -
1) ;; set to 0 "if reading" ???
47 (defvar *std-control-out-table
*
48 (make-control-table #\Newline
#'std-newline-out-handler
49 #\Tab
#'std-tab-out-handler
))
51 (defvar *terminal-control-in-table
*
52 (make-control-table #\Newline
#'std-dc-newline-in-handler
))
58 (defun vector-elt-width (vector)
59 ;; Return octet-width of vector elements
61 ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
62 ;; [and base-char, which is treated specially]
63 ((simple-array (signed-byte 8) (*)) 1)
64 ((simple-array (unsigned-byte 8) (*)) 1)
65 ((simple-array (signed-byte 16) (*)) 2)
66 ((simple-array (unsigned-byte 16) (*)) 2)
67 ((simple-array (signed-byte 32) (*)) 4)
68 ((simple-array (unsigned-byte 32) (*)) 4)
69 ((simple-array single-float
(*)) 4)
70 ((simple-array double-float
(*)) 8)
71 ((simple-array (complex single-float
) (*)) 8)
72 ((simple-array (complex double-float
) (*)) 16)))
74 (defun endian-swap-value (vector endian-swap
)
76 (:network-order
(case (vector-elt-width vector
)
87 (otherwise endian-swap
)))
89 (defun read-vector (vector stream
&key
(start 0) end
(endian-swap :byte-8
))
90 (declare (type (sb-kernel:simple-unboxed-array
(*)) vector
)
92 ;; START and END are octet offsets, not vector indices! [Except for strings]
93 ;; Return value is index of next octet to be read into (i.e., start+count)
96 (with-stream-class (simple-stream stream
)
98 (let* ((start (or start
0))
99 (end (or end
(length vector
)))
100 (char (funcall-stm-handler j-read-char stream nil nil t
)))
102 (setf (schar vector start
) char
)
104 (+ start
(funcall-stm-handler j-read-chars stream vector nil
107 (cond ((any-stream-instance-flags stream
:string
)
108 (error "Can't READ-BYTE on string streams."))
109 ((any-stream-instance-flags stream
:dual
)
113 (index (or start
0) (1+ index
))
114 (end (or end
(* (length vector
) (vector-elt-width vector
))))
115 (endian-swap (endian-swap-value vector endian-swap
))
116 (byte (funcall j-read-byte stream nil nil t
)
117 (funcall j-read-byte stream nil nil nil
)))
118 ((or (null byte
) (>= index end
)) index
)
119 (setf (bref vector
(logxor index endian-swap
)) byte
)))))
120 ((or ansi-stream fundamental-stream
)
121 (unless (typep vector
'(or string
122 (simple-array (signed-byte 8) (*))
123 (simple-array (unsigned-byte 8) (*))))
124 (error "Wrong vector type for read-vector on stream not of type simple-stream."))
125 (read-sequence vector stream
:start
(or start
0) :end end
))))
127 #|
(defun write-vector ...
)|
#
129 ;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
130 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
131 (defun getpagesize ()
132 (sb-unix::int-syscall
("getpagesize"))))
134 (defun read-octets (stream buffer start end blocking
)
135 (declare (type simple-stream stream
)
136 (type (or null simple-stream-buffer
) buffer
)
138 (type (or null fixnum
) end
)
139 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
140 (with-stream-class (simple-stream stream
)
141 (let ((fd (sm input-handle stream
))
142 (end (or end
(sm buf-len stream
)))
143 (buffer (or buffer
(sm buffer stream
))))
144 (declare (fixnum end
))
147 (let ((flag (sb-sys:wait-until-fd-usable fd
:input
148 (if blocking nil
0))))
150 ((and (not blocking
) (= start end
)) (if flag -
3 0))
151 ((and (not blocking
) (not flag
)) 0)
154 (declare (type fixnum count
))
157 ;; Avoid CMUCL gengc write barrier
158 (do ((i start
(+ i
;#.(sb-unix:unix-getpagesize)
159 (the fixnum
(getpagesize)))))
161 (declare (type fixnum i
))
162 (setf (bref buffer i
) 0))
163 (setf (bref buffer
(1- end
)) 0)
164 (multiple-value-bind (bytes errno
)
165 (sb-unix:unix-read fd
(buffer-sap buffer start
)
166 (the fixnum
(- end start
)))
167 (declare (type (or null fixnum
) bytes
)
168 (type (integer 0 100) errno
))
173 (format t
"~&;; UNIX-READ: errno=~D~%" errno
)
174 (cond ((= errno sb-unix
:eintr
) (go again
))
176 (or (= errno
;;sb-unix:eagain
181 (= errno sb-unix
:ewouldblock
)))
182 (sb-sys:wait-until-fd-usable fd
:input nil
)
184 (t (return (- -
10 errno
)))))
185 ((zerop count
) (return -
1))
186 (t (return count
)))))))))))
187 ;; Handle encapsulated stream. FIXME: perhaps handle
188 ;; sbcl-vintage ansi-stream type in read-octets too?
189 (stream (read-octets fd buffer start end blocking
))
190 (t (error "Don't know how to handle input handle &A" fd
))))))
192 (defun write-octets (stream buffer start end blocking
)
193 (declare (type simple-stream stream
)
194 (type (or null simple-stream-buffer
) buffer
)
196 (type (or null fixnum
) end
))
197 (with-stream-class (simple-stream stream
)
198 (let ((fd (sm output-handle stream
))
199 (end (or end
(error "WRITE-OCTETS: end=NIL")))
200 (buffer (or buffer
(error "WRITE-OCTETS: buffer=NIL"))))
203 (let ((flag (sb-sys:wait-until-fd-usable fd
:output
204 (if blocking nil
0))))
206 ((and (not blocking
) (= start end
)) (if flag -
3 0))
207 ((and (not blocking
) (not flag
)) 0)
212 (multiple-value-bind (bytes errno
)
213 (sb-unix:unix-write fd
(buffer-sap buffer
) start
219 (format *debug-io
* "~&;; UNIX-WRITE: errno=~D~%"
221 (cond ((= errno sb-unix
:eintr
) (go again
))
222 ;; don't block for subsequent chars
223 (t (return (- -
10 errno
)))))
224 (t (return count
)))))))))))
225 ;; Handle encapsulated stream. FIXME: perhaps handle
226 ;; sbcl-vintage ansi-stream type in write-octets too?
227 (stream (write-octets fd buffer start end blocking
))
228 (t (error "Don't know how to handle output handle &A" fd
))))))
235 (defmethod device-open ((stream null-simple-stream
) options
)
236 (add-stream-instance-flags stream
:simple
:input
:output
)
239 (defmethod device-open ((stream buffer-input-simple-stream
) options
)
243 (defmethod device-open ((stream buffer-output-simple-stream
) options
)
247 (defun open-file-stream (stream options
)
248 (let ((filename (pathname (getf options
:filename
)))
249 (direction (getf options
:direction
:input
))
250 (if-exists (getf options
:if-exists
))
251 (if-exists-given (not (getf options
:if-exists t
)))
252 (if-does-not-exist (getf options
:if-does-not-exist
))
253 (if-does-not-exist-given (not (getf options
:if-does-not-exist t
))))
254 (with-stream-class (file-simple-stream stream
)
256 (:input
(add-stream-instance-flags stream
:input
))
257 (:output
(add-stream-instance-flags stream
:output
))
258 (:io
(add-stream-instance-flags stream
:input
:output
)))
259 (cond ((and (sm input-handle stream
) (sm output-handle stream
)
260 (not (eql (sm input-handle stream
)
261 (sm output-handle stream
))))
262 (error "Input-Handle and Output-Handle can't be different."))
263 ((or (sm input-handle stream
) (sm output-handle stream
))
264 (add-stream-instance-flags stream
:simple
)
265 ;; get namestring, etc. from handle, if possible (it's a stream)
269 (multiple-value-bind (fd namestring original delete-original
)
270 (%fd-open filename direction if-exists if-exists-given
271 if-does-not-exist if-does-not-exist-given
)
273 (add-stream-instance-flags stream
:simple
)
274 (setf (sm pathname stream
) filename
275 (sm filename stream
) namestring
276 (sm original stream
) original
277 (sm delete-original stream
) delete-original
)
278 (when (any-stream-instance-flags stream
:input
)
279 (setf (sm input-handle stream
) fd
))
280 (when (any-stream-instance-flags stream
:output
)
281 (setf (sm output-handle stream
) fd
))
282 (sb-ext:finalize stream
284 (sb-unix:unix-close fd
)
285 (format *terminal-io
* "~&;;; ** closed ~S (fd ~D)~%"
289 (defmethod device-open ((stream file-simple-stream
) options
)
290 (with-stream-class (file-simple-stream stream
)
291 (when (open-file-stream stream options
)
293 ;; "The device-open method must be prepared to recognize resource
294 ;; and change-class situations. If no filename is specified in
295 ;; the options list, and if no input-handle or output-handle is
296 ;; given, then the input-handle and output-handle slots should
297 ;; be examined; if non-nil, that means the stream is still open,
298 ;; and thus the operation being requested of device-open is a
299 ;; change-class. Also, a device-open method need not allocate a
300 ;; buffer every time it is called, but may instead reuse a
301 ;; buffer it finds in a stream, if it does not become a security
303 (unless (sm buffer stream
)
304 (let ((length (device-buffer-length stream
)))
305 ;; Buffer should be array of (unsigned-byte 8), in general
306 ;; use strings for now so it's easy to read the content...
307 (setf (sm buffer stream
) (make-string length
)
308 (sm buffpos stream
) 0
309 (sm buffer-ptr stream
) 0
310 (sm buf-len stream
) length
)))
311 (when (any-stream-instance-flags stream
:output
)
312 (setf (sm control-out stream
) *std-control-out-table
*))
313 (install-single-channel-character-strategy
314 stream
(getf options
:external-format
:default
) nil
))))
316 (defmethod device-open ((stream mapped-file-simple-stream
) options
)
317 (with-stream-class (mapped-file-simple-stream stream
)
318 (when (open-file-stream stream options
)
319 (let* ((input (any-stream-instance-flags stream
:input
))
320 (output (any-stream-instance-flags stream
:output
))
321 (prot (logior (if input PROT-READ
0)
322 (if output PROT-WRITE
0)))
323 (fd (or (sm input-handle stream
) (sm output-handle stream
))))
324 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
)
325 (sb-unix:unix-fstat fd
)
326 (declare (ignore ino mode nlink uid gid rdev
))
328 (sb-unix:unix-close fd
)
329 (sb-ext:cancel-finalization stream
)
330 (error "Error fstating ~S: ~A" stream
331 (sb-int:strerror dev
)))
332 (when (> size most-positive-fixnum
)
333 ;; Or else BUF-LEN has to be a general integer, or
334 ;; maybe (unsigned-byte 32). In any case, this means
335 ;; BUF-MAX and BUF-PTR have to be the same, which means
336 ;; number-consing every time BUF-PTR moves...
337 ;; Probably don't have the address space available to map
338 ;; bigger files, anyway. Maybe DEVICE-EXTEND can adjust
339 ;; the mapped portion of the file?
340 (warn "Unable to memory-map entire file.")
341 (setf size most-positive-fixnum
))
343 (sb-unix:unix-mmap nil size prot MAP-SHARED fd
0)))
345 (sb-unix:unix-close fd
)
346 (sb-ext:cancel-finalization stream
)
347 (error "Unable to map file."))
348 (setf (sm buffer stream
) buffer
349 (sm buffpos stream
) 0
350 (sm buffer-ptr stream
) size
351 (sm buf-len stream
) size
)
352 (install-single-channel-character-strategy
353 stream
(getf options
:external-format
:default
) 'mapped
)
354 (sb-ext:finalize stream
356 (sb-unix:unix-munmap buffer size
)
357 (format *terminal-io
* "~&;;; ** unmapped ~S" buffer
)))))))
360 (defmethod device-open ((stream string-input-simple-stream
) options
)
364 (defmethod device-open ((stream string-output-simple-stream
) options
)
368 (defmethod device-open ((stream xp-simple-stream
) options
)
372 (defmethod device-open ((stream fill-pointer-output-simple-stream
) options
)
376 (defmethod device-open ((stream socket-base-simple-stream
) options
)
380 (defmethod device-open ((stream socket-simple-stream
) options
)
381 (with-stream-class (socket-simple-stream stream
)
382 (let* ((remote-host (getf options
:remote-host
))
383 (remote-port (getf options
:remote-port
))
384 (socket (make-instance 'sb-bsd-sockets
:inet-socket
385 :type
:stream
:protocol
:tcp
)))
386 (setf (sm socket stream
) socket
)
387 (sb-bsd-sockets:socket-connect socket remote-host remote-port
)
388 (let ((fd (sb-bsd-sockets:socket-file-descriptor socket
)))
389 ;; Connect stream to socket, ...
390 (setf (sm input-handle stream
) fd
)
391 (setf (sm output-handle stream
) fd
)
392 ;; ... and socket to stream.
393 (setf (slot-value socket
'stream
) stream
)
394 (sb-ext:cancel-finalization socket
)
395 (sb-ext:finalize stream
397 (sb-unix:unix-close fd
)
398 (format *terminal-io
*
399 "~&;;; ** closed socket (fd ~D)~%" fd
))))
400 ;; Now frob the stream slots.
401 (add-stream-instance-flags stream
:simple
:input
:output
:dual
)
402 (unless (sm buffer stream
)
403 (let ((length (device-buffer-length stream
)))
404 ;; Buffer should be array of (unsigned-byte 8), in general
405 ;; use strings for now so it's easy to read the content...
406 (setf (sm buffer stream
) (make-string length
)
407 (sm buffpos stream
) 0
408 (sm buffer-ptr stream
) 0
409 (sm buf-len stream
) length
)))
410 (unless (sm out-buffer stream
)
411 (let ((length (device-buffer-length stream
)))
412 (setf (sm out-buffer stream
) (make-string length
)
413 (sm max-out-pos stream
) length
)))
414 (setf (sm control-in stream
) *terminal-control-in-table
*)
415 (setf (sm control-out stream
) *std-control-out-table
*)
416 (install-dual-channel-character-strategy
417 stream
(getf options
:external-format
:default
)))
420 (defmethod device-open ((stream terminal-simple-stream
) options
)
421 (with-stream-class (terminal-simple-stream stream
)
422 (when (getf options
:input-handle
)
423 (setf (sm input-handle stream
) (getf options
:input-handle
))
424 (add-stream-instance-flags stream
:simple
:interactive
:dual
:input
)
425 (unless (sm buffer stream
)
426 (let ((length (device-buffer-length stream
)))
427 (setf (sm buffer stream
) (make-string length
)
428 (sm buf-len stream
) length
)))
429 (setf (sm control-in stream
) *terminal-control-in-table
*))
430 (when (getf options
:output-handle
)
431 (setf (sm output-handle stream
) (getf options
:output-handle
))
432 (add-stream-instance-flags stream
:simple
:interactive
:dual
:output
)
433 (unless (sm out-buffer stream
)
434 (let ((length (device-buffer-length stream
)))
435 (setf (sm out-buffer stream
) (make-string length
)
436 (sm max-out-pos stream
) length
)))
437 (setf (sm control-out stream
) *std-control-out-table
*))
438 (install-dual-channel-character-strategy
439 stream
(getf options
:external-format
:default
)))
444 (defmethod device-close :around
((stream simple-stream
) abort
)
445 (with-stream-class (simple-stream stream
)
446 (when (any-stream-instance-flags stream
:input
:output
)
447 (when (any-stream-instance-flags stream
:output
)
449 (clear-output stream
)
450 (force-output stream
)))
452 (setf (sm input-handle stream
) nil
453 (sm output-handle stream
) nil
)
454 (remove-stream-instance-flags stream
:input
:output
)
455 (sb-ext:cancel-finalization stream
))))
457 (defmethod device-close ((stream simple-stream
) abort
)
458 (declare (ignore abort
))
461 (defmethod device-close ((stream file-simple-stream
) abort
)
462 (with-stream-class (file-simple-stream stream
)
464 ;; Remove any fd-handler
465 ;; If it's an output stream and has an original name,
469 ;; If there's an original name and delete-original is set
472 (if (sm input-handle stream
)
473 (sb-unix:unix-close
(sm input-handle stream
))
474 (sb-unix:unix-close
(sm output-handle stream
)))
475 (setf (sm buffer stream
) nil
))
478 (defmethod device-close ((stream mapped-file-simple-stream
) abort
)
479 (with-stream-class (mapped-file-simple-stream stream
)
480 (when (sm buffer stream
)
481 (sb-unix:unix-munmap
(sm buffer stream
) (sm buf-len stream
))
482 (setf (sm buffer stream
) nil
))
484 ;; remove any FD handler
485 ;; if it has an original name (is this possible for mapped files?)
489 ;; if there's an original name and delete-original is set (again,
490 ;; is this even possible?), kill the original
492 (sb-unix:unix-close
(sm input-handle stream
)))
495 (defmethod device-close ((stream socket-simple-stream
) abort
)
496 ;; Abort argument is handled by :around method on base class
497 (declare (ignore abort
))
498 (with-stream-class (socket-simple-stream stream
)
499 (sb-unix:unix-close
(sm input-handle stream
))
500 (setf (sm buffer stream
) nil
)
501 (setf (sm out-buffer stream
) nil
))
502 (sb-ext:cancel-finalization stream
)
505 (defmethod device-buffer-length ((stream simple-stream
))
508 (defmethod device-buffer-length ((stream null-simple-stream
))
512 (defmethod device-file-position ((stream simple-stream
))
513 (with-stream-class (simple-stream stream
)
514 ;; this may be wrong if :DUAL flag is set!
515 (sm buffpos stream
)))
517 (defmethod (setf device-file-position
) (value (stream simple-stream
))
518 (with-stream-class (simple-stream stream
)
519 ;; this may be wrong if :DUAL flag is set!
520 (setf (sm buffpos stream
) value
)))
522 (defmethod device-file-position ((stream string-simple-stream
))
523 ;; get string length (of input or output buffer?)
526 (defmethod (setf device-file-position
) (value (stream string-simple-stream
))
527 ;; set string length (of input or output buffer?)
530 (defmethod device-file-position ((stream fill-pointer-output-simple-stream
))
531 ;; get fill pointer (of input or output buffer?)
534 (defmethod (setf device-file-position
)
535 (value (stream fill-pointer-output-simple-stream
))
536 ;; set fill pointer (of input or output buffer?)
539 (defmethod device-file-position ((stream file-simple-stream
))
540 (with-stream-class (file-simple-stream stream
)
541 (values (sb-unix:unix-lseek
(or (sm input-handle stream
)
542 (sm output-handle stream
))
546 (defmethod (setf device-file-position
) (value (stream file-simple-stream
))
547 (declare (type fixnum value
))
548 (with-stream-class (file-simple-stream stream
)
549 (values (sb-unix:unix-lseek
(or (sm input-handle stream
)
550 (sm output-handle stream
))
557 (defmethod device-file-length ((stream simple-stream
))
560 (defmethod device-file-length ((stream direct-simple-stream
))
561 ;; return buffer length
564 (defmethod device-file-length ((stream string-simple-stream
))
565 ;; return string length
568 (defmethod device-file-length ((stream file-simple-stream
))
569 (with-stream-class (file-simple-stream stream
)
570 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
)
571 (sb-unix:unix-fstat
(sm input-handle stream
))
572 (declare (ignore dev ino mode nlink uid gid rdev
))
573 (if okay size nil
))))
576 (defmethod device-read ((stream single-channel-simple-stream
) buffer
578 ;; (when (and (null buffer) (not (eql start end)))
579 ;; (with-stream-class (single-channel-simple-stream stream)
580 ;; (setq buffer (sm buffer stream))
581 ;; (setq end (sm buf-len stream))))
582 (read-octets stream buffer start end blocking
))
584 (defmethod device-read ((stream dual-channel-simple-stream
) buffer
587 (with-stream-class (dual-channel-simple-stream stream
)
588 (setq buffer
(sm buffer stream
))
589 (setq end
(- (sm buf-len stream
) start
))))
590 (read-octets stream buffer start end blocking
))
592 (defmethod device-read ((stream null-simple-stream
) buffer
594 (declare (ignore buffer start end blocking
))
597 (defmethod device-read ((stream terminal-simple-stream
) buffer
599 (let ((result (call-next-method)))
600 (if (= result -
1) -
2 result
)))
603 (defmethod device-clear-input ((stream simple-stream
) buffer-only
)
604 (declare (ignore buffer-only
))
607 (defmethod device-clear-input ((stream terminal-simple-stream
) buffer-only
)
611 (defmethod device-write ((stream single-channel-simple-stream
) buffer
613 (when (and (null buffer
) (not (eql start end
)))
614 (with-stream-class (single-channel-simple-stream stream
)
615 (setf buffer
(sm buffer stream
))
616 (setf end
(sm buffpos stream
))))
617 (write-octets stream buffer start end blocking
))
619 (defmethod device-write ((stream dual-channel-simple-stream
) buffer
621 (when (and (null buffer
) (not (eql start end
)))
622 (with-stream-class (dual-channel-simple-stream stream
)
623 (setf buffer
(sm out-buffer stream
))
624 (setf end
(sm outpos stream
))))
625 (write-octets stream buffer start end blocking
))
627 (defmethod device-write ((stream null-simple-stream
) buffer
629 (declare (ignore buffer blocking
))
632 (defmethod device-write ((stream socket-base-simple-stream
) buffer
638 (defmethod device-clear-output ((stream simple-stream
))
642 (defmethod device-extend ((stream direct-simple-stream
) need action
)
643 (declare (ignore need action
))
646 (defmethod device-extend ((stream string-input-simple-stream
) need action
)
647 (declare (ignore need action
))
650 (defmethod device-extend ((stream string-output-simple-stream
) need action
)
654 (defmethod device-extend ((stream fill-pointer-output-simple-stream
)
659 (defmethod device-extend ((stream mapped-file-simple-stream
) need action
)
660 (declare (ignore need action
))
664 ;; device-finish-record apparently has no methods defined
668 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
669 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
674 ;;; CREATION OF STANDARD STREAMS