[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sat May 13 13:26:43 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv17026
Modified Files:
CELTK.lpr Celtk.lisp demos.lisp entry.lisp ltktest-ci.lisp
run.lisp tk-interp.lisp
Log Message:
--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/12 08:30:13 1.9
+++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/13 13:26:42 1.10
@@ -8,6 +8,7 @@
:modules (list (make-instance 'module :name "Celtk.lisp")
(make-instance 'module :name "tk-interp.lisp")
(make-instance 'module :name "tk-object.lisp")
+ (make-instance 'module :name "tk-events.lisp")
(make-instance 'module :name "widget.lisp")
(make-instance 'module :name "font.lisp")
(make-instance 'module :name "layout.lisp")
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/12 08:30:13 1.18
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/13 13:26:43 1.19
@@ -24,6 +24,7 @@
(:nicknames "CTK")
(:use :common-lisp :utils-kt :cells :cffi)
(:export
+ #:<1>
#:title$ #:pop-up #:event-root-x #:event-root-y
#:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget
#:mk-panedwindow
@@ -127,7 +128,7 @@
;
; --- debug stuff ---
;
- (let ((yes '( ))
+ (let ((yes '("bind" "entry"))
(no '("tk-events")))
(declare (ignorable yes no))
@@ -135,7 +136,7 @@
(break "Hey, fix this.")
(replace tk$ "{Alt Q}" :start1 st))
- (when nil #+not (and (or (null yes) (find-if (lambda (s) (search s tk$)) yes))
+ (when (and (or (null yes) (find-if (lambda (s) (search s tk$)) yes))
(not (find-if (lambda (s) (search s tk$)) no)))
(format t "~&tk> ~a~%" tk$)))
@@ -144,7 +145,7 @@
; --- serious stuff ---
;
(setf *tk-last* tk$)
- (eval-script *tki* tk$))
+ (tcl-eval-ex *tki* tk$))
(defun tk-format (defer-info fmt$ &rest fmt-args)
"Format then send to wish (via user queue)"
--- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/12 08:30:14 1.12
+++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/13 13:26:43 1.13
@@ -24,21 +24,13 @@
(in-package :celtk-user)
(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
- #+test (dolist (dll (ff:list-all-foreign-libraries))
- (when (find-if (lambda (lib)
- (search lib (pathname-name dll))) '("ftgl" "tcl" "tk"))
- (print `(unloading foreign library ,dll))
- (ff:unload-foreign-library dll)))
- ;(cffi:use-foreign-library ctk::tcl)
- ;(cffi:use-foreign-library ctk::tk)
- ;(cffi:use-foreign-library ctk::togl)
(test-window
- ;;'one-button
- 'ltktest-cells-inside
- ;;'menu-button-test
- ;;'spinbox-test
- ;; 'lotsa-widgets
- ;;'gears-demo
+ ;; dont try this one, it is deliberately dysfunctional 'one-button
+ ;; OK 'ltktest-cells-inside
+ ;; OK 'menu-button-test
+ ;; OK 'spinbox-test
+ 'lotsa-widgets
+ ;; Now in Gears project 'gears-demo
))
(defmodel one-button (window)
@@ -72,6 +64,10 @@
:width 25)
(make-instance 'button
:fm-parent *parent*
+ :text "<<kenny>>"
+ :command "event generate . <<kenny>> -data \"Hi mom\"")
+ (make-instance 'button
+ :fm-parent *parent*
:text "time now?"
:on-command (c? (lambda (self)
(trc "we got callbacks" self))))
--- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/12 08:30:14 1.4
+++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/13 13:26:43 1.5
@@ -84,12 +84,26 @@
:xscrollcommand (c-in nil)
:yscrollcommand (c-in nil)
:modified (c-in nil)
- :bindings (c? (list (list '|<<Modified>>|
+ :borderwidth (c? (if (^modified) 8 2))
+ :bindings nil #+not (c? (list (list '|<<Modified>>|
(lambda (self event &rest args)
(eko ("<<Modified>> !!TK value for text-widget" self event args)
- (setf (^modified) t))))))))
+ nil #+not (setf (^modified) t))))))))
+
+(defcallback entry-modified-handler :void ((self-tkwin :int)(XEvent :pointer))
+ (trc "yowza entry-modified-handler" self-tkwin XEvent (mem-aref XEvent :int)
+ (TK-EVENT-TYPE (mem-aref XEvent :int))))
+
+(defmethod make-tk-instance :after ((self text-widget))
+ (with-integrity(:client `(:post-make-tk ,self))
+ ;;(tk-format-now "bind ~a <<Modified>> {set bxbxbxbx}" (^path)) ;; {event generate ~:*~a <<yowza>>}" (^path))
+ (let ((self-tkwin (widget-to-tkwin self)))
+ (assert (plusp self-tkwin))
+ (trc "setting up text-widget virtual-event handler" self :tkwin self-tkwin)
+ (tk-create-event-handler self-tkwin (expt 2 30) (callback entry-modified-handler) self-tkwin))))
+
;;;(defvar +tk-keysym-table+
;;; (let ((ht (make-hash-table :test 'string=)))
;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input)
--- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/12 08:30:14 1.2
+++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/13 13:26:43 1.3
@@ -328,7 +328,7 @@
; appended.
;
:bindings (c? (list
- (list '(|<1>| "%X %Y")
+ (list '(<1> "%X %Y")
(lambda (self event root-x root-y)
(declare (ignorable event root-x root-y))
--- /project/cells/cvsroot/Celtk/run.lisp 2006/05/12 08:30:14 1.7
+++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/13 13:26:43 1.8
@@ -44,13 +44,14 @@
;; 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} {call-back-event $n1 $op}")
(tk-format-now "set tk-events {}")
+ (tk-format-now "event add <<kenny>> <Meta-Alt-Control-X><Control-S>")
(tk-format-now "proc call-back {w args} {global tk-events; lappend tk-events [concat do-on-command \\\"$w\\\" $args]}")
(tk-format-now "proc call-back-event {w e args} {global tk-events; lappend tk-events [concat do-on-event \\\"$w\\\" \\\"$e\\\" $args]}")
;; (tk-format-now "bind . <Escape> {call-back-event %W :type <Escape> :time %t}")
-
+ (tk-create-event-handler (tk-main-window *tki*) (expt 2 30) (callback tk-event-proc) 42)
+
(with-integrity ()
(setf *tkw* (make-instance root-class)))
@@ -88,7 +89,7 @@
do (tk-process-event e))))
(progn
(trc nil "tcl-do-one-event-loop sees no events" (get-internal-real-time))
- (sleep *event-loop-delay*)))))
+ #+nah (sleep *event-loop-delay*)))))
(defun tk-process-event (event)
(trc nil "tk-process-event >" event *package*)
--- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/12 08:30:14 1.5
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/13 13:26:43 1.6
@@ -29,10 +29,10 @@
(define-foreign-library Tcl
(:darwin (:framework "Tcl"))
- (:windows (:or "/tcl/bin/Tcl84.dll")))
+ (:windows (:or "/tcl/bin/Tcl85.dll")))
(define-foreign-library Tk
(:darwin (:framework "Tk"))
- (:windows (:or "/tcl/bin/tk84.dll")))
+ (:windows (:or "/tcl/bin/tk85.dll")))
;; Togl
(define-foreign-library Togl
@@ -47,7 +47,7 @@
(defmethod translate-from-foreign (value (type (eql 'tcl-retcode)))
(unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok))
- (error "*** Tcl error !"))
+ (error "Tcl error: ~a" (tcl-get-string-result *tki*)))
value)
;; --- initialization ----------------------------------------
@@ -129,44 +129,31 @@
(with-foreign-string (filename-cstr filename)
(%Tcl_EvalFile interp filename-cstr)))
-;; Tcl_Eval
+(defcfun ("Tcl_Eval" tcl-eval) tcl-retcode
+ (interp :pointer)
+ (script-cstr :string))
-(defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode
+(defcfun ("Tcl_EvalEx" tcl_evalex) tcl-retcode
(interp :pointer)
- (script-cstr :pointer))
+ (script-cstr :string)
+ (num-bytes :int)
+ (flags :int))
+
+(defun tcl-eval-ex (i s)
+ (tcl_evalex i s -1 0))
(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string
(interp :pointer))
(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int)
+(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer))
+(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer
+ (interp :pointer)
+ (pathName :string)
+ (related-tkwin :pointer))
-(defun Tcl_Eval (interp script)
- (with-foreign-string (script-cstr script)
- (%Tcl_Eval interp script-cstr)))
-
-(defcenum tcl-event-flag-values
- (:tcl-dont-wait 2)
- (:tcl-window-events 4)
- (:tcl-file-events 8)
- (:tcl-timer-events 16)
- (:tcl-idle-events 32)
- (:tcl-all-events -3))
-
-(defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int
- (flags :int))
-
-(defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void
- (tcl-idle-proc :pointer)
- (client-data :int))
-
-(defcallback tcl-idle-proc :void ((client-data :int))
- (unless (c-stopped)
- (print (list :idle-proc :client-data client-data))))
-
-;; Tk_MainLoop
-
-(defcfun ("Tk_MainLoop" Tk_MainLoop) :void)
-
+(defun widget-to-tkwin (self)
+ (tk-name-to-window *tki* (^path) (tk-main-window *tki*)))
;;; --- Togl (Version 1.7 and above needed!) -----------------------------
@@ -257,7 +244,7 @@
(assert interp)
(assert script)
- (Tcl_Eval interp script))
+ (tcl-eval interp script))
#+testing
(defun exec-button ()
More information about the Cells-cvs
mailing list