[graphic-forms-cvs] r257 - in trunk: docs/manual src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Mon Sep 11 16:30:56 2006
New Revision: 257

Modified:
   trunk/docs/manual/event-functions.texinfo
   trunk/src/uitoolkit/graphics/graphics-context.lisp
   trunk/src/uitoolkit/system/system-utils.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
account for menu wrapping in window compute-outer-size

Modified: trunk/docs/manual/event-functions.texinfo
==============================================================================
--- trunk/docs/manual/event-functions.texinfo	(original)
+++ trunk/docs/manual/event-functions.texinfo	Mon Sep 11 16:30:56 2006
@@ -239,10 +239,10 @@
 @event-dispatcher-arg
 @item widget
 The @ref{widget} whose contents need to be repainted.
- at item gc
+ at item graphics-context
 A @ref{graphics-context} initialized for use during this paint event and
 which will be @ref{dispose}d after this method returns.
- at item rect
+ at item rectangle
 The specific @ref{rectangle} within @var{widget} needing to be repainted.
 @end table
 @end deffn

Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp	Mon Sep 11 16:30:56 2006
@@ -175,8 +175,8 @@
           (setf gfs::tablength tab-width)
           (setf gfs::leftmargin 0)
           (setf gfs::rightmargin 0)
-          (gfs::with-rect
-            (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
+          (gfs::with-rect (rect-ptr)
+            (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
             (setf (gfs:size-width sz) (- gfs::right gfs::left))
             (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))
     (when (or (zerop len) (zerop (gfs:size-height sz)))
@@ -292,7 +292,7 @@
   (let ((hdc (gfs:handle self))
         (pnt (gfs:location rect))
         (size (gfs:size rect)))
-    (gfs::with-rect
+    (gfs::with-rect (rect-ptr)
       (setf gfs::top (gfs:point-y pnt)
             gfs::left (gfs:point-x pnt)
             gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))
@@ -441,19 +441,19 @@
         (setf gfs::tablength tb-width)
         (setf gfs::leftmargin 0)
         (setf gfs::rightmargin 0)
-        (gfs::with-rect
+        (gfs::with-rect (rect-ptr)
           (setf gfs::left (gfs:point-x pnt))
           (setf gfs::top (gfs:point-y pnt))
           (gfs::draw-text-ex (gfs:handle self)
                              text
                              -1
-                             gfs::rect-ptr
+                             rect-ptr
                              (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+)))
                              dt-ptr)
           (gfs::draw-text-ex (gfs:handle self)
                              text
                              (length text)
-                             gfs::rect-ptr
+                             rect-ptr
                              flags
                              dt-ptr)
           (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))

Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp	(original)
+++ trunk/src/uitoolkit/system/system-utils.lisp	Mon Sep 11 16:30:56 2006
@@ -132,11 +132,11 @@
 ;;; convenience macros
 ;;;
 
-(defmacro with-rect (&body body)
-  `(cffi:with-foreign-object (rect-ptr 'gfs::rect)
+(defmacro with-rect ((rect-var) &body body)
+  `(cffi:with-foreign-object (,rect-var 'gfs::rect)
      (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
-                               rect-ptr gfs::rect)
-       (zero-mem rect-ptr gfs::rect)
+                               ,rect-var gfs::rect)
+       (zero-mem ,rect-var gfs::rect)
        , at body)))
 
 (defmacro with-hfont-selected ((hdc hfont) &body body)

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Mon Sep 11 16:30:56 2006
@@ -153,18 +153,29 @@
     color))
 
 (defmethod compute-outer-size ((self window) desired-client-size)
-  (let ((hwnd (gfs:handle self))
-        (new-size (gfs:make-size)))
-    (gfs::with-rect
+  (let* ((hwnd (gfs:handle self))
+         (has-menu (not (cffi:null-pointer-p (gfs::get-menu hwnd))))
+         (new-size (gfs:make-size)))
+    (gfs::with-rect (rect-ptr)
       (setf gfs::right  (gfs:size-width desired-client-size)
             gfs::bottom (gfs:size-height desired-client-size))
-      (if (zerop (gfs::adjust-window-rect gfs::rect-ptr
+      (if (zerop (gfs::adjust-window-rect rect-ptr
                                           (get-native-style self)
-                                          (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1)
+                                          (if has-menu 1 0)
                                           (get-native-exstyle self)))
         (error 'gfs:win32-error :detail "adjust-window-rect failed"))
       (setf (gfs:size-width new-size)  (- gfs::right gfs::left)
-            (gfs:size-height new-size) (- gfs::bottom gfs::top)))
+            (gfs:size-height new-size) (- gfs::bottom gfs::top))
+      ;; check how much wrapping occurs if there is a menu and we
+      ;; size a window to the above-computed width and infinite
+      ;; height
+      (when has-menu
+        (setf gfs::bottom #x7FFFFFFF) ; ensures we handle all possible menu wrap
+        (gfs::send-message hwnd gfs::+wm-nccalcsize+ 0 (cffi:pointer-address rect-ptr))
+        ;; gfs::top is now the bottom-most position of the top part of the window's
+        ;; non-client area, which is the area that the wrapped menu occupies and for
+        ;; which compensation is needed.
+        (incf (gfs:size-height new-size) gfs::top)))
     new-size))
 
 (defmethod gfs:dispose ((self window))