[graphic-forms-cvs] r167 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Wed Jun 28 17:44:07 2006
New Revision: 167

Modified:
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
introduced infrastructure for dispatching control notifications, and used this to implement event-focus-gain/event-focus-loss and event-modify for edit controls

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Wed Jun 28 17:44:07 2006
@@ -126,6 +126,23 @@
   (call-next-method)
   (gfs:dispose dlg))
 
+(defclass edit-control-events (gfw:event-dispatcher) ())
+
+(defun truncate-text (str)
+  (subseq str 0 (min (length str) 5)))
+
+(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time)
+  (declare (ignore time))
+  (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl))))
+
+(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time)
+  (declare (ignore time))
+  (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl))))
+
+(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time)
+  (declare (ignore time))
+  (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl))))
+
 (defun open-dlg (title style)
   (let* ((dlg (make-instance 'gfw:dialog :owner *main-win*
                                          :dispatcher (make-instance 'dialog-events)
@@ -135,6 +152,7 @@
                                                                 :style '(:horizontal))
                                          :style style
                                          :text title))
+         (edit-disp (make-instance 'edit-control-events))
          (left-panel (make-instance 'gfw:panel
                                     :layout (make-instance 'gfw:flow-layout
                                                            :spacing 4
@@ -145,6 +163,7 @@
                                     :parent left-panel))
          (name-edit (make-instance 'gfw:edit
                                    :text "WWWWWWWWWWWWWWWWWWWWWWWW"
+                                   :dispatcher edit-disp
                                    :parent left-panel))
          (serial-label (make-instance 'gfw:label
                                       :text "Serial Number:"
@@ -152,6 +171,7 @@
          (serial-edit (make-instance 'gfw:edit
                                      :style '(:read-only)
                                      :text "323K DSKL3 DSKE23"
+                                     :dispatcher edit-disp
                                      :parent left-panel))
          (pw-label (make-instance 'gfw:label
                                   :text "Password:"
@@ -159,6 +179,7 @@
          (pw-edit (make-instance 'gfw:edit
                                  :style '(:mask-characters)
                                  :text "WWWWWWWWWWWWWWWWWWWWWWWW"
+                                 :dispatcher edit-disp
                                  :parent left-panel))
          (desc-label (make-instance 'gfw:label
                                     :text "Description:"
@@ -166,6 +187,7 @@
          (desc-edit (make-instance 'gfw:edit
                                    :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return)
                                    :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W")
+                                   :dispatcher edit-disp
                                    :parent left-panel))
          (btn-panel (make-instance 'gfw:panel
                                    :layout (make-instance 'gfw:flow-layout

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Wed Jun 28 17:44:07 2006
@@ -271,6 +271,17 @@
 (defconstant +em-setimestatus+             #x00D8)
 (defconstant +em-getimestatus+             #x00D9)
 
+(defconstant +en-setfocus+                 #x0100)
+(defconstant +en-killfocus+                #x0200)
+(defconstant +en-change+                   #x0300)
+(defconstant +en-update+                   #x0400)
+(defconstant +en-errspace+                 #x0500)
+(defconstant +en-maxtext+                  #x0501)
+(defconstant +en-hscroll+                  #x0601)
+(defconstant +en-vscroll+                  #x0602)
+(defconstant +en-align-ltr-ec+             #x0700)
+(defconstant +en-align-rtl-ec+             #x0701)
+
 (defconstant +es-left+                     #x0000)
 (defconstant +es-center+                   #x0001)
 (defconstant +es-right+                    #x0002)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Wed Jun 28 17:44:07 2006
@@ -118,6 +118,15 @@
                                    (cffi:get-callback 'subclassing_wndproc))))
     (error 'gfs:win32-error :detail "set-window-long failed")))
 
+(defun dispatch-notification (widget wparam-hi)
+  (let ((disp (dispatcher widget))
+        (time (event-time (thread-context))))
+    (case wparam-hi
+      (0                     (event-select     disp widget time (gfs:make-rectangle))) ; FIXME: debug
+      (#.gfs::+en-killfocus+ (event-focus-loss disp widget time))
+      (#.gfs::+en-setfocus+  (event-focus-gain disp widget time))
+      (#.gfs::+en-update+    (event-modify     disp widget time)))))
+
 ;;;
 ;;; process-message methods
 ;;;
@@ -156,14 +165,10 @@
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam)) ; FIXME: debug
         (t
-          (let ((w (get-widget tc (cffi:make-pointer lparam))))
-            (if (null w)
-              (warn 'gfs:toolkit-warning :detail "no object for hwnd")
-              (unless (null (dispatcher w))
-                (event-select (dispatcher w)
-                              w
-                              (event-time tc)
-                              (gfs:make-rectangle))))))) ; FIXME
+          (let ((widget (get-widget tc (cffi:make-pointer lparam))))
+            (when (and widget (dispatcher widget))
+              ; (format t "wparam-hi: ~x  wparam-lo: ~x  lparam: ~x~%" wparam-hi wparam-lo lparam)
+              (dispatch-notification widget wparam-hi)))))
       (warn 'gfs:toolkit-warning :detail "no object for hwnd")))
   0)