On 15/04/07, Luis Oliveira <[EMAIL PROTECTED]> wrote:
"Faré" <[EMAIL PROTECTED]> writes:
Since Stelian looks busy and that GSoC means there will be activity on
IOLib, here's my current patch to IOLib, it contains:
* character output for socket streams
* character peek and unread for socket streams
* support for EINTR in iomux event selection
* support for retrying with a timeout in general
Thanks! You forgot to attach the patch though.
Hear hear! I am sure you are not stopped by such trifles.
[ François-René ÐVB Rideau | Reflection&Cybernethics | http://fare.tunes.org ]
http://Bastiat.org/ - debunking economic sophisms since 1845.
diff --git a/io-multiplex/common.lisp b/io-multiplex/common.lisp
index 4acaab4..e1d166a 100644
--- a/io-multiplex/common.lisp
+++ b/io-multiplex/common.lisp
@@ -271,7 +271,15 @@
(with-accessors ((mux mux-of) (fds fds-of)
(timeouts timeouts-of)) event-base
(let ((deletion-list ())
- (fd-events (harvest-events mux timeout)))
+ (fd-events (block nil
+ (repeat-with-timeout
+ timeout
+ #'(lambda (timeout)
+ (handler-case
+ (return (harvest-events mux timeout))
+ (et:unix-error-intr () nil)))
+ #'(lambda ()
+ (return-from dispatch-fd-events-once nil))))))
(dolist (ev fd-events)
(destructuring-bind (fd ev-types) ev
(let ((fd-entry (fd-entry-of event-base fd)))
@@ -517,6 +525,10 @@
(iolib-utils:define-constant et::pollrdhup 0)
(defun wait-until-fd-ready (fd event-type &optional timeout)
+ ;; FIXME: this conses badly for its return value
+ ;; solution: (1) use a fixnum bitmap, just like C
+ ;; (2) if we really want to expose only lists of keyword as the API,
+ ;; cache a bitmap-indexed vector of all the combinations (sharing tails)
(flet ((choose-poll-flags (type)
(ecase type
(:read (logior et:pollin et::pollrdhup et:pollpri))
diff --git a/io-multiplex/defpackage.lisp b/io-multiplex/defpackage.lisp
index 6f068fc..3878a2e 100644
--- a/io-multiplex/defpackage.lisp
+++ b/io-multiplex/defpackage.lisp
@@ -35,4 +35,6 @@
#:add-fd #:add-timeout
#:remove-event #:event-dispatch
+ #:repeat-with-timeout
+
#:wait-until-fd-ready #:fd-ready-p))
diff --git a/io-multiplex/time.lisp b/io-multiplex/time.lisp
index f87ffa9..6689655 100644
--- a/io-multiplex/time.lisp
+++ b/io-multiplex/time.lisp
@@ -63,3 +63,14 @@
(min t1 t2)
t1)
t2))
+
+
+(defun repeat-with-timeout (timeout thunk
+ &optional
+ (timeout-thunk (constantly :timeout)))
+ (loop with deadline = (if timeout (+ (gettime) timeout) 0) do
+ (funcall thunk timeout)
+ (when timeout
+ (setf timeout (- deadline (gettime)))
+ (unless (> timeout 0)
+ (return (funcall timeout-thunk))))))
diff --git a/io.encodings/external-format.lisp b/io.encodings/external-format.lisp
index e274cc7..955ffed 100644
--- a/io.encodings/external-format.lisp
+++ b/io.encodings/external-format.lisp
@@ -537,14 +537,17 @@
`(funcall (ef-char-to-octets ,ef) ,input ,output ,error-fn
,chars-left))
-(defun string-to-octets (string &key (start 0) end
+(defun string-to-octets (string &key start end
(external-format :default)
adjust-factor)
(declare (type string string)
- (type buffer-index start)
+ (type (or null buffer-index) start)
(type (or null buffer-index) end)
(type (or null real) adjust-factor)
(optimize (speed 3) (space 0) (safety 0) (debug 0)))
+
+ (setf start (or start 0)
+ end (or end (length string)))
(let* ((ef (find-external-format external-format))
(buffer (make-array (1+ (length string))
:element-type 'octet
@@ -554,8 +557,7 @@
(pos -1) oldpos)
(setf adjust-factor (if (and adjust-factor (<= 1 adjust-factor 4))
adjust-factor
- (ef-octet-size ef))
- end (or end (length string)))
+ (ef-octet-size ef)))
(tagbody
(flet ((input ()
(prog1 (char string ptr) (incf ptr)))
diff --git a/sockets/gray-stream-methods.lisp b/sockets/gray-stream-methods.lisp
index 9d9f248..ed5fe23 100644
--- a/sockets/gray-stream-methods.lisp
+++ b/sockets/gray-stream-methods.lisp
@@ -92,13 +92,16 @@
(iobuf-reset ob)
nil))
-;; (defmethod stream-finish-output ((stream active-socket))
-;; (with-slots ((ob output-buffer)) stream
-;; nil))
+(defmethod stream-finish-output ((stream active-socket))
+ (with-slots ((ob output-buffer) fd) stream
+ (flush-obuf ob fd)
+ nil))
-;; (defmethod stream-force-output ((stream active-socket))
-;; (with-slots ((ob output-buffer)) stream
-;; nil))
+(defmethod stream-force-output ((stream active-socket))
+ ;; FIXME: add non-blocking version of this?
+ ;; and/or re-write the flush code in a non-blocking variant,
+ ;; and have the finish-output synchronize on the result.
+ (stream-finish-output stream))
;; (defmethod stream-read-sequence ((stream active-socket) seq
;; &optional start end)
@@ -110,8 +113,13 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;
-(defun fill-iobuf (buf fd &optional timeout)
- (iomux:wait-until-fd-ready fd :read timeout)
+(defun fill-ibuf (buf fd &optional timeout)
+ (when timeout
+ (let ((status
+ (iomux:wait-until-fd-ready fd :read timeout)))
+ (unless (member :read status)
+ ;; FIXME signal something better
+ (return-from fill-ibuf :timeout))))
(let ((num (et:read fd (cffi:inc-pointer (iobuf-data buf)
(iobuf-start buf))
(- (iobuf-size buf)
@@ -133,7 +141,7 @@
(return (values #\Newline 1))))
(:dos (when (= char-code (char-code #\Return))
(when (and (= (iobuf-length ib) 1)
- (eq (fill-iobuf ib fd) :eof))
+ (eq (fill-ibuf ib fd) :eof))
(incf (iobuf-start ib))
(return (values #\Return 1)))
(when (= (bref ib (1+ start-off))
@@ -151,7 +159,7 @@
(ret nil))
(flet ((fill-buf-or-eof ()
;; FIXME - what if we can't refill, in the middle of a wide-char??
- (setf ret (fill-iobuf ib fd))
+ (setf ret (fill-ibuf ib fd))
(when (eq ret :eof)
(return-from stream-read-char :eof))))
(cond ((zerop (iobuf-length ib))
@@ -215,7 +223,7 @@
(when (< 0 (iobuf-end-space-length ib) 4)
(iobuf-copy-data-to-start ib))
(when (and (iomux:fd-ready-p fd :read)
- (eql :eof (fill-iobuf ib fd)))
+ (eql :eof (fill-ibuf ib fd)))
(setf eof t))
(when (zerop (iobuf-length ib))
(return (if eof :eof nil)))
@@ -245,6 +253,8 @@
(char str 0)))))
(defun %stream-unread-char (stream)
+ ;; unreading anything but the latest character is wrong,
+ ;; but checking is not mandated by the standard
(declare (type active-socket stream))
(with-slots ((ib input-buffer) (unread-index ibuf-unread-index)) stream
(symbol-macrolet ((start (iobuf-start ib)))
@@ -256,6 +266,12 @@
nil)
(defmethod stream-unread-char ((stream active-socket) character)
+ #+super-anal-checks
+ (progn
+ (%stream-unread-char stream)
+ (unless (ignore-errors (eql (stream-read-char stream) character))
+ (error "Trying to unread wrong character ~S" character)))
+ #-super-anal-checks
(declare (ignore character))
(%stream-unread-char stream))
@@ -324,11 +340,73 @@
(ioenc::char-to-octets ef #'input #'output #'error-fn (- end ptr)))
(exit))))
+(defun flush-obuf (buf fd &optional timeout)
+ (flet ((write-once ()
+ (let* ((num (et:write
+ fd
+ (cffi:inc-pointer (iobuf-data buf)
+ (iobuf-start buf))
+ (iobuf-length buf))))
+ (if (zerop num)
+ nil
+ (progn (incf (iobuf-start buf) num) t))))
+ (emptyp ()
+ (let ((x (= (iobuf-end buf) (iobuf-start buf))))
+ (when x
+ (iobuf-reset buf)
+ t))))
+ (if (emptyp)
+ (values t nil)
+ (block nil
+ (iomux:repeat-with-timeout
+ timeout
+ #'(lambda (timeout)
+ (let ((status (iomux:wait-until-fd-ready fd :write timeout)))
+ (unless (member :write status)
+ ;; FIXME signal something better -- maybe analyze the status
+ (return (values nil :timeout)))
+ (unless (write-once)
+ (return (values nil :fail)))
+ (when (emptyp)
+ (return t))))
+ #'(lambda ()
+ (return (values nil :timeout))))))))
+
+(defgeneric %stream-write-octets (stream octets &optional start end))
+
(defmethod %stream-write-octets ((stream active-socket) octets
&optional start end)
- (error "NOT IMPLEMENTED YET"))
+ ;; FIXME: when calling write-sequence with a simple-array of octets
+ ;; do required I/O directly, not through a buffer
+ (check-type octets (simple-array ub8 (*)))
+ (let ((max (length octets)))
+ (if start
+ (check-type start (integer 0 *))
+ (setf start 0))
+ (if end
+ (progn
+ (check-type end (integer 0 *))
+ (assert (<= end max)))
+ (setf end max)))
+ (with-slots ((buf output-buffer) fd) stream
+ (loop while (< start end) do
+ (let ((len (min (- end start) (iobuf-end-space-length buf))))
+ (setf *print-readably* nil)
+ ;; FIXME: optimize this BLT
+ (loop for i from start
+ for j from (iobuf-end buf)
+ repeat len do
+ (setf (bref buf j) (aref octets i))
+ )
+ (incf (iobuf-end buf) len)
+ (incf start len)
+ (when (= (iobuf-end buf) (iobuf-size buf))
+ (or (flush-obuf buf fd)
+ ;; FIXME: better error handling
+ (error "Failed to write octets")))))))
(defmethod stream-write-char ((stream active-socket) character)
+ ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
(stream-write-string stream (make-string 1 :initial-element character)))
;; (defmethod stream-advance-to-column ((stream active-socket)
@@ -348,10 +426,15 @@
(defmethod stream-write-string ((stream active-socket)
(string string)
&optional start end)
+ ;; FIXME: have the ef do i/o directly into the existing buffer,
+ ;; don't do double buffering of I/O
(%stream-write-octets
stream
(ioenc:string-to-octets string :start start :end end
:external-format (slot-value stream 'external-format))))
+
+;; FIXME: isn't there a generic stream-write-sequence???
+
;;;;;;;;;;;;;;;;;;
;; ;;
@@ -363,7 +446,7 @@
(with-slots ((fd fd) (ib input-buffer)
(pos istream-pos)) stream
(flet ((fill-buf-or-eof ()
- (when (eq :eof (fill-iobuf ib fd))
+ (when (eq :eof (fill-ibuf ib fd))
(return-from stream-read-byte :eof))))
(when (zerop (iobuf-length ib))
(iobuf-reset ib)
_______________________________________________
iolib-devel mailing list
[email protected]
http://common-lisp.net/cgi-bin/mailman/listinfo/iolib-devel
