[cells-cvs] CVS Celtk - cells-cvs@common-lisp.net - mailman3.common-lisp.net

25 May 2006


      Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv11797
Added Files:
    fileevent.lisp 
Log Message:
New file. Implements Tk's fileevent command via Cells.
--- /project/cells/cvsroot/Celtk/fileevent.lisp	2006/05/25 13:32:45	NONE
+++ /project/cells/cvsroot/Celtk/fileevent.lisp	2006/05/25 13:32:45	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*-
;;;
;;; Copyright (c) 2006 by Frank Goenninger, Germany.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in 
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;; ---------------------------------------------------------------------------
;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.1 2006/05/25 13:32:45 fgoenninger Exp $
;;; ---------------------------------------------------------------------------
;;; ===========================================================================
;;; PACKAGE / EXPORTS
;;; ===========================================================================
(in-package :celtk)
(eval-when (:load-toplevel :compile-toplevel)
  (export '(tk-fileevent
        iostream
        read-fn
        write-fn
        eof-fn
        mk-fileevent)))
;;; ===========================================================================
;;; TK-FILEEVENT MODEL
;;; ===========================================================================
(defmodel tk-fileevent (widget)
((.md-name
    :accessor id :initarg :id
    :initform (c-in nil)
    :documentation "ID of the fileevent instance.")
(input-fd
    :accessor input-fd :initarg :input-fd
    :initform (c? (if (^iostream)
    	      (stream-2-in-fd (^iostream))))
    :documentation "The input/read file descriptor - internal use only.")
(output-fd
    :accessor output-fd
    :initarg :output-fd
    :initform (c? (if (^iostream)
       	      (stream-2-out-fd (^iostream))))
    :documentation "The output/write file descriptor - internal use only.")
(in-tcl-channel
    :accessor in-tcl-channel :initarg  :in-tcl-channel
    :initform (c? (fd-to-tcl-channel (^tki) (^input-fd)))
    :documentation "The TCL channel generated from the input file descriptor. - Internal use only.")
(out-tcl-channel
    :accessor out-tcl-channel :initarg  :in-tcl-channel
    :initform (c? (fd-to-tcl-channel (^tki) (^output-fd)))
    :documentation "The TCL channel generated from the output file descriptor. - Internal use only.")
(in-tcl-ch-name
    :accessor in-tcl-ch-name :initarg  :in-tcl-ch-name
    :initform (c? (if (^in-tcl-channel)
                (Tcl_GetChannelName (^in-tcl-channel))
                nil))
    :documentation "The input TCL channel's name as passed to the fileevent command. - Internal use only.")
(out-tcl-ch-name
    :accessor out-tcl-ch-name :initarg  :in-tcl-ch-name
    :initform (c? (if (^out-tcl-channel)
    	    (Tcl_GetChannelName (^out-tcl-channel))
    	    nil))
    :documentation "The output TCL channel's name as passed to the fileevent command. - Internal use only.")
(iostream
    :accessor iostream :initarg :iostream
    :initform (c-in nil)
    :documentation "The Lisp stream to be monitored - API: initarg,setf.")
(readable-cb
    :accessor readable-cb :initarg :readable-cb
    :initform (c-in nil)
    :documentation "The readable callback. A dispatcher function used to call the function supplied via the read-fn slot. - Internal use only.")
(writeable-cb
    :accessor writeable-cb :initarg :writeable-cb
    :initform (c-in nil)
    :documentation "The writeable callback. A dispatcher function used to call the function supplied via the read-fn slot. - Internal use only.")
(eof-cb
    :accessor eof-cb :initarg :eof-cb
    :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.")
(tki
    :accessor tki :initarg :tki
    :initform (c-in nil)
    :documentation "The Tcl/Tk Interpreter used. - API: initarg.")
(opcode
    :accessor opcode :initarg :opcode
    :initform (file-event-opcode-cell-rule)
    :documentation "The opcode slot is used to control the operaion of the fileevent instance. - Internal use only.")
(read-fn
    :accessor read-fn :initarg :read-fn
    :initform (c-in nil)
    :documentation "User supplied function, gets called when iostream is ready for reading. Gets iostream as parameter. - API: initarg, setf")
(write-fn
    :accessor write-fn :initarg :write-fn
    :initform (c-in nil)
    :documentation "User supplied function, gets called when iostream is ready for writing. Gets iostream as parameter. - API: initarg, setf")
(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)."))
(:default-initargs
      :id (gensym "tk-fileevent-")
    :eof-fn 'default-eof-fn))
;;; ===========================================================================
;;; CELL RULE: FILE-EVENT/OPCODE
;;; ===========================================================================
;;;
;;; Depending on opcode call the appropriate function to handle the various
;;; cases/combinations of input-fd, output-fd, and the previously executed
;;; update operation.
(defun file-event-opcode-cell-rule ()
  (c? ;; Set the opcode depending on values of input-fd, output-fd, iostream,
      ;; readable-cb, writeable-cb
(if (and (not (^input-fd))
           (not (^output-fd))
           (not .cache))
        :nop
(if (and (^input-fd)
    	 (^iostream)
             (^readable-cb))
       :update-input-tk-fileevent
       
       (if (and (^output-fd)
    	    (^iostream)
    	    (^writeable-cb))
           :update-output-tk-fileevent
           
          (if (and (not (^iostream))
    	       (not (^input-fd)))
    	 :reset-input-tk-fileevent
    	 
    	 (if (and (not (^iostream))
    		  (not (^output-fd)))
    	     :reset-output-tk-fileevent
    	     :nop)))))))
;;; ===========================================================================
;;; INIT-TK-FILEEVENT - CALLED UPON INITIALIZATION
;;; ===========================================================================
(defun init-tk-fileevent (tki)
  (assert tki)
  ;; Nop - all init done in observers now.
)
;;; ===========================================================================
;;; FILEEVENT HELPER METHODS AND FUCTIONS
;;; ===========================================================================
(defmethod set-tk-readable ((self tk-fileevent) ch-name path)
  (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))
(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]"
    	 ch-name
    	 ch-name
    	 path))
;;; ===========================================================================
;;; OBSERVERS - USED TO SEND UPDATES TO TK LAND
;;; ===========================================================================
(defobserver opcode ((self tk-fileevent))
  (let ((*tki* (tki self)))
    (ecase new-value
((:init-tk-fileevent)
       (init-tk-fileevent (tki self)))
((: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)))
((: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)))
((:reset-input-tk-fileevent)
       ;; Do nothing
       nil)
((:reset-output-tk-fileevent)
       ;; Do nothing
       nil)
((:nop)
       ;; Do nothing
       nil))))
(defobserver in-tcl-channel ((self tk-fileevent))
  (let ((*tki* (tki self)))
    (if (and new-value
         (not old-value))
      (Tcl_RegisterChannel *tki* new-value))
    (if (and old-value (not new-value))
      (progn
    (tk-format-now "fileevent ~A readable {}"
    	       (Tcl_GetChannelName old-value))
    (Tcl_UnregisterChannel *tki* old-value)))))
(defobserver out-tcl-channel ((self tk-fileevent))
  (let ((*tki* (tki self)))
    (if (and new-value (not old-value))
     (Tcl_RegisterChannel *tki* new-value))
      (if (and old-value (not new-value))
    (progn
      (tk-format-now "fileevent ~A writeable {}"
    		 (Tcl_GetChannelName old-value))
      (Tcl_UnregisterChannel *tki* old-value)))))
(defobserver readable-cb ((self tk-fileevent))
  (if new-value
    (Tcl_CreateCommand *tki*
    	       "readable-cb"
    	       new-value
    	       (null-pointer)
    	       (null-pointer))))
(defobserver writeable-cb ((self tk-fileevent))
  (if new-value
    (Tcl_CreateCommand *tki*
    	       "writeable-cb"
    	       new-value
    	       (null-pointer)
    	       (null-pointer))))
(defobserver eof-cb ((self tk-fileevent))
  (if new-value
    (Tcl_CreateCommand *tki*
    	       "eof-cb"
    	       new-value
    	       (null-pointer)
    	       (null-pointer))))
;;; ===========================================================================
;;; HELPER FUNCTIONS - FILE DESCRIPTOR TO STREAM AND CHANNEL
;;; ===========================================================================
(defun fd-to-tcl-channel (interp fd)
  (assert interp)
  (if fd
      (let ((channel (Tcl_MakeFileChannel fd 6))) ;; 6 = READ/WRITE
    (if channel
        channel
        (error "*** Tcl error: ~a" (tcl-get-string-result interp))))))
(defun stream-2-out-fd (stream) ;; FRGO: PORTING...
#+allegro
    (excl:stream-output-fn stream)
#-allegro
    (error "STREAM-2-OUT-FD: Not implemented for ~A Version ~A. Sorry."
       (lisp-implementation-type)
       (lisp-implementation-version))
)
(defun stream-2-in-fd (stream)  ;; FRGO: PORTING...
#+allegro
    (excl:stream-input-fn stream)
#-allegro
    (error "STREAM-2-IN-FD: Not implemented for ~A Version ~A. Sorry."
       (lisp-implementation-type)
       (lisp-implementation-version))
)
;;; ===========================================================================
;;; CALLBACKS
;;; ===========================================================================
(defcallback readable-cb :int
    ((clientData :pointer)
     (interp     :pointer)
     (argc       :int)
     (argv       :pointer))
  (declare (ignorable clientData argc interp))
  (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1)))
     (self (gethash path (dictionary *tkw*))))
    (bwhen (fn (^read-fn))
      (funcall fn self :read))) 
  (values (foreign-enum-value 'tcl-retcode-values :tcl-ok)))
(defcallback writeable-cb :int
    ((clientData :pointer)
     (interp     :pointer)
     (argc       :int)
     (argv       :pointer))
  (declare (ignorable clientData argc interp))
  (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1)))
     (self (gethash path (dictionary *tkw*))))
    (bwhen (fn (^write-fn))
      (funcall fn self :write)))
  (values (foreign-enum-value 'tcl-retcode-values :tcl-ok)))
(defcallback eof-cb :int
    ((clientData :pointer)
     (interp     :pointer)
     (argc       :int)
     (argv       :pointer))
  (declare (ignorable clientData interp argc))
  (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)))
;;; ===========================================================================
;;; MK-FILEEVENT: CONVENIENCE MACRO
;;; ===========================================================================
(defmacro mk-fileevent (&rest inits)
  `(make-instance 'tk-fileevent
    	  :tki *tki*
    	  :readable-cb (get-callback 'readable-cb)
    	  :writeable-cb (get-callback 'writeable-cb)
    	  :eof-cb (get-callback 'eof-cb)
    	  :fm-parent *parent*
    	  ,@inits))
;;; ===========================================================================
;;; A DEFAULT EOF FUNCTION, USER MAY SUPPLY ANOTHER FUNCTION WHEN MAKING THE
;;; INSTANCE OF TK-FILEEVENT
;;; ===========================================================================
(defmethod default-eof-fn ((self tk-fileevent))
    ;; Default action: close stream
    (bwhen (iostream (^iostream))
      (close iostream)
      (setf (^iostream) nil)))
;;; ===========================================================================
;;; TESTING
;;; ===========================================================================
;;;
;;; With these few lines below we get a simple application with a text widget
;;; that shows data sent to a pipe in that text widget.
;;;
;;; The app does this by opening the named pipe for reading. It then waits
;;; for data on the pipe via the Tcl fileevent command. When establishing
;;; the fileevent a set of callbacks is established. The callbacks call
;;; two Lisp functions, depending on the type of channel (read or write.
;;;
;;; The callback functions look for the file channel's registered read or
;;; write functions. Those functions are set via the write-fn and read-fn
;;; methods of the tk-fileevent object.
;;;
;;; In the test example below we use the read case: the function read-from-pipe
;;; actually reads from the pipe and sends the data to the text widget by
;;; setting the text widgets model value.
;;;
[48 lines skipped]