[graphic-forms-cvs] r436 - in trunk: . src/uitoolkit/graphics src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sat Mar 17 12:12:49 2007
New Revision: 436

Modified:
   trunk/NEWS.txt
   trunk/src/uitoolkit/graphics/graphics-classes.lisp
   trunk/src/uitoolkit/graphics/graphics-context.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
graphics-context clear now works for widgets and images, added surface-size slot

Modified: trunk/NEWS.txt
==============================================================================
--- trunk/NEWS.txt	(original)
+++ trunk/NEWS.txt	Sat Mar 17 12:12:49 2007
@@ -1,4 +1,8 @@
 
+. Latest CFFI is required to take advantage of newly-added support for the
+  stdcall calling convention (FIXME: change checked in this past Feb., need
+  to narrow down which snapshot actually has it).
+
 . Greatly expanded the symbols for accessing predefined colors, and now
   provide access to system color settings in a similar manner.
 

Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp	Sat Mar 17 12:12:49 2007
@@ -1,7 +1,7 @@
 ;;;;
 ;;;; graphics-classes.lisp
 ;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
 ;;;; All rights reserved.
 ;;;;
 ;;;; Redistribution and use in source and binary forms, with or without
@@ -113,6 +113,10 @@
    (widget-handle
     :accessor widget-handle-of
     :initform nil)
+   (surface-size
+    :accessor surface-size-of
+    :initarg :surface-size
+    :initform nil)
    (logbrush-style
     :accessor logbrush-style-of
     :initform gfs::+bs-solid+)

Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp	Sat Mar 17 12:12:49 2007
@@ -1,7 +1,7 @@
 ;;;;
 ;;;; graphics-context.lisp
 ;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
 ;;;; All rights reserved.
 ;;;;
 ;;;; Redistribution and use in source and binary forms, with or without
@@ -224,22 +224,16 @@
     (error 'gfs:disposed-error))
   (setf (background-color self) color
         (foreground-color self) color)
-  (let* ((hdc (gfs:handle self))
-         (hwnd (gfs::window-from-dc hdc)))
-    (if (gfs:null-handle-p hwnd)
-      (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC")
-      (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
-        (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom)
-                                  wi-ptr gfs::windowinfo)
-          (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
-          (if (zerop (gfs::get-window-info hwnd wi-ptr))
-            (warn 'gfs:win32-warning :detail "get-window-info failed")
-            (gfs::with-rect (rect-ptr)
-              (setf gfs::top    0
-                    gfs::left   0
-                    gfs::bottom gfs::clientbottom
-                    gfs::right  gfs::clientright)
-              (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer)))))))))
+  (let ((hdc (gfs:handle self))
+        (size (surface-size-of self)))
+    (if size
+      (gfs::with-rect (rect-ptr)
+        (setf gfs::top    0
+              gfs::left   0
+              gfs::right  (gfs:size-width size)
+              gfs::bottom (gfs:size-height size))
+        (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer)))
+      (warn 'gfs:toolkit-warning :detail "null surface size"))))
 
 (defmethod gfs:dispose ((self graphics-context))
   (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+))
@@ -250,6 +244,7 @@
       (if (null (widget-handle-of self))
         (funcall fn (gfs:handle self))
         (funcall fn (widget-handle-of self) (gfs:handle self)))))
+  (setf (surface-size-of self) nil)
   (setf (widget-handle-of self) nil)
   (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
 
@@ -483,9 +478,11 @@
         (progn
           (setf hdc (gfs::get-dc (gfs:handle widget)))
           (setf (dc-destructor-of self) #'gfs::release-dc)
-          (setf (widget-handle-of self) (gfs:handle widget))))
+          (setf (widget-handle-of self) (gfs:handle widget))
+          (setf (surface-size-of self) (gfw:client-size widget))))
       (setf (slot-value self 'gfs:handle) hdc)
       (unless (null image)
+        (setf (surface-size-of self) (gfg:size image))
         (gfs::select-object hdc (gfs:handle image)))))
   ;; ensure world-to-device transformation conformance
   (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sat Mar 17 12:12:49 2007
@@ -410,6 +410,7 @@
                 (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y))
                 (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height))
                 (disp (dispatcher widget)))
+            (setf (gfg::surface-size-of gc) (client-size widget))
             (unwind-protect
                 (let ((parent (gfw:parent widget)))
                   (when (and parent (typep (dispatcher parent) 'scrolling-helper))