[graphic-forms-cvs] r402 - in trunk: . docs/manual src src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Nov 26 07:12:07 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list