Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12140
Modified Files: fileevent.lisp Log Message: Changed:EOF now handled on both sides: in Lisp land and in Tcl land
--- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 23:53:57 1.5 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/31 05:09:14 1.6 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.5 2006/05/28 23:53:57 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.6 2006/05/31 05:09:14 fgoenninger Exp $ ;;; ---------------------------------------------------------------------------
;;; =========================================================================== @@ -108,6 +108,11 @@ :initform (c-in nil) :documentation "The eof callback. A dispatcher function used to call the function supplied via the eof-fn slot. - Internal use only.")
+ (error-cb + :accessor error-cb :initarg :error-cb + :initform (c-in nil) + :documentation "The error callback. A dispatcher function used to call the function supplied via the error-fn slot. - Internal use only.") + (tki :accessor tki :initarg :tki :initform (c-in nil) @@ -131,7 +136,12 @@ (eof-fn :accessor eof-fn :initarg :eof-fn :initform (c-in nil) - :documentation "User supplied function, gets called when iostream is EOF. Gets iostream as parameter. - API: initarg, setf (Via default-initarg set to fn default-eof-fn which simply closes the stream).")) + :documentation "User supplied function, gets called when iostream is EOF. Gets iostream as parameter. - API: initarg, setf (Via default-initarg set to fn default-eof-fn which simply closes the stream).") + + (error-fn + :accessor error-fn :initarg :error-fn + :initform (c-in nil) + :documentation "User supplied function, gets called when iostream has encountntered an error. Gets iostream and error sting as parameters. - API: initarg, setf (Via default-initarg set to fn default-error-fn which simply closes the stream and signals an error of class tcl-error)."))
(:default-initargs :id (gensym "tk-fileevent-") @@ -187,11 +197,13 @@ ;;; FILEEVENT HELPER METHODS AND FUCTIONS ;;; ===========================================================================
-(defmethod set-tk-readable ((self tk-fileevent) ch-name path) +(defmethod set-tk-readable ((self tk-fileevent) ch-name path type)
;; frgo, 2006-05-26: ;; The code here was aimed at EOF checking after reading... -;; So the API needs rework... +;; So the API needs rework... +;; STATUS: IN WORK +;; ;; (tk-format-now " proc readable {channel path} { ;; # check for async errors (sockets only, I think) ;; if {[string length [set err [fconfigure $channel -error]]]} { @@ -199,7 +211,7 @@ ;; close $channel ;; return ;; } -;; # read a line from the channel +;; # Read a line from the channel ;; if {[catch {set line [gets $channel]} err]} { ;; error-cb $path $err ;; close $channel @@ -214,19 +226,56 @@ ;; close $channel ;; } ;; }") + +;; frgo: Old code snippet: +;; (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") +;; (tk-format-now "fileevent ~A readable [list readable ~A ~A]" +;; ch-name +;; ch-name +;; path) + + (trc "tk-set-readable sees ch-name path type" ch-name path type) + (tk-format-now + "proc readable {channel path type} { + + if {! [string compare $type "socket"]} { + if {[string length [set err [fconfigure $channel -error]]]} { + error-cb $path $err + close $channel + return + } + } + + readable-cb $path + + catch { if {[eof $channel]} { + eof-cb $path + close $channel + } + } + }")
- (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") - (tk-format-now "fileevent ~A readable [list readable ~A ~A]" + (tk-format-now "fileevent ~A readable [list readable ~A ~A ~a]" ch-name ch-name - path)) + path + type) +)
-(defmethod set-tk-writeable ((self tk-fileevent) ch-name path) - (tk-format-now "proc writeable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") - (tk-format-now "fileevent ~A writeable [list writeable ~A ~A]" +(defmethod set-tk-writeable ((self tk-fileevent) ch-name path type) + (tk-format-now "proc writeable {channel path type} { if [ eof $channel ] then { eof-cb $path } else { writeable-cb $path } }") + (tk-format-now "fileevent ~A writeable [list writeable ~A ~A ~a]" ch-name ch-name - path)) + path + type)) + +;;; =========================================================================== +;;; FILEEVENT CONDITIONS +;;; =========================================================================== + +(define-condition tcl-fileevent-error (error) + ())
;;; =========================================================================== ;;; OBSERVERS - USED TO SEND UPDATES TO TK LAND @@ -242,14 +291,26 @@ ((:update-input-tk-fileevent) (let* ((channel (in-tcl-channel self)) (path (path self)) - (ch-name (Tcl_GetChannelName channel))) - (set-tk-readable self ch-name path))) + (ch-name (Tcl_GetChannelName channel)) + (ch-type (Tcl_GetChannelType channel))) + (set-tk-readable self + ch-name + path + (foreign-slot-value ch-type + 'Tcl_ChannelType + 'typeName ))))
((:update-output-tk-fileevent) (let* ((channel (out-tcl-channel self)) (path (path self)) - (ch-name (Tcl_GetChannelName channel))) - (set-tk-writeable self ch-name path))) + (ch-name (Tcl_GetChannelName channel)) + (ch-type (Tcl_GetChannelType channel))) + (set-tk-writeable self + ch-name + path + (foreign-slot-value ch-type + 'Tcl_ChannelType + 'typeName))))
((:reset-input-tk-fileevent) ;; Do nothing @@ -308,6 +369,14 @@ (null-pointer) (null-pointer))))
+(defobserver error-cb ((self tk-fileevent)) + (if new-value + (Tcl_CreateCommand *tki* + "error-cb" + new-value + (null-pointer) + (null-pointer)))) + ;;; =========================================================================== ;;; HELPER FUNCTIONS - FILE DESCRIPTOR TO STREAM AND CHANNEL ;;; =========================================================================== @@ -377,13 +446,27 @@ (argc :int) (argv :pointer)) (declare (ignore clientData interp argc)) - (trc "eof!!!!!") + (trc "EOF-CB !!!") (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) (funcall fn self))) (values (foreign-enum-value 'tcl-retcode-values :tcl-ok)))
+(defcallback error-cb :int + ((clientData :pointer) + (interp :pointer) + (argc :int) + (argv :pointer)) + (declare (ignore clientData interp argc)) + (trc "ERROR-CB !!!") + (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) + (err$ (foreign-string-to-lisp (mem-aref argv :pointer 2))) + (self (gethash path (dictionary *tkw*)))) + (bwhen (fn (^error-fn)) + (funcall fn self err$))) + (values (foreign-enum-value 'tcl-retcode-values :tcl-error))) + ;;; =========================================================================== ;;; MK-FILEEVENT: CONVENIENCE MACRO ;;; =========================================================================== @@ -394,6 +477,7 @@ :readable-cb (get-callback 'readable-cb) :writeable-cb (get-callback 'writeable-cb) :eof-cb (get-callback 'eof-cb) + :error-cb (get-callback 'error-cb) :fm-parent *parent* ,@inits))
@@ -403,10 +487,26 @@ ;;; ===========================================================================
(defmethod default-eof-fn ((self tk-fileevent)) - ;; Default action: close stream - (bwhen (iostream (^iostream)) - (close iostream) - (setf (^iostream) nil))) + ;; Default action: close stream + (bwhen (iostream (^iostream)) + (with-integrity (:client `(:variable ,self)) + (setf (^iostream) nil) + (close iostream)))) + +;;; =========================================================================== +;;; A DEFAULT ERROR FUNCTION, USER MAY SUPPLY ANOTHER FUNCTION WHEN MAKING THE +;;; INSTANCE OF TK-FILEEVENT +;;; =========================================================================== + +(defmethod default-error-fn ((self tk-fileevent) err$) + (declare (ignorable err$)) + (trc "Heya! Error ~a ... :-(" err$) + ;; Default action 1: close stream + (bwhen (iostream (^iostream)) + (close iostream) + (setf (^iostream) nil)) + ;; Default action 2: signal error + (signal 'tcl-fileevent-error))
;;; =========================================================================== ;;; TESTING @@ -441,13 +541,18 @@ ;;; ;;; May 2006
-(defmethod read-from-pipe ((self tk-fileevent) &optional (operation :read)) + +;;; This is the User Supplied Read Function USRF. USRF has to take care of +;;; closing the channel if it is a file that is read from !!! +;;; The sample supplied here may serve as a template ... +(defmethod USRF ((self tk-fileevent) &optional (operation :read)) (declare (ignorable operation)) (let ((stream (^iostream))) (let ((data (read-line stream nil nil nil))) - (trc "*** READ-FROM-PIPE: data = " data) - (when data - (setf (md-value (fm-other :receive-window)) data))))) + (trc "*** USRF: data = " data) + (if data + (setf (md-value (fm-other :receive-window)) data) + (funcall (^eof-fn) self)))))
(defmodel fileevent-test-window (window) () @@ -465,10 +570,11 @@ :relief 'sunken :pady 5)) (mk-fileevent :id :fileevent-test - :read-fn 'read-from-pipe - :iostream (open "/0dev/hw.txt" + :read-fn 'USRF + :iostream (c-in + (open "/Users/frgo/dribble.lisp" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ - :direction :input)))))) + :direction :input)))))))
;;; Call this function for testing !! (defun test-fileevent ()