[graphic-forms-cvs] r403 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Nov 26 22:51:44 UTC 2006
Author: junrue
Date: Sun Nov 26 17:51:43 2006
New Revision: 403
Added:
trunk/src/uitoolkit/graphics/cursor.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
(setf cursor-of) now works; added missing source file
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Sun Nov 26 17:51:43 2006
@@ -82,8 +82,6 @@
(:file "graphics-generics")
(:file "color"
:depends-on ("graphics-classes"))
- (:file "cursor"
- :depends-on ("graphics-classes"))
(:file "palette"
:depends-on ("graphics-classes"))
(:file "image-data"
@@ -92,6 +90,8 @@
:depends-on ("graphics-classes" "graphics-generics"))
(:file "icon-bundle"
:depends-on ("graphics-constants" "image"))
+ (:file "cursor"
+ :depends-on ("graphics-classes" "image"))
(:file "font-data")
(:file "font")
(:file "graphics-context")
Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Sun Nov 26 17:51:43 2006
@@ -55,6 +55,7 @@
(assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size)))
(setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2)
(gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2))
+ (setf (gfw:cursor-of panel) (make-instance 'gfg:cursor :system gfg:+hand-cursor+))
panel))
(defun set-grid-scroll-params (window)
Added: trunk/src/uitoolkit/graphics/cursor.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/cursor.lisp Sun Nov 26 17:51:43 2006
@@ -0,0 +1,68 @@
+;;;;
+;;;; cursor.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.graphics)
+
+;;;
+;;; functions
+;;;
+
+
+;;;
+;;; methods
+;;;
+
+(defmethod gfs:dispose ((self cursor))
+ (if (gfs:disposed-p self)
+ (warn 'gfs:toolkit-warning :detail "cursor already disposed"))
+ (unless (sharedp self)
+ (gfs::destroy-cursor (gfs:handle self)))
+ (setf (slot-value self 'gfs:handle) nil))
+
+(defmethod initialize-instance :after ((self cursor) &key file hotspot image system
+ &allow-other-keys)
+ (let ((resource-id (if system (cffi:make-pointer system))))
+ (cond
+ (resource-id
+ (setf (slot-value self 'gfs:handle)
+ (gfs::load-image (cffi:null-pointer)
+ resource-id
+ gfs::+image-cursor+
+ 0 0
+ (logior gfs::+lr-defaultsize+ gfs::+lr-shared+)))
+ (setf (slot-value self 'shared) t))
+ (file
+ (let ((tmp (make-instance 'image :file file)))
+ (setf (slot-value self 'gfs:handle) (image->hicon tmp))))
+ ((typep image 'image)
+ (setf (slot-value self 'gfs:handle) (image->hicon image hotspot))))))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Nov 26 17:51:43 2006
@@ -470,6 +470,36 @@
(defconstant +hs-cross+ 4)
(defconstant +hs-diagcross+ 5)
+(defconstant +hterror+ -2)
+(defconstant +httransparent+ -1)
+(defconstant +htnowhere+ 0)
+(defconstant +htclient+ 1)
+(defconstant +htcaption+ 2)
+(defconstant +htsysmenu+ 3)
+(defconstant +htgrowbox+ 4)
+(defconstant +htsize+ 4)
+(defconstant +htmenu+ 5)
+(defconstant +hthscroll+ 6)
+(defconstant +htvscroll+ 7)
+(defconstant +htminbutton+ 8)
+(defconstant +htmaxbutton+ 9)
+(defconstant +htleft+ 10)
+(defconstant +htright+ 11)
+(defconstant +httop+ 12)
+(defconstant +httopleft+ 13)
+(defconstant +httopright+ 14)
+(defconstant +htbottom+ 15)
+(defconstant +htbottomleft+ 16)
+(defconstant +htbottomright+ 17)
+(defconstant +htborder+ 18)
+(defconstant +htreduce+ 8)
+(defconstant +htzoom+ 9)
+(defconstant +htsizefirst+ 10)
+(defconstant +htsizelast+ 17)
+(defconstant +htobject+ 19)
+(defconstant +htclose+ 20)
+(defconstant +hthelp+ 21)
+
(defconstant +icc-listview-classes+ #x00000001)
(defconstant +icc-treeview-classes+ #x00000002)
(defconstant +icc-bar-classes+ #x00000004)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Nov 26 17:51:43 2006
@@ -83,7 +83,7 @@
("ClientToScreen" client-to-screen)
BOOL
(hwnd HANDLE)
- (pnt point-pointer))
+ (pnt :pointer))
(defcfun
("CreateIconIndirect" create-icon-indirect)
@@ -388,7 +388,7 @@
(defcfun
("GetCursorPos" get-cursor-pos)
BOOL
- (pnt point-pointer))
+ (pnt :pointer))
(defcfun
("GetDC" get-dc)
@@ -665,7 +665,7 @@
("ScreenToClient" screen-to-client)
BOOL
(hwnd HANDLE)
- (pnt point-pointer))
+ (pnt :pointer))
(defcfun
("ScrollWindowEx" scroll-window)
@@ -813,4 +813,4 @@
(defcfun
("WindowFromPoint" window-from-point)
HANDLE
- (pnt point-pointer))
+ (pnt :pointer))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 26 17:51:43 2006
@@ -413,14 +413,14 @@
(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))
+ (let* ((widget (get-widget (thread-context) hwnd))
+ (cursor (slot-value widget 'cursor)))
+ (cond
+ (cursor
+ (gfs::set-cursor (gfs:handle cursor))
+ 1)
+ (t
+ (gfs::def-window-proc hwnd msg wparam lparam)))))
(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
(declare (ignore wparam))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun Nov 26 17:51:43 2006
@@ -68,7 +68,11 @@
(defun thread-context ()
(when (null *the-thread-context*)
(setf *the-thread-context* (make-instance 'thread-context))
- (init-utility-hwnd *the-thread-context*))
+ (handler-case
+ (init-utility-hwnd *the-thread-context*)
+ (win32-error (e)
+ (setf *the-thread-context* nil)
+ (format *error-output* "~a~%" e))))
*the-thread-context*)
#+(or clisp sbcl)
@@ -84,7 +88,11 @@
(when (null tc)
(setf tc (make-instance 'thread-context))
(setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)
- (init-utility-hwnd tc))
+ (handler-case
+ (init-utility-hwnd tc)
+ (win32-error (e)
+ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)
+ (format *error-output* "~a~%" e))))
tc))
#+lispworks
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sun Nov 26 17:51:43 2006
@@ -78,13 +78,9 @@
(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))))
+ (let ((capture-hwnd (gfs::get-capture)))
+ (if (or (gfs:null-handle-p capture-hwnd)
+ (cffi:pointer-eq capture-hwnd (gfs:handle widget)))
(gfs::set-cursor (gfs:handle cursor)))))
;;;
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Nov 26 17:51:43 2006
@@ -100,7 +100,8 @@
(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))))))
+ (/= (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)
+ 0)))))
(defun get-window-class-name (hwnd)
(cffi:with-foreign-pointer-as-string (str-ptr +max-classname-string-length+)
More information about the Graphic-forms-cvs
mailing list