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+)