From f2ba44b90ac97e6b4dfb4eca414241147a2844b8 Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Thu, 15 Jan 2009 02:58:45 +0100 Subject: [PATCH] Add memory streams. --- io.streams/zeta/buffer.lisp | 487 ++++++++++++++++++++++---------- io.streams/zeta/conditions.lisp | 14 +- io.streams/zeta/device.lisp | 38 ++- io.streams/zeta/ffi-functions-unix.lisp | 6 +- io.streams/zeta/file-unix.lisp | 51 ++-- io.streams/zeta/stream.lisp | 75 ++--- 6 files changed, 451 insertions(+), 220 deletions(-) diff --git a/io.streams/zeta/buffer.lisp b/io.streams/zeta/buffer.lisp index 46ad823..8e2792a 100644 --- a/io.streams/zeta/buffer.lisp +++ b/io.streams/zeta/buffer.lisp @@ -10,52 +10,117 @@ ;;;------------------------------------------------------------------------- (defclass buffer () + ()) + +(defclass device-buffer (buffer) ((synchronized :initarg :synchronized - :reader synchronizedp) + :reader %db-synchronized-p) (device :initform nil :initarg :device - :accessor device-of) + :accessor %db-device) (input-iobuf :initarg :input-buffer - :accessor input-iobuf-of) + :accessor %db-input-iobuf) (output-iobuf :initarg :output-buffer - :accessor output-iobuf-of) + :accessor %db-output-iobuf) (buffering :initarg :buffering - :accessor buffering-of)) + :accessor %db-buffering)) (:default-initargs :synchronized nil)) -(defclass single-channel-buffer (buffer) - ((last-io-op :initform nil :accessor last-io-op-of))) - -(defclass dual-channel-buffer (buffer) ()) +(defclass single-channel-buffer (device-buffer) + ((dirtyp :initform nil + :accessor %scb-dirtyp))) + +(defclass dual-channel-buffer (device-buffer) + ()) + +(defclass memory-buffer (buffer) + ((data-vector :initarg :data + :accessor %mb-data-vector) + (input-position :initform 0 + :accessor %mb-input-position) + (output-position :initform 0 + :accessor %mb-output-position) + (adjust-size :initarg :adjust-size + :accessor %mb-adjust-size) + (adjust-threshold :initarg :adjust-threshold + :accessor %mb-adjust-threshold))) ;;;------------------------------------------------------------------------- ;;; Generic Functions ;;;------------------------------------------------------------------------- -(defgeneric buffer-fill (buffer &key timeout)) +;;; Accessors + +(defgeneric zstream-synchronized-p (buffer)) + +(defgeneric zstream-device (buffer)) + +(defgeneric (setf zstream-device) (new-device buffer)) + +;;; I/O functions + +(defgeneric zstream-read-octet (buffer &key timeout)) + +(defgeneric zstream-write-octet (buffer byte &key timeout)) + +(defgeneric zstream-read-vector (buffer vector &key start end timeout)) + +(defgeneric zstream-write-vector (buffer vector &key start end timeout)) -(defgeneric buffer-flush (buffer &key timeout)) +;;; Device buffer functions -(defgeneric buffer-wait-until-flushable (buffer &key timeout)) +(defgeneric zstream-io-position (buffer)) -(defgeneric buffer-clear-input (buffer)) +(defgeneric (setf zstream-io-position) (position buffer &optional from)) -(defgeneric buffer-clear-output (buffer)) +(defgeneric zstream-input-position (buffer)) + +(defgeneric (setf zstream-input-position) (position buffer &optional from)) + +(defgeneric zstream-output-position (buffer)) + +(defgeneric (setf zstream-output-position) (position buffer &optional from)) + +(defgeneric zstream-poll (buffer &key direction timeout)) + +(defgeneric zstream-fill-input (buffer &key timeout)) + +(defgeneric zstream-flush-output (buffer &key timeout)) + +(defgeneric zstream-clear-input (buffer)) + +(defgeneric zstream-clear-output (buffer)) ;;; Internal functions -(defgeneric %buffer-read-vector (buffer vector start end timeout)) +(defgeneric %zstream-read-vector (buffer vector start end timeout)) + +(defgeneric %zstream-write-vector (buffer vector start end timeout)) -(defgeneric %buffer-write-vector (buffer vector start end timeout)) +(defgeneric %zstream-fill-input (buffer timeout)) -(defgeneric %buffer-fill (buffer timeout)) +(defgeneric %zstream-flush-output (buffer timeout)) -(defgeneric %buffer-flush (buffer timeout)) +(defgeneric %zstream-clear-input (buffer)) -(defgeneric %buffer-clear-input (buffer)) +(defgeneric %zstream-clear-output (buffer)) -(defgeneric %buffer-clear-output (buffer)) +(defgeneric %ensure-memory-buffer-capacity (buffer amount)) + + +;;;------------------------------------------------------------------------- +;;; Accessors +;;;------------------------------------------------------------------------- + +(defmethod zstream-synchronized-p ((buffer device-buffer)) + (%db-synchronized-p buffer)) + +(defmethod zstream-device ((buffer device-buffer)) + (%db-device buffer)) + +(defmethod (setf zstream-device) (new-device (buffer device-buffer)) + (setf (%db-device buffer) new-device)) ;;;------------------------------------------------------------------------- @@ -68,16 +133,16 @@ (ecase direction (:input `(bt:with-lock-held - ((iobuf-lock (input-iobuf-of ,buffer))) + ((iobuf-lock (%db-input-iobuf ,buffer))) ,body)) (:output `(bt:with-lock-held - ((iobuf-lock (output-iobuf-of ,buffer))) + ((iobuf-lock (%db-output-iobuf ,buffer))) ,body)) (:io (make-locks (make-locks body :output) :input))))) `(flet ((,body-fun () ,@body)) - (if (synchronizedp ,buffer) + (if (zstream-synchronized-p ,buffer) ,(make-locks `(,body-fun) direction) (,body-fun)))))) @@ -90,9 +155,9 @@ ((buffer single-channel-buffer) slot-names &key data size buffering) (declare (ignore slot-names)) - (with-accessors ((device device-of) - (input-iobuf input-iobuf-of) - (output-iobuf output-iobuf-of)) + (with-accessors ((device zstream-device) + (input-iobuf %db-input-iobuf) + (output-iobuf %db-output-iobuf)) buffer (check-type device device) (check-type data (or null iobuf)) @@ -104,9 +169,9 @@ ((buffer dual-channel-buffer) slot-names &key input-data output-data input-size output-size buffering) (declare (ignore slot-names)) - (with-accessors ((device device-of) - (input-iobuf input-iobuf-of) - (output-iobuf output-iobuf-of)) + (with-accessors ((device zstream-device) + (input-iobuf %db-input-iobuf) + (output-iobuf %db-output-iobuf)) buffer (check-type device device) (check-type input-data (or null iobuf)) @@ -114,6 +179,30 @@ (check-type buffering stream-buffering) (setf input-iobuf (or input-data (make-iobuf input-size))) (setf output-iobuf (or output-data (make-iobuf output-size))))) + +(defmethod shared-initialize :after + ((buffer memory-buffer) slot-names + &key data (start 0) end element-type + (adjust-size 1.5) (adjust-threshold 1)) + (declare (ignore slot-names)) + ;; FIXME: signal proper condition + (assert (> adjust-size 1)) + (assert (<= adjust-threshold 1)) + (cond + (data + (check-bounds data start end) + (when element-type + ;; FIXME: signal proper condition + (assert (subtypep element-type (array-element-type data)))) + (setf (%mb-data-vector buffer) + (make-array (truncate (* adjust-size (length data))) + :element-type (or element-type + (array-element-type data)))) + (setf (%mb-output-position buffer) (- end start)) + (replace (%mb-data-vector buffer) data :start2 start :end2 end)) + (t + (setf (%mb-data-vector buffer) + (make-array 128 :element-type element-type))))) ;;;------------------------------------------------------------------------- @@ -121,53 +210,57 @@ ;;;------------------------------------------------------------------------- (defmethod relinquish ((buffer single-channel-buffer) &key abort) - (with-accessors ((device device-of)) - buffer - (with-synchronized-buffer (buffer :input) - (unless (or abort (eql :read (last-io-op-of buffer))) - (%buffer-flush buffer 0)) - (relinquish device :abort abort))) + (with-synchronized-buffer (buffer :input) + (unless abort + (%zstream-flush-output buffer 0)) + (relinquish (zstream-device buffer) :abort abort)) (values buffer)) (defmethod relinquish ((buffer dual-channel-buffer) &key abort) - (with-accessors ((device device-of)) - buffer - (with-synchronized-buffer (buffer :io) - (unless abort - (%buffer-flush buffer 0)) - (relinquish device :abort abort))) + (with-synchronized-buffer (buffer :io) + (unless abort + (%zstream-flush-output buffer 0)) + (relinquish (zstream-device buffer) :abort abort)) (values buffer)) ;;;------------------------------------------------------------------------- -;;; DEVICE-READ +;;; READ-OCTET +;;;------------------------------------------------------------------------- + +(defmethod zstream-read-octet ((buffer buffer) &key timeout) + (let ((v (make-array 1 :element-type 'ub8))) + (declare (dynamic-extent v)) + (zstream-read-vector buffer v :timeout timeout) + (aref v 0))) + + +;;;------------------------------------------------------------------------- +;;; READ-VECTOR ;;;------------------------------------------------------------------------- -(defmethod device-read :around ((buffer buffer) vector &key - (start 0) end timeout) +(defmethod zstream-read-vector :around ((buffer buffer) vector &key + (start 0) end timeout) (check-bounds vector start end) - (if (= start end) - 0 - (call-next-method buffer vector :start start - :end end :timeout timeout))) + (when (= start end) (return* 0)) + (call-next-method buffer vector :start start :end end :timeout timeout)) -(defmethod device-read ((buffer single-channel-buffer) vector - &key start end timeout) +(defmethod zstream-read-vector ((buffer single-channel-buffer) vector + &key start end timeout) (with-synchronized-buffer (buffer :input) - (%buffer-read-vector buffer vector start end timeout))) + (%zstream-read-vector buffer vector start end timeout))) -(defmethod device-read ((buffer dual-channel-buffer) vector - &key start end timeout) +(defmethod zstream-read-vector ((buffer dual-channel-buffer) vector + &key start end timeout) (with-synchronized-buffer (buffer :input) - (%buffer-read-vector buffer vector start end timeout))) + (%zstream-read-vector buffer vector start end timeout))) -(defmethod %buffer-read-vector ((buffer buffer) vector start end timeout) - (with-accessors ((input-iobuf input-iobuf-of) - (output-iobuf output-iobuf-of)) +(defmethod %zstream-read-vector ((buffer device-buffer) vector start end timeout) + (with-accessors ((input-iobuf %db-input-iobuf)) buffer (cond ((iobuf-empty-p input-iobuf) - (let ((nbytes (%buffer-fill buffer timeout))) + (let ((nbytes (%zstream-fill-input buffer timeout))) (if (iobuf-empty-p input-iobuf) (if (eql :eof nbytes) :eof 0) (iobuf->vector input-iobuf vector start end)))) @@ -176,122 +269,212 @@ ;;;------------------------------------------------------------------------- -;;; DEVICE-WRITE +;;; WRITE-OCTET ;;;------------------------------------------------------------------------- -(defmethod device-write :around ((buffer buffer) vector - &key (start 0) end timeout) +(defmethod zstream-write-octet ((buffer buffer) octet &key timeout) + (check-type octet (unsigned-byte 8)) + (let ((v (make-array 1 :element-type 'ub8 :initial-contents octet))) + (declare (dynamic-extent v)) + (zstream-write-vector buffer v :timeout timeout))) + + +;;;------------------------------------------------------------------------- +;;; WRITE-VECTOR +;;;------------------------------------------------------------------------- + +(defmethod zstream-write-vector :around ((buffer buffer) vector + &key (start 0) end timeout) (check-bounds vector start end) - (if (= start end) - 0 - (call-next-method buffer vector :start start - :end end :timeout timeout))) + (when (= start end) (return* 0)) + (call-next-method buffer vector :start start :end end :timeout timeout)) -(defmethod device-write ((buffer single-channel-buffer) vector - &key start end timeout) +(defmethod zstream-write-vector ((buffer single-channel-buffer) vector + &key start end timeout) (with-synchronized-buffer (buffer :output) ;; If the previous operation was a read, flush the read buffer ;; and reposition the file offset accordingly - (%buffer-clear-input buffer) - (%buffer-write-vector buffer vector start end timeout))) + (%zstream-clear-input buffer) + (%zstream-write-vector buffer vector start end timeout))) -(defmethod device-write ((buffer dual-channel-buffer) vector - &key start end timeout) +(defmethod zstream-write-vector ((buffer dual-channel-buffer) vector + &key start end timeout) (with-synchronized-buffer (buffer :output) - (%buffer-write-vector buffer vector start end timeout))) + (%zstream-write-vector buffer vector start end timeout))) -(defmethod %buffer-write-vector ((buffer buffer) vector start end timeout) - (with-accessors ((output-iobuf output-iobuf-of)) +(defmethod %zstream-write-vector ((buffer device-buffer) vector start end timeout) + (with-accessors ((output-iobuf %db-output-iobuf)) buffer (multiple-value-prog1 (vector->iobuf output-iobuf vector start end) - (setf (last-io-op-of buffer) :write) (when (iobuf-full-p output-iobuf) - (%buffer-flush buffer timeout))))) + (%zstream-flush-output buffer timeout))))) + +(defmethod %zstream-write-vector :after ((buffer single-channel-buffer) + vector start end timeout) + (setf (%scb-dirtyp buffer) t)) + +(defmethod zstream-write-vector ((buffer memory-buffer) vector + &key (start 0) end timeout) + (declare (ignore timeout)) + (check-bounds vector start end) + (with-accessors ((data-vector %mb-data-vector) + (output-position %mb-output-position)) + buffer + (%ensure-memory-buffer-capacity buffer (length vector)) + (replace data-vector vector :start1 output-position + :start2 start :end2 end) + (incf output-position (length vector)))) ;;;------------------------------------------------------------------------- -;;; DEVICE-POSITION +;;; IO-POSITION ;;;------------------------------------------------------------------------- -(defmethod device-position ((buffer single-channel-buffer)) +(defmethod zstream-io-position ((buffer single-channel-buffer)) (with-synchronized-buffer (buffer :input) - (%buffer-position buffer))) - -(defun %buffer-position (buffer) - (let ((position (device-position (device-of buffer)))) - (assert (not (null position)) (position) - "A single-channel-buffer's device must not return a NULL device-position.") - (ecase (last-io-op-of buffer) - (:read - (- position (iobuf-available-octets (input-iobuf-of buffer)))) - (:write - (+ position (iobuf-available-octets (output-iobuf-of buffer))))))) - -(defmethod (setf device-position) + (let ((position (device-position (zstream-device buffer)))) + ;; FIXME: signal proper condition + (assert (not (null position)) (position) + "A single-channel-buffer's device must not return a NULL device-position.") + (if (%scb-dirtyp buffer) + (+ position (iobuf-available-octets (%db-output-iobuf buffer))) + (- position (iobuf-available-octets (%db-input-iobuf buffer))))))) + +(defmethod zstream-io-position ((buffer dual-channel-buffer)) + (device-position (zstream-device buffer))) + +(defmethod zstream-io-position ((buffer memory-buffer)) + (declare (ignore buffer)) + ;; FIXME: signal an error because it has two cursors ? + nil) + +(defmethod (setf zstream-io-position) (position (buffer single-channel-buffer) &optional (from :start)) - (setf (%buffer-position buffer from) position)) + (setf (device-position (zstream-device buffer) from) position)) + +(defmethod (setf zstream-io-position) + (position (buffer dual-channel-buffer) &optional (from :start)) + (setf (device-position (zstream-device buffer) from) position)) + +(defmethod (setf zstream-io-position) + (position (buffer dual-channel-buffer) &optional (from :start)) + (declare (ignore position buffer from)) + ;; FIXME: signal an error because it has two cursors ? + nil) + + +;;;------------------------------------------------------------------------- +;;; INPUT-POSITION +;;;------------------------------------------------------------------------- + +(defmethod zstream-input-position ((buffer memory-buffer)) + (%mb-input-position buffer)) -(defun (setf %buffer-position) (position buffer from) - (setf (device-position (device-of buffer) from) position)) +(defmethod (setf zstream-input-position) + (offset (buffer memory-buffer) &optional (from :start)) + (with-accessors ((data-vector %mb-data-vector) + (input-position %mb-input-position) + (output-position %mb-output-position)) + buffer + (let ((len (length data-vector)) + (newpos + (ecase from + (:start offset) + (:current (+ input-position offset)) + (:output (+ output-position offset))))) + ;; FIXME: signal proper condition + (assert (< output-position len)) + (unless (and (<= newpos output-position)) + ;; FIXME: signal proper condition + (error "Wrong sequence bounds. start: ~S end: ~S" + newpos output-position)) + (setf input-position newpos)))) + + +;;;------------------------------------------------------------------------- +;;; OUTPUT-POSITION +;;;------------------------------------------------------------------------- + +(defmethod zstream-output-position ((buffer memory-buffer)) + (%mb-output-position buffer)) + +(defmethod (setf zstream-output-position) + (offset (buffer memory-buffer) &optional (from :start)) + (with-accessors ((data-vector %mb-data-vector) + (input-position %mb-input-position) + (output-position %mb-output-position) + (adjust-size %mb-adjust-size)) + buffer + (let ((newpos + (ecase from + (:start offset) + (:current (+ output-position offset)) + (:input (+ input-position offset))))) + (unless (<= input-position newpos) + ;; FIXME: signal proper condition + (error "Wrong sequence bounds. start: ~S end: ~S" + input-position newpos)) + (%ensure-memory-buffer-capacity buffer (- newpos output-position)) + (setf output-position newpos)))) ;;;------------------------------------------------------------------------- ;;; CLEAR-INPUT ;;;------------------------------------------------------------------------- -(defmethod buffer-clear-input ((buffer single-channel-buffer)) +(defmethod zstream-clear-input ((buffer single-channel-buffer)) (with-synchronized-buffer (buffer :input) - (%buffer-clear-input buffer))) + (%zstream-clear-input buffer))) -(defmethod %buffer-clear-input ((buffer single-channel-buffer)) - (when (eql :read (last-io-op-of buffer)) - (let ((nbytes (iobuf-available-octets (input-iobuf-of buffer)))) +(defmethod %zstream-clear-input ((buffer single-channel-buffer)) + (unless (%scb-dirtyp buffer) + (let ((nbytes (iobuf-available-octets (%db-input-iobuf buffer)))) (unless (zerop nbytes) (setf (%buffer-position buffer :current) (- nbytes))) - (iobuf-reset (input-iobuf-of buffer))))) + (iobuf-reset (%db-input-iobuf buffer))))) -(defmethod buffer-clear-input ((buffer buffer)) +(defmethod zstream-clear-input ((buffer buffer)) (with-synchronized-buffer (buffer :input) - (%buffer-clear-input buffer))) + (%zstream-clear-input buffer))) -(defmethod %buffer-clear-input ((buffer dual-channel-buffer)) - (iobuf-reset (input-iobuf-of buffer))) +(defmethod %zstream-clear-input ((buffer dual-channel-buffer)) + (iobuf-reset (%db-input-iobuf buffer))) ;;;------------------------------------------------------------------------- ;;; CLEAR-OUTPUT ;;;------------------------------------------------------------------------- -(defmethod buffer-clear-output ((buffer single-channel-buffer)) +(defmethod zstream-clear-output ((buffer single-channel-buffer)) (with-synchronized-buffer (buffer :output) - (%buffer-clear-output buffer))) + (%zstream-clear-output buffer))) -(defmethod %buffer-clear-output ((buffer single-channel-buffer)) - (when (eql :write (last-io-op-of buffer)) - (iobuf-reset (output-iobuf-of buffer)))) +(defmethod %zstream-clear-output ((buffer single-channel-buffer)) + (when (%scb-dirtyp buffer) + (iobuf-reset (%db-output-iobuf buffer)))) -(defmethod buffer-clear-output ((buffer dual-channel-buffer)) +(defmethod zstream-clear-output ((buffer dual-channel-buffer)) (with-synchronized-buffer (buffer :output) - (iobuf-reset (output-iobuf-of buffer)))) + (iobuf-reset (%db-output-iobuf buffer)))) ;;;------------------------------------------------------------------------- ;;; FILL-INPUT ;;;------------------------------------------------------------------------- -(defmethod buffer-fill ((buffer single-channel-buffer) &key timeout) +(defmethod zstream-fill-input ((buffer single-channel-buffer) &key timeout) (with-synchronized-buffer (buffer :input) - (%buffer-clear-output buffer) - (%buffer-fill buffer timeout))) + (%zstream-flush-output buffer) + (%zstream-fill-input buffer timeout))) -(defmethod buffer-fill ((buffer dual-channel-buffer) &key timeout) +(defmethod zstream-fill-input ((buffer dual-channel-buffer) &key timeout) (with-synchronized-buffer (buffer :input) - (%buffer-fill buffer timeout))) + (%zstream-fill-input buffer timeout))) -(defmethod %buffer-fill ((buffer buffer) timeout) - (with-accessors ((device device-of) - (input-iobuf input-iobuf-of)) +(defmethod %zstream-fill-input ((buffer buffer) timeout) + (with-accessors ((device zstream-device) + (input-iobuf %db-input-iobuf)) buffer (multiple-value-bind (data start end) (iobuf-next-empty-zone input-iobuf) @@ -303,7 +486,6 @@ (error 'end-of-file :stream buffer)) (unsigned-byte (setf (iobuf-end input-iobuf) (+ start nbytes)) - (setf (last-io-op-of buffer) :read) (values nbytes (iobuf-available-space input-iobuf)))))))) @@ -311,36 +493,55 @@ ;;; FLUSH-OUTPUT ;;;------------------------------------------------------------------------- -(defmethod buffer-flush ((buffer single-channel-buffer) &key timeout) +(defmethod zstream-flush-output ((buffer device-buffer) &key timeout) (with-synchronized-buffer (buffer :output) - (when (eql :write (last-io-op-of buffer)) - (%buffer-flush buffer timeout)))) + (%zstream-flush-output buffer timeout))) -(defmethod buffer-flush ((buffer dual-channel-buffer) &key timeout) - (with-synchronized-buffer (buffer :output) - (%buffer-flush buffer timeout))) +(defmethod %zstream-flush-output ((buffer buffer) timeout) + (with-accessors ((device zstream-device) + (output-iobuf %db-output-iobuf)) + buffer + (when (%scb-dirtyp buffer) + (multiple-value-bind (data start end) + (iobuf-next-data-zone output-iobuf) + (let ((nbytes + (device-write device data :start start + :end end :timeout timeout))) + (etypecase nbytes + ((eql :hangup) + (error 'hangup :stream buffer)) + (unsigned-byte + (setf (iobuf-start output-iobuf) (+ start nbytes)) + (values nbytes (iobuf-available-octets output-iobuf))))))))) + +(defmethod %zstream-flush-output :after ((buffer single-channel-buffer) timeout) + (declare (ignore timeout)) + (when (iobuf-empty-p (%db-output-iobuf buffer)) + (setf (%scb-dirtyp buffer) nil))) + + +;;;------------------------------------------------------------------------- +;;; MEMORY-BUFFER GROW +;;;------------------------------------------------------------------------- -(defmethod %buffer-flush ((buffer buffer) timeout) - (with-accessors ((device device-of) - (output-iobuf output-iobuf-of)) +(defmethod %ensure-memory-buffer-capacity ((buffer memory-buffer) amount) + (check-type amount unsigned-byte) + (with-accessors ((data-vector %mb-data-vector) + (output-position %mb-output-position) + (adjust-size %mb-adjust-size) + (adjust-threshold %mb-adjust-threshold)) buffer - (multiple-value-bind (data start end) - (iobuf-next-data-zone output-iobuf) - (let ((nbytes - (device-write device data :start start - :end end :timeout timeout))) - (etypecase nbytes - ((eql :hangup) - (error 'hangup :stream buffer)) - (unsigned-byte - (setf (iobuf-start output-iobuf) (+ start nbytes)) - (setf (last-io-op-of buffer) :write) - (values nbytes (iobuf-available-octets output-iobuf)))))))) + (let* ((size-needed (+ output-position amount)) + (threshold (* adjust-threshold size-needed))) + (when (>= threshold (length data-vector)) + (setf data-vector + (adjust-array data-vector (truncate (* adjust-size + size-needed)))))))) ;;;------------------------------------------------------------------------- ;;; I/O WAIT ;;;------------------------------------------------------------------------- -(defmethod buffer-wait-until-flushable ((buffer buffer) &key timeout) - (device-poll-output (device-of buffer) :timeout timeout)) +(defmethod zstream-poll ((buffer buffer) &key direction timeout) + (device-poll (zstream-device buffer) direction timeout)) diff --git a/io.streams/zeta/conditions.lisp b/io.streams/zeta/conditions.lisp index dd33cf3..bca9fe1 100644 --- a/io.streams/zeta/conditions.lisp +++ b/io.streams/zeta/conditions.lisp @@ -6,19 +6,19 @@ (in-package :io.zeta-streams) (define-condition posix-file-error (file-error) - ((action :initarg :action :reader action-of) - (code :initarg :code :reader code-of) - (identifier :initarg :identifier :reader identifier-of)) + ((action :initarg :action :reader posix-file-error-action) + (code :initarg :code :reader posix-file-error-code) + (identifier :initarg :identifier :reader posix-file-error-identifier)) (:report (lambda (condition stream) (format stream "Error while ~A ~S: ~A" - (action-of condition) + (posix-file-error-action condition) (file-error-pathname condition) - (%sys-strerror (code-of condition)))))) + (%sys-strerror (posix-file-error-code condition)))))) (defun posix-file-error (posix-error filename action) (error 'posix-file-error - :code (code-of posix-error) - :identifier (identifier-of posix-error) + :code (posix-file-error-code posix-error) + :identifier (posix-file-error-identifier posix-error) :pathname filename :action action)) (define-condition hangup (stream-error) () diff --git a/io.streams/zeta/device.lisp b/io.streams/zeta/device.lisp index 045dcff..a01bdeb 100644 --- a/io.streams/zeta/device.lisp +++ b/io.streams/zeta/device.lisp @@ -10,10 +10,14 @@ ;;;------------------------------------------------------------------------- (defclass device () - ((handle :initarg :handle :accessor handle-of) - (readable :initarg :readable :accessor device-readablep) - (writeable :initarg :writeable :accessor device-writeablep) - (seekable :initarg :seekable :accessor device-seekablep))) + ((handle :initarg :handle + :accessor device-handle) + (readable :initarg :readable + :accessor device-readablep) + (writeable :initarg :writeable + :accessor device-writeablep) + (seekable :initarg :seekable + :accessor device-seekablep))) (defclass direct-device (device) ()) @@ -41,9 +45,9 @@ (defgeneric device-length (device)) -(defgeneric device-poll-input (device &key timeout)) +(defgeneric (setf device-length) (length device)) -(defgeneric device-poll-output (device &key timeout)) +(defgeneric device-poll (device direction &optional timeout)) ;;; Internal functions @@ -73,14 +77,24 @@ ;;;------------------------------------------------------------------------- (defmethod device-position ((device device)) - (values nil)) + (declare (ignore device)) + ;; FIXME: signal proper condition + (error "Device not seekable: ~S" device)) (defmethod (setf device-position) (position (device device) &optional from) (declare (ignore position from)) - (values nil)) + ;; FIXME: signal proper condition + (error "Device not seekable: ~S" device)) (defmethod device-length ((device device)) - (values nil)) + (declare (ignore device)) + ;; FIXME: signal proper condition + (error "Device not seekable: ~S" device)) + +(defmethod (setf device-length) (length (device device)) + (declare (ignore length)) + ;; FIXME: signal proper condition + (error "Device not seekable: ~S" device)) ;;;------------------------------------------------------------------------- @@ -91,8 +105,7 @@ (start 0) end timeout) (check-bounds vector start end) (when (= start end) (return* 0)) - (call-next-method device vector :start start - :end end :timeout timeout)) + (call-next-method device vector :start start :end end :timeout timeout)) (defmethod device-read ((device device) vector &key start end timeout) (if (and timeout (zerop timeout)) @@ -108,8 +121,7 @@ (start 0) end timeout) (check-bounds vector start end) (when (= start end) (return* 0)) - (call-next-method device vector :start start - :end end :timeout timeout)) + (call-next-method device vector :start start :end end :timeout timeout)) (defmethod device-write ((device device) vector &key start end timeout) (if (and timeout (zerop timeout)) diff --git a/io.streams/zeta/ffi-functions-unix.lisp b/io.streams/zeta/ffi-functions-unix.lisp index 063c091..fad3bbb 100644 --- a/io.streams/zeta/ffi-functions-unix.lisp +++ b/io.streams/zeta/ffi-functions-unix.lisp @@ -47,12 +47,12 @@ in seconds. If a timeout occurs `POLL-TIMEOUT' is signaled. Returns two boolean values indicating readability and writeability of `FD'." (flet ((poll-error (posix-err) (error 'poll-error - :code (code-of posix-err) - :identifier (identifier-of posix-err) + :code (posix-file-error-code posix-err) + :identifier (posix-file-error-identifier posix-err) :event-type event-type :os-handle file-descriptor :message (format nil "OS error ~A" - (identifier-of posix-err))))) + (posix-file-error-identifier posix-err))))) (with-foreign-object (pollfd 'pollfd) (%sys-bzero pollfd size-of-pollfd) (with-foreign-slots ((fd events revents) pollfd pollfd) diff --git a/io.streams/zeta/file-unix.lisp b/io.streams/zeta/file-unix.lisp index f976022..a28b121 100644 --- a/io.streams/zeta/file-unix.lisp +++ b/io.streams/zeta/file-unix.lisp @@ -11,13 +11,13 @@ (defclass file-device (device) ((filename :initarg :filename - :accessor filename-of) + :accessor file-device-filename) (flags :initarg flags - :accessor flags-of) + :accessor file-device-flags) (mode :initarg mode - :accessor mode-of) + :accessor file-device-mode) (delete-if-exists :initarg :delete-if-exists - :accessor delete-if-exists-p))) + :accessor file-device-delete-if-exists-p))) (defclass memory-mapped-file-device (file-device direct-device) ()) @@ -32,7 +32,11 @@ (defmethod print-object ((file file-device) stream) (print-unreadable-object (file stream :identity t :type nil) - (format stream "File device for ~S" (filename-of file)))) + (format stream "File device for ~S" (file-device-filename file)))) + +(defmethod print-object ((file file-zeta-stream) stream) + (print-unreadable-object (file stream :identity t :type t) + (format stream "wrapping ~S" (zstream-device file)))) ;;;------------------------------------------------------------------------- @@ -52,7 +56,7 @@ ((device file-device) slot-names &key handle filename flags (mode *default-open-mode*) delete-if-exists) (declare (ignore slot-names)) - (setf (filename-of device) (copy-seq filename)) + (setf (file-device-filename device) (copy-seq filename)) (with-device (device) (device-open device :handle handle :filename filename :flags flags :mode mode :delete-if-exists delete-if-exists))) @@ -82,7 +86,7 @@ (:no-error (fd) fd)))) (let ((fd (or handle (try-open)))) (%set-fd-nonblock fd) - (setf (handle-of device) fd))) + (setf (device-handle device) fd))) (values device)) @@ -92,8 +96,8 @@ (defmethod relinquish ((device file-device) &key abort) (declare (ignore abort)) - (%sys-close (handle-of device)) - (setf (handle-of device) nil) + (%sys-close (device-handle device)) + (setf (device-handle device) nil) (values device)) @@ -103,14 +107,14 @@ (defmethod device-position ((device file-device)) (handler-case - (%sys-lseek (handle-of device) 0 seek-cur) + (%sys-lseek (device-handle device) 0 seek-cur) (posix-error (err) (posix-file-error err device "seeking on")))) (defmethod (setf device-position) (position (device file-device) &optional (from :start)) (handler-case - (%sys-lseek (handle-of device) position + (%sys-lseek (device-handle device) position (ecase from (:start seek-set) (:current seek-cur) @@ -125,20 +129,23 @@ (defmethod device-length ((device file-device)) (handler-case - (%sys-fstat (handle-of device)) + (%sys-fstat (device-handle device)) (posix-error (err) (posix-file-error err device "getting status of")))) + +(defmethod (setf device-length) (length (device file-device)) + (handler-case + (%sys-ftruncate (device-handle device) length) + (posix-error (err) + (posix-file-error err device "truncating")))) ;;;------------------------------------------------------------------------- ;;; I/O WAIT ;;;------------------------------------------------------------------------- -(defmethod device-poll-input ((device file-device) &key timeout) - (poll-fd (handle-of device) :input timeout)) - -(defmethod device-poll-output ((device file-device) &key timeout) - (poll-fd (handle-of device) :output timeout)) +(defmethod device-poll ((device file-device) direction &optional timeout) + (poll-fd (device-handle device) direction timeout)) ;;;------------------------------------------------------------------------- @@ -147,12 +154,12 @@ (defmethod device-read/non-blocking ((device file-device) vector start end) (with-device (device) - (%read-octets/non-blocking (handle-of device) vector start end))) + (%read-octets/non-blocking (device-handle device) vector start end))) (defmethod device-read/timeout ((device file-device) vector start end timeout) (with-device (device) - (%read-octets/timeout (handle-of device) vector start end timeout))) + (%read-octets/timeout (device-handle device) vector start end timeout))) ;;;------------------------------------------------------------------------- @@ -161,12 +168,12 @@ (defmethod device-write/non-blocking ((device file-device) vector start end) (with-device (device) - (%write-octets/non-blocking (handle-of device) vector start end))) + (%write-octets/non-blocking (device-handle device) vector start end))) (defmethod device-write/timeout ((device file-device) vector start end timeout) (with-device (device) - (%write-octets/timeout (handle-of device) vector start end timeout))) + (%write-octets/timeout (device-handle device) vector start end timeout))) ;;;------------------------------------------------------------------------- @@ -216,7 +223,7 @@ :mode mode :delete-if-exists (eql :delete if-exists)) (posix-file-error (error) - (case (identifier-of error) + (case (posix-file-error-identifier error) (:enoent (if (null if-does-not-exist) nil (error error))) (:eexist diff --git a/io.streams/zeta/stream.lisp b/io.streams/zeta/stream.lisp index ab25b9d..7e923c7 100644 --- a/io.streams/zeta/stream.lisp +++ b/io.streams/zeta/stream.lisp @@ -9,13 +9,19 @@ ;;; Classes and Types ;;;------------------------------------------------------------------------- -(defclass zeta-stream () - ((external-format :reader external-format-of))) +(defclass zstream () + ((external-format :reader zstream-external-format))) -(defclass single-channel-zeta-stream (single-channel-buffer zeta-stream) +(defclass device-zstream (device-buffer zstream) ()) -(defclass dual-channel-zeta-stream (dual-channel-buffer zeta-stream) +(defclass single-channel-zstream (single-channel-buffer device-zstream) + ()) + +(defclass dual-channel-zstream (dual-channel-buffer device-zstream) + ()) + +(defclass memory-zstream (memory-buffer zstream) ()) @@ -23,19 +29,29 @@ ;;; Generic Functions ;;;------------------------------------------------------------------------- -(defgeneric (setf external-format-of) (external-format stream)) +(defgeneric (setf zstream-external-format) (external-format stream)) + + +(defgeneric zstream-read-char (stream &key eof-error-p eof-value)) + +(defgeneric zstream-write-char (stream char &key hangup-error-p hangup-value)) + +(defgeneric zstream-read-string (stream string &key start end eof-error-p eof-value)) + +(defgeneric zstream-write-string (stream string &key start end hangup-error-p hangup-value)) -(defgeneric zstream-read-vector (stream sequence &key start end)) -(defgeneric zstream-write-vector (stream sequence &key start end)) +(defgeneric zstream-read-line (stream &key eof-error-p eof-value)) + +(defgeneric zstream-write-line (stream line &key start end hangup-error-p hangup-value)) ;;;------------------------------------------------------------------------- ;;; Accessors ;;;------------------------------------------------------------------------- -(defmethod (setf external-format-of) - (external-format (stream zeta-stream)) +(defmethod (setf zstream-external-format) + (external-format (stream zstream)) (setf (slot-value stream 'external-format) (babel:ensure-external-format external-format))) @@ -44,47 +60,42 @@ ;;; Constructors ;;;------------------------------------------------------------------------- -(defmethod shared-initialize :after ((stream zeta-stream) slot-names +(defmethod shared-initialize :after ((stream zstream) slot-names &key (external-format :default)) (declare (ignore slot-names)) - (setf (external-format-of stream) external-format)) + (setf (zstream-external-format stream) external-format)) ;;;------------------------------------------------------------------------- -;;; READ-VECTOR +;;; READ-STRING ;;;------------------------------------------------------------------------- -(defmethod zstream-read-vector ((stream zeta-stream) (vector vector) - &key (start 0) end timeout) - (check-type vector (or ub8-simple-vector ub8-vector)) - (check-bounds vector start end) - (when (= start end) (return* 0)) - (device-read stream vector :start start :end end :timeout timeout)) - -(defmethod zstream-read-vector ((stream zeta-stream) (vector string) - &key (start 0) end timeout) - (check-type vector (or ub8-simple-vector ub8-vector)) - (check-bounds vector start end) +(defmethod zstream-read-string ((stream zstream) (string string) + &key (start 0) end eof-error-p eof-value) + (check-bounds string start end) (when (= start end) (return* 0)) ;; TODO: write it ) ;;;------------------------------------------------------------------------- -;;; WRITE-VECTOR +;;; WRITE-OCTETS ;;;------------------------------------------------------------------------- -(defmethod zstream-write-vector ((stream zeta-stream) (vector vector) +(defmethod zstream-write-octets ((stream zstream) (octets vector) &key (start 0) end timeout) - (check-type vector (or ub8-simple-vector ub8-vector)) - (check-bounds vector start end) + (check-bounds octets start end) (when (= start end) (return* 0)) - (device-write stream vector :start start :end end :timeout timeout)) + (device-write stream octets :start start :end end :timeout timeout)) + -(defmethod zstream-write-vector ((stream zeta-stream) (vector string) - &key (start 0) end timeout) - (check-type vector (or ub8-simple-vector ub8-vector)) - (check-bounds vector start end) +;;;------------------------------------------------------------------------- +;;; WRITE-STRING +;;;------------------------------------------------------------------------- + +(defmethod zstream-write-string ((stream zstream) (string string) + &key (start 0) end hangup-error-p hangup-value) + (check-bounds string start end) (when (= start end) (return* 0)) ;; TODO: write it ) -- 2.11.4.GIT