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