[cells-cvs] CVS Celtk
fgoenninger
fgoenninger at common-lisp.net
Wed May 31 05:09:14 UTC 2006
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*
, at 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 ()
More information about the Cells-cvs
mailing list