Author: junrue Date: Sun Nov 26 02:12:03 2006 New Revision: 402
Modified: trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented cursor functionality; implemented screen/window coordinate translation
Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Sun Nov 26 02:12:03 2006 @@ -41,6 +41,15 @@ data. </description> </argument> + <argument name=":hotspot"> + <description> + A <reftopic>gfs:point</reftopic> identifying the pixel location within the + cursor image that determines which screen location is affected by mouse + events. By default, the location (0, 0) is used. For cursors loaded + via the :system initarg and cursors loaded from *.cur files, the hotspot + is predefined. + </description> + </argument> <argument name=":image"> <description> Specifies a <reftopic>gfg:image</reftopic> whose data will be copied and @@ -55,6 +64,7 @@ </argument> </initargs> <seealso> + <reftopic>gfw:with-cursor</reftopic> <reftopic>gfw:with-wait-cursor</reftopic> <reftopic>gfw:set-cursor</reftopic> <reftopic>gfw:show-cursor</reftopic>
Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sun Nov 26 02:12:03 2006 @@ -2195,12 +2195,58 @@
<!-- FUNCTIONS -->
+ <function name="obtain-pointer-location"> + <syntax> + <return> + <reftopic>gfs:point</reftopic> + </return> + </syntax> + <description> + This function returns the current location of the pointing device in + screen coordinates. + </description> + <seealso> + <reftopic>gfw:translate-point</reftopic> + </seealso> + </function> + + <function name="translate-point"> + <syntax> + <arguments> + <argument name="widget"> + <description> + The <reftopic>gfw:widget</reftopic> representing the source or + target coordinate system, depending on the value of <arg1/>. + </description> + </argument> + <argument name="system"> + <description> + One of the <refclhs>symbol</refclhs>s :display or :client to + indicate the target coordinate system. + </description> + </argument> + <argument name="point"> + <description> + The <reftopic>gfs:point</reftopic> to be converted. + </description> + </argument> + </arguments> + <return> + <reftopic>gfs:point</reftopic> + </return> + </syntax> + <description> + This function converts the coordinates specified by <arg2/> from <arg0/> + (or the display's) coordinate system to the display (or <arg0/>). + </description> + </function> + <function name="cursor-of"> <syntax with-setf="t"> <arguments> - <argument name="window"> + <argument name="widget"> <description> - The <reftopic>gfw:window</reftopic> whose cursor is to be + The <reftopic>gfw:widget</reftopic> whose cursor is to be returned (modified). </description> </argument> @@ -2210,9 +2256,12 @@ </return> </syntax> <description> - This function returns (sets) the cursor image associated with a window. The - association remains in effect until either the next call to (setf cursor) - or the assigned cursor is disposed. + This function returns (sets) the cursor image associated with a widget. For + subclasses of <reftopic>gfw:window</reftopic>, this function will always return + a cursor, although this may be the window class cursor. For non-window + objects, this function may return NIL. The SETF function will dispose the + previously-assigned cursor, if any, and then assume ownership of the new cursor. + The association remains in effect until the next call to the SETF function. </description> <seealso> <reftopic>gfw:show-cursor</reftopic> @@ -2225,12 +2274,6 @@ <function name="show-cursor"> <syntax> <arguments> - <argument name="window"> - <description> - The <reftopic>gfw:window</reftopic> whose cursor visibility - is to be modified. - </description> - </argument> <argument name="flag"> <description> A <refclhs>boolean</refclhs>; pass NIL to hide the cursor, or @@ -2243,11 +2286,11 @@ </return> </syntax> <description> - Use this function to control the visibility of the mouse cursor within - <arg0/>. The system maintains a display counter whose value must be + Use this function to control the visibility of the mouse cursor. + The system maintains a display counter whose value must be greater than 0 for the cursor to actually be visible. When <arg1/> is - NIL, then the system counter is decremented by one; when <arg1/> is - non-NIL, the system counter is incremented. + NIL, then the system counter is decremented; when <arg1/> is non-NIL, + the counter is incremented. </description> <seealso> <reftopic>gfw:cursor-of</reftopic> @@ -5978,9 +6021,9 @@ <syntax> <arguments> <notarg name="("/> - <argument name="window"> + <argument name="widget"> <description> - The <reftopic>gfw:window</reftopic> object for which the cursor + The <reftopic>gfw:widget</reftopic> object for which the cursor will be set as determined by <arg1/>. </description> </argument> @@ -5991,6 +6034,12 @@ </description> </argument> <notarg name="pathname"/> + <argument name=":hotspot"> + <description> + See <reftopic>gfg:cursor</reftopic>. + </description> + </argument> + <notarg name="point"/> <argument name=":image"> <description> See <reftopic>gfg:cursor</reftopic>. @@ -6033,9 +6082,9 @@ <syntax> <arguments> <notarg name="("/> - <argument name="window"> + <argument name="widget"> <description> - The <reftopic>gfw:window</reftopic> object for which the cursor + The <reftopic>gfw:widget</reftopic> object for which the cursor will be set as determined by <arg1/>. </description> </argument> @@ -6059,7 +6108,7 @@ to: </para> <para role="normal"> - (gfw:with-cursor (window :system gfg:+wait-cursor+) body...) + (gfw:with-cursor (widget :system gfg:+wait-cursor+) body...) </para> </description> <seealso>
Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Nov 26 02:12:03 2006 @@ -82,6 +82,8 @@ (:file "graphics-generics") (:file "color" :depends-on ("graphics-classes")) + (:file "cursor" + :depends-on ("graphics-classes")) (:file "palette" :depends-on ("graphics-classes")) (:file "image-data"
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Nov 26 02:12:03 2006 @@ -107,6 +107,7 @@
;; classes and structs #:color + #:cursor #:font #:font-data #:font-metrics @@ -391,7 +392,7 @@ #:copy-text #:cut-text #:current-font - #:cursor + #:cursor-of #:data-of #:default-message-filter #:default-widget @@ -496,6 +497,7 @@ #:obtain-displays #:obtain-event-time #:obtain-horizontal-scrollbar + #:obtain-pointer-location #:obtain-primary-display #:obtain-vertical-scrollbar #:outer-limit @@ -523,6 +525,7 @@ #:selected-p #:selected-span #:show + #:show-cursor #:show-column #:show-header #:show-item @@ -547,6 +550,7 @@ #:top-child-of #:top-index #:top-margin-of + #:translate-point #:traverse #:traverse-order #:trim-sizes
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Nov 26 02:12:03 2006 @@ -86,6 +86,13 @@ (defmacro color-table (data) `(gfg::palette-table ,data)))
+(defclass cursor (gfs:native-object) + ((shared + :reader sharedp + :initarg :shared + :initform nil)) + (:documentation "This class wraps a native cursor handle.")) + (defclass image-data-plugin (gfs:native-object) () (:documentation "Base class for image data plugin implementations."))
@@ -97,7 +104,7 @@ (:documentation "This class maintains image attributes, color, and pixel data."))
(defclass font (gfs:native-object) () - (:documentation "This class encapsulates a realized native font.")) + (:documentation "This class wraps a native font handle."))
(defclass graphics-context (gfs:native-object) ((dc-destructor
Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Nov 26 02:12:03 2006 @@ -153,12 +153,7 @@
(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) (let ((image-list nil) - (resource-id (case system - (#.+application-icon+ (cffi:make-pointer system)) - (#.+error-icon+ (cffi:make-pointer system)) - (#.+information-icon+ (cffi:make-pointer system)) - (#.+question-icon+ (cffi:make-pointer system)) - (#.+warning-icon+ (cffi:make-pointer system))))) + (resource-id (if system (cffi:make-pointer system)))) (cond (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id)))
Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Nov 26 02:12:03 2006 @@ -72,6 +72,20 @@ (ch UINT))
(defcfun + ("ChildWindowFromPointEx" child-window-from-point) + HANDLE + (hwnd HANDLE) + (pntx LONG) + (pnty LONG) + (flags UINT)) + +(defcfun + ("ClientToScreen" client-to-screen) + BOOL + (hwnd HANDLE) + (pnt point-pointer)) + +(defcfun ("CreateIconIndirect" create-icon-indirect) HANDLE (iconinfo iconinfo-pointer)) @@ -336,6 +350,10 @@ (virtkey INT))
(defcfun + ("GetCapture" get-capture) + HANDLE) + +(defcfun ("GetClassInfoExA" get-class-info) BOOL (instance HANDLE) @@ -368,6 +386,11 @@ (rct LPTR))
(defcfun + ("GetCursorPos" get-cursor-pos) + BOOL + (pnt point-pointer)) + +(defcfun ("GetDC" get-dc) HANDLE (hwnd HANDLE)) @@ -642,7 +665,7 @@ ("ScreenToClient" screen-to-client) BOOL (hwnd HANDLE) - (pnt :pointer)) + (pnt point-pointer))
(defcfun ("ScrollWindowEx" scroll-window) @@ -786,3 +809,8 @@ BOOL (hwnd HANDLE) (rct LPTR)) + +(defcfun + ("WindowFromPoint" window-from-point) + HANDLE + (pnt point-pointer))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 26 02:12:03 2006 @@ -118,7 +118,7 @@ (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget)))))
(defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (hdc (cffi:make-pointer wparam)) (bkgdcolor (brush-color-of widget)) (textcolor (text-color-of widget)) @@ -206,7 +206,7 @@ (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) (event-select (dispatcher item) item)))) - (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (let ((widget (get-widget tc (cffi:make-pointer (logand #xFFFFFFFF lparam))))) (when (and widget (dispatcher widget)) (dispatch-control-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) @@ -412,6 +412,16 @@ (declare (ignore hwnd)) (process-ctlcolor-message wparam lparam))
+(defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) + (declare (ignore hwnd lparam)) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer wparam))) + (cursor (slot-value widget 'cursor)) + (retval 0)) + (when cursor + (gfs::set-cursor (gfs:handle cursor)) + (setf retval 1)) + retval)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) @@ -452,7 +462,7 @@ (declare (ignore wparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) - (info-ptr (cffi:make-pointer lparam))) + (info-ptr (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (if (typep w 'top-level) (let ((max-size (maximum-size w)) (min-size (minimum-size w)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Nov 26 02:12:03 2006 @@ -123,7 +123,9 @@ (:documentation "This class encapsulates a scrollbar attached to a window."))
(defclass widget (event-source) - ((style + ((cursor + :initform nil) + (style :accessor style-of :initarg :style :initform nil))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Nov 26 02:12:03 2006 @@ -117,9 +117,6 @@ (defgeneric copy-text (self) (:documentation "Copies the current text selection to the clipboard."))
-(defgeneric cursor (self) - (:documentation "Returns the cursor object associated with this object.")) - (defgeneric cut-text (self) (:documentation "Copies the current text selection to the clipboard and removes it from self."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Nov 26 02:12:03 2006 @@ -104,20 +104,48 @@ (funcall start-fn) (message-loop #'default-message-filter))))
+(declaim (inline shutdown)) (defun shutdown (exit-code) (gfs::post-quit-message exit-code))
+(defun translate-point (widget system pnt) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (multiple-value-bind (ptr params) + (cffi:convert-to-foreign pnt 'gfs:point) + (ecase system + (:client (if (zerop (gfs::screen-to-client (gfs:handle widget) ptr)) + (error 'gfs:win32-error :detail "screen-to-client failed"))) + (:display (if (zerop (gfs::client-to-screen (gfs:handle widget) ptr)) + (error 'gfs::win32-error :detail "client-to-screen failed")))) + (let ((pnt (cffi:convert-from-foreign ptr 'gfs:point))) + (cffi:free-converted-object ptr 'gfs:point params) + pnt))) + +(declaim (inline show-cursor)) +(defun show-cursor (flag) + (gfs::show-cursor (if flag 1 0))) + +(defun obtain-pointer-location () + (cffi:with-foreign-object (ptr 'gfs:point) + (cffi:with-foreign-slots ((gfs::x gfs::y) ptr gfs:point) + (when (zerop (gfs::get-cursor-pos ptr)) + (warn 'gfs:win32-warning :detail "get-cursor-pos failed") + (return-from obtain-pointer-location (gfs:make-point))) + (gfs:make-point :x gfs::x :y gfs::y)))) + (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (let ((hwnd (gfs::create-window ex-style + (let ((hwnd (gfs::create-window + ex-style cname-ptr title-ptr std-style gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+ - gfs::+cw-usedefault+ + gfs::+cw-usedefault+ parent-hwnd (if (zerop (logand gfs::+ws-child+ std-style)) (cffi:null-pointer)
Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Nov 26 02:12:03 2006 @@ -62,6 +62,31 @@ (setf new-y (centered-coord-outside (gfs:point-y ancest-pnt) ancest-height desc-height))) (setf (location descendant) (gfs:make-point :x new-x :y new-y))))
+(defun cursor-of (widget) + "Return the cursor assigned to widget." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((cursor (slot-value widget 'cursor))) + (if cursor + (return-from cursor-of cursor))) + (get-window-class-cursor (gfs:handle widget))) + +(defun (setf cursor-of) (cursor widget) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((old-cursor (slot-value widget 'cursor))) + (if (and old-cursor (not (gfs:disposed-p old-cursor))) + (gfs:dispose old-cursor))) + (setf (slot-value widget 'cursor) cursor) + (let ((capture-hwnd (gfs::get-capture)) + (size (size widget)) + (pnt (obtain-pointer-location))) + (if (and (or (gfs:null-handle-p capture-hwnd) + (cffi:pointer-eq capture-hwnd (gfs:handle widget))) + (and (>= (gfs:point-x pnt) 0) (<= (gfs:point-x pnt) (gfs:size-width size))) + (and (>= (gfs:point-y pnt) 0) (<= (gfs:point-y pnt) (gfs:size-height size)))) + (gfs::set-cursor (gfs:handle cursor))))) + ;;; ;;; widget methods ;;; @@ -171,6 +196,10 @@ (error 'gfs:disposed-error)))
(defmethod gfs:dispose ((self widget)) + (if (gfs:disposed-p self) + (warn 'gfs:toolkit-warning :detail "widget already disposed")) + (unless (null (slot-value self 'cursor)) + (gfs:dispose (slot-value self 'cursor))) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self)) (let ((hwnd (gfs:handle self)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Nov 26 02:12:03 2006 @@ -33,6 +33,8 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defconstant +max-classname-string-length+ 256) + (defparameter *dialog-classname* "GraphicFormsDialog") (defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") (defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") @@ -92,7 +94,35 @@ #'child-window-visitor :stdcall))
+(defun window-class-registered-p (class-name) + (cffi:with-foreign-string (str-ptr class-name) + (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) + (cffi:with-foreign-slots ((gfs::cbsize) wc-ptr gfs::wndclassex) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) + (/= (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)))))) + +(defun get-window-class-name (hwnd) + (cffi:with-foreign-pointer-as-string (str-ptr +max-classname-string-length+) + (if (zerop (gfs::get-class-name hwnd str-ptr +max-classname-string-length+)) + (error 'gfs:win32-error :detail "get-class-name failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun get-window-class-cursor (hwnd) + (cffi:with-foreign-string (str-ptr (get-window-class-name hwnd)) + (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::hcursor) wc-ptr gfs::wndclassex) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) + (when (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) + (warn 'gfs:win32-warning :detail (format nil "class ~a not registered")) + (return-from get-window-class-cursor nil)) + (if (not (gfs::null-handle-p gfs::hcursor)) + (make-instance 'gfg:cursor :handle gfs::hcursor :shared t)))))) + (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) + (if (window-class-registered-p class-name) + (return-from register-window-class 1)) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -101,32 +131,29 @@ gfs::hicon gfs::hcursor gfs::hbrush gfs::menuname gfs::classname gfs::smallicon) wc-ptr gfs::wndclassex) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) - str-ptr wc-ptr)) - (progn - (setf gfs::style style) - (setf gfs::wndproc proc-ptr) - (setf gfs::clsextra 0) - (setf gfs::wndextra (or wndextra 0)) - (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer))) - (setf gfs::hicon (cffi:null-pointer)) - (setf gfs::hcursor (gfs::load-image (cffi:null-pointer) - (cffi:make-pointer gfs::+ocr-normal+) - gfs::+image-cursor+ 0 0 - (logior gfs::+lr-defaultcolor+ - gfs::+lr-shared+))) - (setf gfs::hbrush (if (< bkgcolor 0) - (cffi:null-pointer) - (cffi:make-pointer (1+ bkgcolor)))) - (setf gfs::menuname (cffi:null-pointer)) - (setf gfs::classname str-ptr) - (setf gfs::smallicon (cffi:null-pointer)) - (setf retval (gfs::register-class wc-ptr))) - (setf retval 1)) - (if (/= retval 0) - retval - (error 'gfs::win32-error :detail "register-class failed"))))))) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex) + gfs::style style + gfs::wndproc proc-ptr + gfs::clsextra 0 + gfs::wndextra (or wndextra 0) + gfs::hinst (gfs::get-module-handle (cffi:null-pointer)) + gfs::hicon (cffi:null-pointer) + gfs::hcursor (gfs::load-image (cffi:null-pointer) + (cffi:make-pointer gfs::+ocr-normal+) + gfs::+image-cursor+ 0 0 + (logior gfs::+lr-defaultcolor+ + gfs::+lr-shared+)) + gfs::hbrush (if (< bkgcolor 0) + (cffi:null-pointer) + (cffi:make-pointer (1+ bkgcolor))) + gfs::menuname (cffi:null-pointer) + gfs::classname str-ptr + gfs::smallicon (cffi:null-pointer)) + (setf retval (gfs::register-class wc-ptr))))) + (if (/= retval 0) + retval + (error 'gfs::win32-error :detail "register-class failed"))))
(defun capture-mouse (self) (if (gfs:disposed-p self) @@ -161,14 +188,12 @@ ;;; methods ;;;
-(defmethod gfg:background-color ((win window)) - (let ((hwnd (gfs:handle win)) +(defmethod gfg:background-color ((self window)) + (let ((hwnd (gfs:handle self)) (color nil)) - (cffi:with-foreign-pointer-as-string (str-ptr 64) - (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) - (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) - (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) + (if (string= (get-window-class-name self) *toplevel-erasebkgnd-window-classname*) + (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) + (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+)))) color))
(defmethod compute-outer-size ((self window) desired-client-size)