/fileevent.lisp

;; -*- 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.9 2006/11/04 20:53:08 ktilton Exp $

;;; ---------------------------------------------------------------------------



;;; ===========================================================================

;;; PACKAGE / EXPORTS

;;; ===========================================================================



(in-package :celtk)



(eval-when (:load-toplevel :compile-toplevel)

  (export '(tk-fileevent

	    iostream

	    read-fn

	    write-fn

	    eof-fn

	    mk-fileevent

	    stream-2-in-fd

	    stream-2-out-fd)))



;;; ===========================================================================

;;; 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.")



   (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)

    :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).")



   (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-")

    :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 ()

  "Set the opcode depending on values of input-fd, output-fd, iostream, readable-cb, writeable-cb"

  (c? (cond

       ((not (or (^input-fd) (^output-fd) .cache))

        :nop)

       

       ((and (^input-fd) (^iostream) (^readable-cb))

        :update-input-tk-fileevent)

	   

       ((and (^output-fd) (^iostream) (^writeable-cb))

        :update-output-tk-fileevent)

       

       ((not (or (^iostream) (^input-fd)))

        :reset-input-tk-fileevent)

		 

       ((not (or (^iostream) (^output-fd)))

        :reset-output-tk-fileevent)



       (t :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 type)



;; frgo, 2006-05-26:

;; The code here was aimed at EOF checking after reading...

;; 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]]]} {

;;          error-cb $path $err

;; 	 close $channel

;;  	 return

;;      }

;;      # Read a line from the channel

;;      if {[catch {set line [gets $channel]} err]} {

;;          error-cb $path $err

;;  	close $channel

;;  	return

;;      }

;;      if {[string length $line]} {

;;  	received-cb $path $line

;;      }

;;      # check for eof

;;      if {[eof $channel]} {

;;          eof-cb $path

;;          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 "fileevent ~A readable [list readable ~A ~A ~a]"

		 ch-name

		 ch-name

		 path

		 type)

)



(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

		 type))



;;; ===========================================================================

;;; FILEEVENT CONDITIONS

;;; ===========================================================================



(define-condition tcl-fileevent-error (error)

  ())



;;; ===========================================================================

;;; 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))

	      (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))

	      (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

       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-create-command *tki*

		       "readable-cb"

		       new-value

		       (null-pointer)

		       (null-pointer))))



(defobserver writeable-cb ((self tk-fileevent))

  (if new-value

    (tcl-create-command *tki*

		       "writeable-cb"

		       new-value

		       (null-pointer)

		       (null-pointer))))



(defobserver eof-cb ((self tk-fileevent))

  (if new-value

    (tcl-create-command *tki*

		       "eof-cb"

		       new-value

		       (null-pointer)

		       (null-pointer))))



(defobserver error-cb ((self tk-fileevent))

  (if new-value

    (tcl-create-command *tki*

		       "error-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 (ignore 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 (ignore 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 (ignore clientData interp argc))

  (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

;;; ===========================================================================



(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)

		  :error-cb (get-callback 'error-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))

    (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

;;; ===========================================================================

;;;

;;; 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.

;;; 

;;; In order to use this example please adapt the code below with a

;;; pipe name suitable for you (see the ^^^^^^^^ marks below).

;;; On Unixes you have to create the pipe with the mkfifo command.

;;;

;;; Have fun!

;;;

;;; Questions welcome...

;;;

;;; Frank Goenninger

;;; frgo@mac.com

;;;

;;; May 2006





;;; 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 "*** USRF: data = " data)

      (if data

	 (setf (value (fm-other :receive-window)) data)

	 (funcall (^eof-fn) self)))))



(defmodel fileevent-test-window (window)

  ()

  (:default-initargs

      :kids (c? (the-kids

		   (mk-stack (:packing (c?pack-self))

 		     (mk-label :text "Receive window"

			       :pady 10)

		     (mk-text-widget :id :receive-window

				     ;:state 'disabled

				     :value (c-in "")

				     :height 10

				     :width 80

				     :borderwidth 2

				     :relief 'sunken

				     :pady 5))

		   (mk-fileevent :id :fileevent-test

				 :read-fn 'USRF

			         :iostream (c-in

					     (open "/Users/frgo/dribble.lisp"

;;;                           Adapt here !!!     ^^^^^^^^^^^^^^^^^^^^^^^^^^^

						  :direction :input)))))))



;;; Call this function  for testing !!

(defun test-fileevent ()

  (trc "-----------------------------------------------------------------------------")

  (test-window 'fileevent-test-window)

  (trc "-----------------------------------------------------------------------------"))



#+test

(test-window 'fileevent-test-window)