An implementation of simple streams for sbcl.
-Simple streams are an extensible streams protocol, with similar goals
-but different architecture than Gray streams. Documentation about
-simple streams is available at
+Simple streams are an extensible streams protocol that avoids some
+problems with Gray streams.
+
+Documentation about simple streams is available at
http://www.franz.com/support/documentation/6.2/doc/streams.htm
This code was originally written by Paul Foley for cmucl; Paul's
version resides (as of 2003-05-12) at
http://users.actrix.co.nz/mycroft/cl.html
-The port to sbcl was done by Rudi Schlatte (rudi@constantly.at). Bug
-reports welcome.
+The port to sbcl was done by Rudi Schlatte (rudi@constantly.at).
+
+This implementation should be considered Alpha-quality; the basic
+framework is there, but many classes are just stubs at the moment.
+See simple-stream-test.lisp for things that should work.
+
+
+
+Known differences to the ACL behaviour:
+
+- open not return a simple-stream by default. This can be
+ adjusted; see default-open-class in the file cl.lisp
+
+
+
+
==================================================
If you want to extend a given Gray stream, is it enough to supply a
method for stream-write-byte, or do you have to overwrite
stream-write-sequence as well? How do you extend your Gray socket
-stream to support chunked stream encoding for HTTP/1.1? Chances are
-that for any seriously interesting stream customization, you will
-implement some kind of buffer, collect data in it and
-
-
+stream to support chunked stream encoding for HTTP/1.1? Is
+stream-read-char-no-hang required to call stream-listen, then
+stream-read-char? Simple-streams solve these protocol problems by
+implementing a device layer following a buffering protocol and a thin
+"strategy" layer that provides the functionality for the normal CL
+stream semantics.
-Simple streams is a layered architecture. The device layer at the
-bottom deals with transferring chunks of bytes between a buffer and a
-device (socket, file, printer, what-have-you). The top layer is the
-familiar CL API (read-line, write-sequence, open, etc). The strategy
-layer in the middle translates between the buffer-of-bytes and CL
-stream world-view, dealing with byte<->character conversion,
-line-ending and stream-external-format conventions, etc.
+The device layer at the bottom deals with transferring chunks of bytes
+between a buffer and a device (socket, file, printer, what-have-you).
+The top layer is the familiar CL API (read-line, write-sequence, open,
+etc). The strategy layer in the middle translates between the
+buffer-of-bytes and CL stream world-view, dealing with
+byte<->character conversion, line-ending and stream-external-format
+conventions, etc.
Implementing a new type of stream is a matter of extending the right
stream class and implementing device-read, device-write, device-extend
--- /dev/null
+-*- text -*-
+
+- Writing beyond the end of a mapped-simple-stream is funky; arguably,
+ it should signal an error.
+
+- write-octets / read-octets handling of encapsulated streams is
+ untested.
+
+- Implement socket-base-simple-stream and chunked transfer encoding.
+
+- Implement string streams.
+
(error 'type-error :datum filename
:expected-type '(or pathname stream base-string)))
(cond ((eql klass 'sb-sys::file-stream)
- (remf options :claass)
+ (remf options :class)
(remf options :mapped)
;; INPUT-HANDLE and OUTPUT-HANDLE must be fixnums or NIL.
;; If both are given, they must be the same -- or maybe
(setf (bref (sm out-buffer stream) ptr) integer)))
(t ;; single-channel-simple-stream
(let ((ptr (sm buffpos stream)))
+ ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
(when (>= ptr (sm buffer-ptr stream))
(sc-flush-buffer stream t)
(setf ptr (1- (sm buffpos stream))))
(unless (device-open instance initargs)
(device-close instance t)))
+;;; From the simple-streams documentation: "A generic function implies
+;;; a specialization capability that does not exist for
+;;; simple-streams; simple-stream specializations should be on
+;;; device-close." So don't do it.
(defmethod close ((stream simple-stream) &key abort)
(device-close stream abort))
())
(def-stream-class socket-simple-stream (dual-channel-simple-stream)
- ())
+ ((socket :initform nil :type (or sb-bsd-sockets:socket null)
+ :initarg :socket sb-pcl::location 27)))
(def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
())
(defsystem sb-simple-streams
- :depends-on (sb-rt sb-grovel)
+ :depends-on (sb-grovel sb-bsd-sockets)
:components ((:file "package")
(:file "fndb")
(grovel-constants-file "constants"
:package :sb-simple-streams
:pathname "constants.lisp"
:depends-on ("package"))
- ;; (:file "stuff_grovelled_from_headers")
(:file "unix" :depends-on ("constants"))
;;(:file "pcl")
;;(:file "ext-format" :depends-on ("package"))
(:file "simple-streams" :depends-on ("cl" "strategy" "unix"))
;;(:file "gray-compat" :depends-on ("package"))
;;(:file "iodefs" :depends-on ("package"))
- (:file "simple-stream-tests" :depends-on ("simple-streams"))
))
+(defmethod perform :after ((o load-op)
+ (c (eql (find-system :sb-simple-streams))))
+ (provide 'sb-simple-streams))
+
(defmethod perform ((o test-op) (c (eql (find-system :sb-simple-streams))))
+ (operate 'load-op 'sb-simple-streams-tests)
+ (operate 'test-op 'sb-simple-streams-tests))
+
+
+(defsystem sb-simple-streams-tests
+ :depends-on (sb-rt sb-simple-streams)
+ :components ((:file "simple-stream-tests")))
+
+(defmethod perform ((o test-op)
+ (c (eql (find-system :sb-simple-streams-tests))))
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "test-op failed")))
(in-package #:sb-simple-streams-test)
-(defparameter *dumb-string* "This file created by simple-stream-tests.lisp. Nothing to see here, move along.")
+(defparameter *dumb-string*
+ "This file created by simple-stream-tests.lisp. Nothing to see here, move along.")
-(defparameter *test-path* (merge-pathnames
- (make-pathname :name nil :type nil :version nil)
- *load-truename*))
+(defparameter *test-path*
+ (merge-pathnames (make-pathname :name nil :type nil :version nil)
+ *load-truename*)
+ "Directory for temporary test files.")
(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
+
+
(deftest create-file-1
- (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
- (stream-object (make-instance 'file-simple-stream
- :filename file
- :direction :output
- :if-exists :overwrite)))
+ ;; Create a file-simple-stream, write data.
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
(prog1
- (with-open-stream (s stream-object)
- (string= (write-string *dumb-string* s) *dumb-string*))
+ (with-open-stream (s (make-instance 'file-simple-stream
+ :filename file
+ :direction :output
+ :if-exists :overwrite))
+ (string= (write-string *dumb-string* s) *dumb-string*))
(delete-file file)))
t)
(deftest create-file-2
+ ;; Create a file-simple-stream via :class argument to open, write data.
(let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
(prog1
(with-open-file (s file
t)
(deftest create-read-file-1
+ ;; Via file-simple-stream objects, write and then re-read data.
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
- (let ((stream-object (make-instance 'file-simple-stream
- :filename file
- :direction :output
- :if-exists :overwrite)))
- (with-open-stream (s stream-object)
- (setf result (and result (string= (write-string *dumb-string* s)
- *dumb-string*)))
- (terpri s)))
- (let ((stream-object (make-instance 'file-simple-stream
- :filename file
- :direction :input)))
- (with-open-stream (s stream-object)
- (setf result (and result (string= (read-line s) *dumb-string*)))))
+ (with-open-stream (s (make-instance 'file-simple-stream
+ :filename file
+ :direction :output
+ :if-exists :overwrite))
+ (write-line *dumb-string* s)
+ (setf result (and result (string= (write-string *dumb-string* s)
+ *dumb-string*))))
+ (with-open-stream (s (make-instance 'file-simple-stream
+ :filename file
+ :direction :input
+ :if-does-not-exist :error))
+ ;; Check first line
+ (multiple-value-bind (string missing-newline-p)
+ (read-line s)
+ (setf result (and result (string= string *dumb-string*)
+ (not missing-newline-p))))
+ ;; Check second line
+ (multiple-value-bind (string missing-newline-p)
+ (read-line s)
+ (setf result (and result (string= string *dumb-string*)
+ missing-newline-p))))
+ (delete-file file)
result)
t)
(deftest create-read-mapped-file-1
+ ;; Read data via a mapped-file-simple-stream object.
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
(with-open-file (s file
result)
t)
-
+(deftest write-read-inet
+ (handler-case
+ (with-open-stream (s (make-instance 'socket-simple-stream
+ :remote-host #(127 0 0 1)
+ :remote-port 7))
+ (string= (prog1 (write-line "Got it!" s) (finish-output s))
+ (read-line s)))
+ (sb-bsd-sockets::connection-refused-error () t))
+ t)
(t (return (- -10 errno)))))
((zerop count) (return -1))
(t (return count)))))))))))
- (t (error "implement me"))))))
+ ;; Handle encapsulated stream. FIXME: perhaps handle
+ ;; sbcl-vintage ansi-stream type in read-octets too?
+ (stream (read-octets fd buffer start end blocking))
+ (t (error "Don't know how to handle input handle &A" fd))))))
(defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
(incf count bytes)
(incf start bytes))
(cond ((null bytes)
- (format t "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
+ errno)
(cond ((= errno sb-unix:eintr) (go again))
;; don't block for subsequent chars
(t (return (- -10 errno)))))
(t (return count)))))))))))
- (t (error "implement me"))))))
+ ;; Handle encapsulated stream. FIXME: perhaps handle
+ ;; sbcl-vintage ansi-stream type in write-octets too?
+ (stream (write-octets fd buffer start end blocking))
+ (t (error "Don't know how to handle output handle &A" fd))))))
;;;
stream)
(defun open-file-stream (stream options)
- (let ((filename (getf options :filename))
+ (let ((filename (pathname (getf options :filename)))
(direction (getf options :direction :input))
(if-exists (getf options :if-exists))
(if-exists-given (not (getf options :if-exists t)))
stream)
(defmethod device-open ((stream socket-simple-stream) options)
- #| do something |#
- stream)
+ (with-stream-class (socket-simple-stream stream)
+ (let* ((remote-host (getf options :remote-host))
+ (remote-port (getf options :remote-port))
+ (socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp)))
+ (setf (sm socket stream) socket)
+ (sb-bsd-sockets:socket-connect socket remote-host remote-port)
+ (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
+ ;; Connect stream to socket, ...
+ (setf (sm input-handle stream) fd)
+ (setf (sm output-handle stream) fd)
+ ;; ... and socket to stream.
+ (setf (slot-value socket 'stream) stream)
+ (sb-ext:cancel-finalization socket)
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-unix:unix-close fd)
+ (format *terminal-io*
+ "~&;;; ** closed socket (fd ~D)~%" fd))))
+ ;; Now frob the stream slots.
+ (add-stream-instance-flags stream :simple :input :output :dual)
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ ;; Buffer should be array of (unsigned-byte 8), in general
+ ;; use strings for now so it's easy to read the content...
+ (setf (sm buffer stream) (make-string length)
+ (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm buf-len stream) length)))
+ (unless (sm out-buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm out-buffer stream) (make-string length)
+ (sm max-out-pos stream) length)))
+ (setf (sm control-in stream) *terminal-control-in-table*)
+ (setf (sm control-out stream) *std-control-out-table*)
+ (install-dual-channel-character-strategy
+ stream (getf options :external-format :default)))
+ stream))
(defmethod device-open ((stream terminal-simple-stream) options)
(with-stream-class (terminal-simple-stream stream)
))
(if (sm input-handle stream)
(sb-unix:unix-close (sm input-handle stream))
- (sb-unix:unix-close (sm output-handle stream)))
+ (sb-unix:unix-close (sm output-handle stream)))
(setf (sm buffer stream) nil))
t)
(sb-unix:unix-close (sm input-handle stream)))
t)
+(defmethod device-close ((stream socket-simple-stream) abort)
+ ;; Abort argument is handled by :around method on base class
+ (declare (ignore abort))
+ (with-stream-class (socket-simple-stream stream)
+ (sb-unix:unix-close (sm input-handle stream))
+ (setf (sm buffer stream) nil)
+ (setf (sm out-buffer stream) nil))
+ (sb-ext:cancel-finalization stream)
+ t)
(defmethod device-buffer-length ((stream simple-stream))
4096)
(let* ((unread (sm last-char-read-size stream))
(buffer (sm buffer stream)))
(unless (zerop unread)
+ ;; Keep last read character at beginning of buffer
(buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
(let ((bytes (device-read stream nil unread nil blocking)))
(declare (type fixnum bytes))
(funcall (the (or symbol function) (svref ctrl code))
stream character))
(return-from sc-write-char character))
- (if (< ptr (sm buffer-ptr stream))
- (progn
- (setf (bref buffer ptr) code)
- (setf (sm buffpos stream) (1+ ptr)))
- (progn
- (sc-flush-buffer stream t)
- (setf ptr (sm buffpos stream))))))
+ ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
+ (unless (< ptr (sm buffer-ptr stream))
+ (sc-flush-buffer stream t)
+ (setf ptr (sm buffpos stream)))
+ (setf (bref buffer ptr) code)
+ (setf (sm buffpos stream) (1+ ptr))))
character)
(declaim (ftype j-write-chars-fn sc-write-chars))
(funcall (the (or symbol function) (svref ctrl code))
stream character))
(return-from dc-write-char character))
- (if (< ptr (sm max-out-pos stream))
- (progn
- (setf (bref buffer ptr) code)
- (setf (sm outpos stream) (1+ ptr)))
- (progn
- (dc-flush-buffer stream t)
- (setf ptr (sm outpos stream))))))
+ (unless (< ptr (sm max-out-pos stream))
+ (dc-flush-buffer stream t)
+ (setf ptr (sm outpos stream)))
+ (progn
+ (setf (bref buffer ptr) code)
+ (setf (sm outpos stream) (1+ ptr))
+ )))
character)
(declaim (ftype j-write-chars-fn dc-write-chars))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8alpha.0.34"
+"0.8alpha.0.35"
projects / sbcl.git / commitdiff