[cells-cvs] CVS Celtk
fgoenninger
fgoenninger at common-lisp.net
Fri Aug 14 16:07:56 UTC 2009
Update of /project/cells/cvsroot/Celtk
In directory cl-net:/tmp/cvs-serv5539
Modified Files:
run.lisp
Log Message:
Changed: Multiple changes, largely adding Lispworks support by ensuring
that event loop / Tcl/Tk and Lispworks are running in same thread.
Changed: Added support for on-command for mouse buttons 2 and 3.
--- /project/cells/cvsroot/Celtk/run.lisp 2008/06/16 12:35:56 1.30
+++ /project/cells/cvsroot/Celtk/run.lisp 2009/08/14 16:07:56 1.31
@@ -16,76 +16,254 @@
|#
-(in-package :Celtk)
+;;; $Header: /project/cells/cvsroot/Celtk/run.lisp,v 1.31 2009/08/14 16:07:56 fgoenninger Exp $
+(in-package :Celtk)
-;;; --- running a Celtk (window class, actually) --------------------------------------
+;;; --- running a Celtk (window class, actually) ------------------------------
(eval-now!
- (export '(tk-scaling run-window test-window *ctk-dbg*)))
+ (export '(tk-scaling
+
+ run-window-using-context
+ mk-run-window-context
+
+ run-window
+ test-window
+
+ *ctk-dbg*
+
+ defcommand
+ )))
(defparameter *ctk-dbg* nil)
+;;; --- commands --------------------------------------------------------------
+
+(defmacro defcommand (name)
+ (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name)))
+ (^on-name (read-from-string (format nil "^ON-~a" name))))
+
+ `(progn
+
+ (defmethod ,do-on-name (self &rest args)
+ (bwhen (cmd (,^on-name))
+ (apply cmd self args))
+ 0)
+
+ (defcallback ,do-on-name :int
+ ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
+ (declare (ignore client-data))
+ (let ((*tki* interp)
+ (args (loop for argn upfrom 1 below argc
+ collecting (mem-aref argv :string argn))))
+ (bif (self (gethash (car args) (dictionary *tkw*)))
+ (progn
+ (trc "defcommand > " ',^on-name self (cdr args))
+ (apply ',do-on-name self (rest args)))
+ (progn
+ (break ",do-on-name> Target widget ~a does not exist" (car args))
+ #+anyvalue? (tcl-set-result interp
+ (format nil ",do-on-name> Target widget ~a does not exist" (car args))
+ (null-pointer))
+ 1)))))))
+
+(defcommand command)
+;
+; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events
+;
+(defcommand key-down)
+(defcommand key-up)
+(defcommand double-click-1)
+(defcommand double-click-2)
+(defcommand double-click-3)
+
+;;; --- running a Celtk (window class, actually) -----------------------------
+
+(defmd run-window-context ()
+ root-class
+ resetp
+ window-initargs
+ tk-packages-to-load
+
+ ;; Default initargs
+
+ :resetp t
+
+ ;; Specify here the Tcl/Tk packages to load after Tcl/Tk init.
+ ;; Format is: list of (package-name init-function) pairs.
+ :tk-packages-to-load (list
+ '("snack" nil)
+ '("tile" (lambda ()
+ (ctk:tk-format-now "namespace import -force ttk::*")))
+ '("QuickTimeTcl" nil)
+ '("snack" (lambda ()
+ (ctk:tk-format-now "snack::sound s")))))
+
+(defmacro mk-run-window-context (root-class &rest args)
+ `(make-instance 'run-window-context :root-class ,root-class , at args))
+
+(defparameter *rwc* nil "This is the single instance of run-window-context. Holds call parameters for run-window. Needed because run-window needs to be a function with no arguments on Lispworks.")
+
+(defun %do-run-window ()
+ "Lowest level call to %run-window - implementation and platform specific
+ stuff should go into this function."
+
+ ;;(%run-window) ;; frgo, 2007-09-28:
+ ;; DEBUG - call %run-window directly even on LW
+
+ #+lispworks
+ (let* ((bindings (cons '(*tkw* . *tkw*) mp:*process-initial-bindings*)) ;; UGLY ...
+ (bindings (cons '(*tki* . *tki*) bindings)) ;; there has to be a
+ (bindings (cons '(*app* . *app*) bindings)) ;; better way ...
+ (bindings (cons '(*rwc* . *rwc*) bindings)) ;; frgo, 2007-09-26
+ (mp:*process-initial-bindings* bindings))
+ (%run-window))
+
+ #-lispwoks (%run-window)
+ )
+
(defun run-window (root-class &optional (resetp t) &rest window-initargs)
- (assert (symbolp root-class))
- (setf *tkw* nil)
+ (declare (ignorable root-class))
- (when resetp
- (cells-reset 'tk-user-queue-handler))
- (tk-interp-init-ensure)
-
- (setf *tki* (Tcl_CreateInterp))
- ;(break "ok?")
- ;(deep)
-
- ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42)
- (tk-app-init *tki*)
- (tk-togl-init *tki*)
- (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
-
- (tk-format-now "package require snack")
- (tk-format-now "package require tile")
- #-unix
- ;;(tk-format-now "package require QuickTimeTcl")
- (tk-format-now "snack::sound s")
-
- (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
-
- ;; these next exist because of limitations in the Tcl API. eg, the keypress event does not
- ;; include enough info to extract the keysym directly, and the function to extract the
- ;; keysym is not exposed. The keysym, btw, is the portable representation of key events.
-
- (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
- (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
- (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer))
- (trc "integ" cells::*within-integrity*)
-
- (with-integrity () ;; w/i somehow ensures tkwin slot gets populated
- (setf *app*
- (make-instance 'application
- :kids (c? (the-kids
- (setf *tkw* (apply 'make-instance root-class
- :fm-parent *parent*
- window-initargs)))))))
-
- (assert (tkwin *tkw*))
-
- (tk-format `(:fini) "wm deiconify .")
- #-its-alive! (tk-format-now "bind . <Escape> {destroy .}")
- ;
- ; see above for why we are converting key x-events to application key virtual events:
- ;
- (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
- (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
- (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}")
+ ;; Save call parameters into *rwc* context
+ (setq *rwc* (make-instance 'run-window-context
+ :root-class root-class
+ :resetp resetp
+ :window-initargs window-initargs))
+
+ ;; Call internal run-window funtion
+ (%do-run-window))
+
+(defmethod run-window-using-context ((rwc run-window-context))
+ (declare (ignorable root-class))
+
+ ;; Save call into *rwc* context
+ (let ((*rwc* rwc))
+
+ ;; Call internal run-window funtion
+ (%do-run-window)))
+
+(defun tk-package-require (tk-package)
+ (assert (stringp tk-package) () "Error: Parameter tk-package is not a string.")
+ (tk-format-now "package require ~a" tk-package))
+
+(defun %run-window ()
+ "This function is intented to be called by 'run-window. It relies on the call parameters to be stored in *rwc*."
- (block nil
+ (assert *rwc* () "Error: Global call context *rwc* for '%run-window is not initialized.")
+
+ ;; Get call parameters from *rwc*
+ (let ((root-class (root-class *rwc*))
+ (resetp (resetp *rwc*))
+ (window-initargs (window-initargs *rwc*))
+ (tk-packages-to-load (tk-packages-to-load *rwc*)))
+
+ ;; Ensure clean start situation
+
+ (setf *tkw* nil)
+
+ (when resetp
+ (cells-reset 'tk-user-queue-handler))
+
+ (tk-interp-init-ensure)
+
+ ;; Initialize Tcl/Tk
+ (setf *tki* (Tcl_CreateInterp))
+
+ (tk-app-init *tki*) ;; Inits Tk
+ (tk-togl-init *tki*) ;; Inits the Tcl/Tk OpenGL Widget TOGL
+
+ (trc "Tcl/Tk and Togl initialized." *tki*)
+
+ ;; Load Tcl/Tk packages (as they are defined in *rwc*.tk-packages-to-load)
+
+ (dolist (pkg-load-info tk-packages-to-load)
+ (let ((tk-package (first pkg-load-info))
+ (init-fn (second pkg-load-info)))
+ (when tk-package
+ (tk-package-require tk-package))
+ (when (and init-fn (functionp init-fn))
+ (trc "*** Calling Tcl/Tk package init function" init-fn)
+ (funcall init-fn))))
+
+ ;; Setup Tcl/Tk to be able to interact with Celtk
+ (tk-format-now
+ "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
+
+ (tcl-create-command *tki* "do-on-command"
+ (get-callback 'do-on-command)
+ (null-pointer) (null-pointer))
+
+ ;; These next exist because of limitations in the Tcl API. eg, the
+ ;; keypress event does not include enough info to extract the keysym
+ ;; directly, and the function to extract the keysym is not exposed.
+ ;; The keysym, btw, is the portable representation of key events.
+
+ (tcl-create-command *tki* "do-key-down"
+ (get-callback 'do-on-key-down)
+ (null-pointer) (null-pointer))
+
+ (tcl-create-command *tki* "do-key-up"
+ (get-callback 'do-on-key-up)
+ (null-pointer) (null-pointer))
+
+ (tcl-create-command *tki* "do-double-click-1"
+ (get-callback 'do-on-double-click-1)
+ (null-pointer) (null-pointer))
+ (tcl-create-command *tki* "do-double-click-2"
+ (get-callback 'do-on-double-click-2)
+ (null-pointer) (null-pointer))
+ (tcl-create-command *tki* "do-double-click-3"
+ (get-callback 'do-on-double-click-3)
+ (null-pointer) (null-pointer))
+
+ (trc ";;; Celtk: Tcl/Tk setup done. Now about to create window.")
+
+ ;; Create the application window
+
+ (with-integrity () ;; w/i somehow ensures tkwin slot gets populated
+ (setf *app*
+ (make-instance 'application
+ :kids (c? (the-kids
+ (setf *tkw* (apply 'make-instance root-class
+ :fm-parent *parent*
+ window-initargs))))
+ )))
+
+ (assert (tkwin *tkw*)) ;; really there ?
+
+ (trc ";;; Celtk: Tcl/Tk window created.")
+
+ ;; And ... show it!
+ (tk-format `(:fini) "wm deiconify .")
+
+ ;; Default key bindings
+
+ #-its-alive! (tk-format-now "bind . <Escape> {destroy .}")
+ ;;
+ ;; See above for why we are converting key x-events to application
+ ;; key virtual events:
+
+ (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
+ (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
+
+ (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}")
+ (tk-format-now "bind . <Double-ButtonPress-2> {do-double-click-2 %W %K; break}")
+ (tk-format-now "bind . <Double-ButtonPress-3> {do-double-click-1 %W %K; break}")
+
+ ;; Call the window class's init function prior to enter event loop
(bwhen (ifn (start-up-fn *tkw*))
(funcall ifn *tkw*))
- (CG:kill-splash-screen)
- (unless #-rms-s3 nil #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" )
- (not (eval (read-from-string bail$))))
- (tcl-do-one-event-loop))))
+
+ ;; Kenny Tilton specials on next 4 lines
+ #+cg (cg:kill-spash-screen)
+ (unless #-rms-s3 nil
+ #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" )
+ (not (eval (read-from-string bail$)))))
+
+ ;; Finally enter event loop to process events
+ (tcl-do-one-event-loop)))
(defun ensure-destruction (w key)
(declare (ignorable key))
@@ -113,9 +291,10 @@
(defmethod widget-event-handle ((self window) xe)
(let ((*tkw* self))
(unless (find (xevent-type xe) '(:MotionNotify))
- #+xxx (TRC "main window event" self *tkw* (xevent-type xe)))
+ (TRC "main window event" self *tkw* (xevent-type xe)))
(flet ((give-to-window ()
(bwhen (eh (event-handler *tkw*))
+ (trc "giving to window: eh" eh)
(funcall eh *tkw* xe))))
(case (xevent-type xe)
((:focusin :focusout) (setf (^focus-state) (xevent-type xe)))
@@ -123,9 +302,13 @@
#+shhh (call-dump-event client-data xe))
(:configurenotify
- (setf (^width) (parse-integer (tk-eval "winfo width .")))
- (with-cc :height
- (setf (^height) (parse-integer (tk-eval "winfo height .")))))
+ (let ((width (parse-integer (tk-eval "winfo width .")))
+ (height (parse-integer (tk-eval "winfo height ."))))
+ (trc ":configure-notify >>> widht | height" width height)
+ ;; frgo (break "widget-event-handle/:configurenotify")
+ #+not (with-cc :configurenotify
+ (setf (^width) width)
+ (setf (^height) height))))
(:destroyNotify
(pushnew *tkw* *windows-destroyed*)
@@ -133,7 +316,7 @@
(:virtualevent
(bwhen (n$ (xsv name xe))
- (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
+ (trc "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
(tcl-get-string (xsv user-data xe))))
(case (read-from-string (string-upcase n$))
(keypress ;(break "this works??: going after keysym")
@@ -197,38 +380,3 @@
(apply 'run-window root-class resetp window-initargs))
-;;; --- commands -----------------------------------------------------------------
-
-(defmacro defcommand (name)
- (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name)))
- (^on-name (read-from-string (format nil "^ON-~a" name))))
- `(progn
- (defmethod ,do-on-name (self &rest args)
- (bwhen (cmd (,^on-name))
- (apply cmd self args))
- 0)
-
- (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
- (declare (ignore client-data))
- (let ((*tki* interp)
- (args (loop for argn upfrom 1 below argc
- collecting (mem-aref argv :string argn))))
- (bif (self (gethash (car args) (dictionary *tkw*)))
- (progn
- (trc nil "defcommand > " ',^on-name self (cdr args))
- (apply ',do-on-name self (rest args)))
- (progn
- (break ",do-on-name> Target widget ~a does not exist" (car args))
- #+anyvalue? (tcl-set-result interp
- (format nil ",do-on-name> Target widget ~a does not exist" (car args))
- (null-pointer))
- 1)))))))
-
-(defcommand command)
-;
-; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events
-;
-(defcommand key-down)
-(defcommand key-up)
-(defcommand double-click-1)
-
More information about the Cells-cvs
mailing list