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

[junrue at common-lisp.net]

Author: junrue
Date: Tue May 16 12:37:07 2006
New Revision: 135

Modified:
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/widgets/dialog.lisp
   trunk/src/uitoolkit/widgets/top-level.lisp
Log:
fixed a bug in top-level initialize-instance that interfered with :text initarg; bit more work on re-enabling top-levels when modal dialog is dismissed

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Tue May 16 12:37:07 2006
@@ -80,20 +80,20 @@
   (declare (ignore disp item time rect))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
+                                              :text "Mini Frame"
                                               :style '(:miniframe))))
     (setf (gfw:location window) (gfs:make-point :x 250 :y 150))
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
-    (setf (gfw:text window) "Mini Frame")
     (gfw:show window t)))
 
 (defun create-palette-win (disp item time rect)
   (declare (ignore disp item time rect))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
+                                              :text "Palette"
                                               :style '(:palette))))
     (setf (gfw:location window) (gfs:make-point :x 250 :y 150))
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
-    (setf (gfw:text window) "Palette")
     (gfw:show window t)))
 
 (defun open-file-dlg (disp item time rect)

Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp	(original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp	Tue May 16 12:37:07 2006
@@ -51,6 +51,21 @@
                          gfs::+color-btnface+
                          +dlgwindowextra+))
 
+(defun disable-top-levels (hdlg)
+  (let ((hutility (utility-hwnd (thread-context))))
+    (setf *disabled-top-levels* nil)
+    (maptoplevels (lambda (win)
+                    (unless (or (cffi:pointer-eq (gfs:handle win) hdlg)
+                                (cffi:pointer-eq (gfs:handle win) hutility))
+                      (if (enabled-p win)
+                        (push win *disabled-top-levels*))
+                        (enable win nil))))))
+
+(defun reenable-top-levels ()
+  (loop for win in *disabled-top-levels*
+        do (enable win t))
+  (setf *disabled-top-levels* nil))
+
 ;;;
 ;;; methods
 ;;;
@@ -136,6 +151,7 @@
     (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))
 
 (defmethod gfs:dispose ((self dialog))
+  (reenable-top-levels)
   (if (visible-p self)
     (show self nil))
   (call-next-method))
@@ -163,25 +179,15 @@
   (show dlg nil))
 
 (defmethod show ((self dialog) flag)
-  (let* ((tc (thread-context))
-         (hutility (utility-hwnd tc))
-         (app-modal (find :application-modal (style-of self)))
-         (owner-modal (find :owner-modal (style-of self)))
-         (owner (owner self))
-         (hdlg (gfs:handle self)))
+  (let ((app-modal (find :application-modal (style-of self)))
+        (owner-modal (find :owner-modal (style-of self)))
+        (owner (owner self))
+        (hdlg (gfs:handle self)))
     (cond
       ((and app-modal flag)
-         (setf *disabled-top-levels* nil)
-         (maptoplevels (lambda (win)
-                         (unless (or (cffi:pointer-eq (gfs:handle win) hdlg)
-                                 (cffi:pointer-eq (gfs:handle win) hutility))
-                           (if (enabled-p win)
-                             (push win *disabled-top-levels*))
-                           (enable win nil)))))
+         (disable-top-levels hdlg))
       ((and app-modal (null flag))
-         (loop for win in *disabled-top-levels*
-               do (enable win t))
-         (setf *disabled-top-levels* nil))
+         (reenable-top-levels))
       ((and owner-modal owner)
          (enable owner (null flag))))
     (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))

Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp	(original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp	Tue May 16 12:37:07 2006
@@ -124,18 +124,18 @@
       (remove-widget (thread-context) (gfs:handle m))))
   (call-next-method))
 
-(defmethod initialize-instance :after ((win top-level) &key owner title &allow-other-keys)
+(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys)
   (unless (null owner)
     (if (gfs:disposed-p owner)
       (error 'gfs:disposed-error)))
-  (if (null title)
-    (setf title +default-window-title+))
+  (if (null text)
+    (setf text +default-window-title+))
   (let ((classname +toplevel-noerasebkgnd-window-classname+)
         (register-func #'register-toplevel-noerasebkgnd-window-class))
     (when (find :workspace (style-of win))
       (setf classname +toplevel-erasebkgnd-window-classname+)
       (setf register-func #'register-toplevel-erasebkgnd-window-class))
-    (init-window win classname register-func owner title)))
+    (init-window win classname register-func owner text)))
 
 (defmethod menu-bar :before ((win top-level))
   (if (gfs:disposed-p win)