From c9078c1bae4ee38d5e1433c12ae3128f1bb9bc78 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 18 May 2003 15:49:11 +0000 Subject: [PATCH] 0.8alpha.0.35: Commit patch from Rudi Schlatte for sb-simple-streams contrib ... add TODO ... implement socket streams (using sb-bsd-sockets) ... (frob by CSR: don't fail if we get a connection refused) --- contrib/sb-simple-streams/README | 50 ++++++++----- contrib/sb-simple-streams/TODO | 12 ++++ contrib/sb-simple-streams/cl.lisp | 7 +- contrib/sb-simple-streams/classes.lisp | 3 +- contrib/sb-simple-streams/sb-simple-streams.asd | 18 ++++- contrib/sb-simple-streams/simple-stream-tests.lisp | 74 +++++++++++++------- contrib/sb-simple-streams/simple-streams.lisp | 66 +++++++++++++++-- contrib/sb-simple-streams/strategy.lisp | 28 ++++---- version.lisp-expr | 2 +- 9 files changed, 191 insertions(+), 69 deletions(-) create mode 100644 contrib/sb-simple-streams/TODO diff --git a/contrib/sb-simple-streams/README b/contrib/sb-simple-streams/README index 47f3a28..5e948e3 100644 --- a/contrib/sb-simple-streams/README +++ b/contrib/sb-simple-streams/README @@ -2,17 +2,32 @@ 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 + + + + ================================================== @@ -26,19 +41,20 @@ Motivation: 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 diff --git a/contrib/sb-simple-streams/TODO b/contrib/sb-simple-streams/TODO new file mode 100644 index 0000000..0d4eb4c --- /dev/null +++ b/contrib/sb-simple-streams/TODO @@ -0,0 +1,12 @@ +-*- 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. + diff --git a/contrib/sb-simple-streams/cl.lisp b/contrib/sb-simple-streams/cl.lisp index 9d5114a..1948f18 100644 --- a/contrib/sb-simple-streams/cl.lisp +++ b/contrib/sb-simple-streams/cl.lisp @@ -298,7 +298,7 @@ simple-streams proposal.") (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 @@ -708,6 +708,7 @@ simple-streams proposal.") (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)))) @@ -1002,6 +1003,10 @@ simple-streams proposal.") (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)) diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp index 51d2bd1..c611bff 100644 --- a/contrib/sb-simple-streams/classes.lisp +++ b/contrib/sb-simple-streams/classes.lisp @@ -259,7 +259,8 @@ ()) (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) ()) diff --git a/contrib/sb-simple-streams/sb-simple-streams.asd b/contrib/sb-simple-streams/sb-simple-streams.asd index a652c3b..e22e85b 100644 --- a/contrib/sb-simple-streams/sb-simple-streams.asd +++ b/contrib/sb-simple-streams/sb-simple-streams.asd @@ -7,14 +7,13 @@ (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")) @@ -25,10 +24,23 @@ (: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"))) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 9664814..3d334ee 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -6,27 +6,32 @@ (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 @@ -37,25 +42,36 @@ 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 @@ -71,5 +87,13 @@ 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) diff --git a/contrib/sb-simple-streams/simple-streams.lisp b/contrib/sb-simple-streams/simple-streams.lisp index 1c4e316..e762c9f 100644 --- a/contrib/sb-simple-streams/simple-streams.lisp +++ b/contrib/sb-simple-streams/simple-streams.lisp @@ -184,7 +184,10 @@ (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) @@ -213,12 +216,16 @@ (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)))))) ;;; @@ -238,7 +245,7 @@ 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))) @@ -371,8 +378,44 @@ 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) @@ -428,7 +471,7 @@ )) (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) @@ -449,6 +492,15 @@ (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) diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp index f7e2eb3..600560e 100644 --- a/contrib/sb-simple-streams/strategy.lisp +++ b/contrib/sb-simple-streams/strategy.lisp @@ -14,6 +14,7 @@ (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)) @@ -219,13 +220,12 @@ (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)) @@ -373,13 +373,13 @@ (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)) diff --git a/version.lisp-expr b/version.lisp-expr index 4d38a4c..b1ac9ed 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4