November 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r407 - trunk/src/tests/uitoolkit
by junrue＠common-lisp.net 30 Nov '06

30 Nov '06

Author: junrue Date: Wed Nov 29 22:16:44 2006 New Revision: 407 Added: trunk/src/tests/uitoolkit/custom.cur (contents, props changed) Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Log: added test for loading and using cursor from file Added: trunk/src/tests/uitoolkit/custom.cur ============================================================================== Binary file. No diff available. 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 Wed Nov 29 22:16:44 2006 @@ -46,6 +46,7 @@ (declare (ignore disp item))) (defun make-scroll-grid-panel (parent) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)) :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))) (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) @@ -55,7 +56,9 @@ (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+)) + (setf (gfw:cursor-of panel) + (make-instance 'gfg:cursor + :file (merge-pathnames "custom.cur"))) panel)) (defun set-grid-scroll-params (window)

1 0

[graphic-forms-cvs] r406 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Nov '06

29 Nov '06

Author: junrue Date: Wed Nov 29 13:51:06 2006 New Revision: 406 Modified: trunk/src/uitoolkit/widgets/widget.lisp Log: fixed a regression in (setf cursor-of) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Nov 29 13:51:06 2006 @@ -81,7 +81,9 @@ (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))))) + (if cursor + (gfs::set-cursor (gfs:handle cursor)) + (gfs::set-cursor (cffi:null-pointer)))))) (defmacro with-cursor ((widget &key file hotspot image system) &body body) (lispworks:with-unique-names (old new retval)

1 0

[graphic-forms-cvs] r405 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Nov '06

29 Nov '06

Author: junrue Date: Wed Nov 29 13:23:14 2006 New Revision: 405 Added: trunk/src/uitoolkit/system/metrics.lisp Modified: trunk/NEWS.txt trunk/docs/manual/clhs-table.xml trunk/docs/manual/gf-data.xsl trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented obtain-system-metrics Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Nov 29 13:23:14 2006 @@ -4,8 +4,13 @@ macros GFW:WITH-CURSOR and GFW:WITH-WAIT-CURSOR. . Implemented a new layout manager called GFW:BORDER-LAYOUT which allows - applications to assign children to 5 possible regions, identified by - :top, :left, :right, :bottom, or :center. + applications to assign children to regions around the perimeter of a + window or the center. + +. Implemented GFS:OBTAIN-SYSTEM-METRICS as a higher-level interface to the + Win32 GetSystemMetrics() API. It returns a hash table that applications + may cache if desired, and collapses certain related metrics values for + easier access. . Implemented the function GFW:PROCESS-EVENTS to help applications flush the event queue of pending events. Modified: trunk/docs/manual/clhs-table.xml ============================================================================== --- trunk/docs/manual/clhs-table.xml (original) +++ trunk/docs/manual/clhs-table.xml Wed Nov 29 13:23:14 2006 @@ -12,11 +12,13 @@ <entry name="error" url="http://www.lispworks.com/documentation/HyperSpec/Body/e_error.htm"/> <entry name="float" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_float.htm"/> <entry name="format" url="http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm"/> + <entry name="hash-table" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_hash_t.htm"/> <entry name="integer" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm"/> <entry name="list" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_list.htm"/> <entry name="namestring" url="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_n.htm#namestri…"/> <entry name="pathname" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_pn.htm"/> <entry name="string" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_string.htm"/> <entry name="symbol" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_symbol.htm"/> + <entry name="values" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_values.htm"/> <entry name="warning" url="http://www.lispworks.com/documentation/HyperSpec/Body/e_warnin.htm"/> </clhs-table> Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Wed Nov 29 13:23:14 2006 @@ -17,11 +17,7 @@ <xsl:variable name="clhs-table" select="document('clhs-table.xml')"/> <xsl:template name="emit-index-term"> - <xsl:element name="indexterm"> - <xsl:element name="primary"> - <xsl:value-of select="@name"/> - </xsl:element> - </xsl:element> + <indexterm><primary><xsl:value-of select="@name"/></primary></indexterm> </xsl:template> <xsl:template name="emit-page-type"> Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Wed Nov 29 13:23:14 2006 @@ -9,9 +9,9 @@ <description> The symbols in this package correspond to system-level functionality, - such as foreign function declarations for the Win32 API. The majority - of symbols in this package are not exported, except for the - fundamental types, conditions, and functions listed below. + including CFFI declarations for functions and data types. Additional + symbols represent key classes, functions, and conditions. + The majority of Graphic-Forms is built on top of this package. </description>  @@ -301,6 +301,275 @@  + <function name="obtain-system-metrics"> + <syntax> + <return> + <refclhs>hash-table</refclhs> + </return> + </syntax> + <description> + <para role="normal"> + This function returns a table of system metrics: + </para> + <enum> + <argument name=":arrangement"> + <description> + A <refclhs>list</refclhs> specifying how minimized windows + are arranged. The first element is a <refclhs>symbol</refclhs> indicating + the starting position: + <enum> + <argument name=":bottom-left"/> + <argument name=":bottom-right"/> + <argument name=":hide"/> + <argument name=":top-left"/> + <argument name=":top-right"/> + </enum> + The second element indicates the direction: + <enum> + <argument name=":horizontal"/> + <argument name=":vertical"/> + </enum> + </description> + </argument> + <argument name=":boot-mode"> + <description> + A <refclhs>symbol</refclhs> describing how the system was started: + <enum> + <argument name=":fail-safe"/> + <argument name=":fail-safe-no-network"/> + <argument name=":normal"/> + </enum> + </description> + </argument> + <argument name=":border-sizes"> + <description> + A <refclhs>list</refclhs> of <reftopic>gfs:size</reftopic> objects + describing the thickness of a window border in pixels. The first + element corresponds to windows with the 3D look, whereas the second + element describes windows with non-3D borders. + </description> + </argument> + <argument name=":button-count"> + <description> + An <refclhs>integer</refclhs> indicating the number of mouse + buttons, or zero if no mouse is installed. + </description> + </argument> + <argument name=":buttons-swapped"> + <description> + T if the meaning of the left and right mouse buttons are swapped; + NIL otherwise. + </description> + </argument> + <argument name=":caption-button-sizes"> + <description> + A <refclhs>list</refclhs> whose first element is a + <reftopic>gfs:size</reftopic> describing the size of a + normal (default) caption button. The second element is a + <reftopic>gfs:size</reftopic> for the small caption + button type. + </description> + </argument> + <argument name=":cursor-size"> + <description> + A <reftopic>gfs:size</reftopic> describing the dimensions of a cursor + image in pixels. + </description> + </argument> + <argument name=":dbcs-enabled"> + <description> + T if the installed user32.dll supports DBCS; NIL otherwise. + </description> + </argument> + <argument name=":debug-version"> + <description> + T if the debug version of user32.dll is installed; NIL otherwise. + </description> + </argument> + <argument name=":display-count"> + <description> + An <refclhs>integer</refclhs> describing the number of display + monitors on the desktop. + </description> + </argument> + <argument name=":display-sizes"> + <description> + A <refclhs>list</refclhs> whose first element is a + <reftopic>gfs:size</reftopic> describing the total dimensions of + the primary display including the taskbar area. The second element + is a <reftopic>gfs:size</reftopic> that excludes the taskbar area. + </description> + </argument> + <argument name=":double-click-size"> + <description> + A <reftopic>gfs:size</reftopic> indicating the area surrounding the + initial click of a double-click gesture. + </description> + </argument> + <argument name=":drag-size"> + <description> + A <reftopic>gfs:size</reftopic> indicating the area surrounding the + initial click of a drag gesture. + </description> + </argument> + <argument name=":focus-size"> + <description> + A <reftopic>gfs:size</reftopic> indicating the thickness in pixels + of the edges of the focus rectangle. + </description> + </argument> + <argument name=":frame-sizes"> + <description> + A <refclhs>list</refclhs> whose first element is a + <reftopic>gfs:size</reftopic> describing the thickness of a + resizable window's border in pixels. The second element is + a <reftopic>gfs:size</reftopic> indicating the thickness of + a fixed frame. + </description> + </argument> + <argument name=":icon-sizes"> + <description> + A <refclhs>list</refclhs> whose first element is a + <reftopic>gfs:size</reftopic> describing the size of a + normal (default) icon. The second element is a + <reftopic>gfs:size</reftopic> for the small icon type. + </description> + </argument> + <argument name=":icon-spacing"> + <description> + A <reftopic>gfs:size</reftopic> describing the width and height of + a grid cell for items in a large icon view; these values will be + greater than or equal to the large icon size. + </description> + </argument> + <argument name=":ime-enabled"> + <description> + T if Input Method Manager / Input Method Editor features are + enabled; NIL otherwise. + </description> + </argument> + <argument name=":low-end-processor"> + <description> + T if the system has determined that the CPU meets criteria associated + with a low-end (slow) model. + </description> + </argument> + <argument name=":media-center"> + <description> + T if the installed system is Media Center Edition; NIL otherwise. + </description> + </argument> + <argument name=":menu-button-size"> + <description> + A <reftopic>gfs:size</reftopic> describing the size of menubar buttons + in pixels. + </description> + </argument> + <argument name=":menu-check-size"> + <description> + A <reftopic>gfs:size</reftopic> describing the size of the default + menu checkmark in pixels. + </description> + </argument> + <argument name=":menu-drop-alignment"> + <description> + The <refclhs>symbol</refclhs> :right if menus are right-aligned with + the corresponding menubar item, or :left if menus are left-aligned. + </description> + </argument> + <argument name=":mideast-enabled"> + <description> + T if the system is configured to support Hebrew and Arabic languages; + NIL otherwise. + </description> + </argument> + <argument name=":minimized-window-spacing"> + <description> + A <reftopic>gfs:size</reftopic> describing the dimensions of a minimized + window in pixels. + </description> + </argument> + <argument name=":mouse-wheel"> + <description> + T if a mouse with a wheel is installed; NIL otherwise. + </description> + </argument> + <argument name=":notify-visually"> + <description> + T if the user requires applications to provide visual notification + in situations where only an audible notification would normally occur. + </description> + </argument> + <argument name=":pen-extensions"> + <description> + T if the Windows for Pen extensions are installed; NIL otherwise. + </description> + </argument> + <argument name=":remote-session"> + <description> + T if the calling process is associated with a Terminal Services client + session; NIL otherwise. + </description> + </argument> + <argument name=":remotely-controlled"> + <description> + T if the current session is remotely controlled (in a Terminal Services + environment); NIL otherwise. + </description> + </argument> + <argument name=":same-display-format"> + <description> + T if all displays use the same color encoding; NIL otherwise. + </description> + </argument> + <argument name=":scrollbar-dimensions"> + <description> + A <reftopic>gfs:size</reftopic> indicating the width of a vertical + scrollbar and the height of a horizontal scrollbar. + </description> + </argument> + <argument name=":scrollbar-arrow-dimensions"> + <description> + A <reftopic>gfs:size</reftopic> describing the width of a vertical + scrollbar's arrow bitmap and the height of a horizontal scrollbar's + arrow bitmap. + </description> + </argument> + <argument name=":shutting-down"> + <description> + T if the current session is shutting down; NIL otherwise. + </description> + </argument> + <argument name=":tablet-pc"> + <description> + T if the system is Windows XP Tablet PC edition; NIL otherwise. + </description> + </argument> + <argument name=":tracking-sizes"> + <description> + A <refclhs>list</refclhs> containing <reftopic>gfs:size</reftopic> + objects for the minimum and maximum supported window border tracking + sizes. + </description> + </argument> + <argument name=":window-sizes"> + <description> + A <refclhs>list</refclhs> containing <reftopic>gfs:size</reftopic> + objects for window extremums in the following order: + <emphasis>full screen</emphasis>, <emphasis>maximized</emphasis>, + <emphasis>minimized</emphasis>, and <emphasis>minimum allowed</emphasis>. + </description> + </argument> + <argument name=":virtual-display-size"> + <description> + A <reftopic>gfs:size</reftopic> describing the width and height of + the bounding rectangle of all display monitors. + </description> + </argument> + </enum> + </description> + </function> + <function name="make-point"> <syntax> <arguments> Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Nov 29 13:23:14 2006 @@ -6043,8 +6043,8 @@ <notarg name="("/> <argument name="widget"> <description> - The <reftopic>gfw:widget</reftopic> object for which the cursor - will be set as determined by <arg1/>. + The <reftopic>gfw:widget</reftopic> object for which a cursor + will be set. </description> </argument> <notarg name="&key"/> @@ -6104,8 +6104,8 @@ <notarg name="("/> <argument name="widget"> <description> - The <reftopic>gfw:widget</reftopic> object for which the cursor - will be set as determined by <arg1/>. + The <reftopic>gfw:widget</reftopic> object for which the wait + cursor will be set. </description> </argument> <notarg name=")"/> @@ -6122,7 +6122,7 @@ </syntax> <description> <para role="normal"> - This macro temporarily sets the wait cursor in <arg0/> + This macro temporarily sets the standard wait cursor in <arg0/> for the duration of <arg1/>. The previous cursor set in <arg0/> is restored afterwards. Use of this macro is equivalent to: Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Nov 29 13:23:14 2006 @@ -72,6 +72,7 @@ (:file "gdi32") (:file "kernel32") (:file "user32") + (:file "metrics") (:file "native-object") (:file "system-utils"))) (:module "graphics" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Nov 29 13:23:14 2006 @@ -77,6 +77,7 @@ #:make-size #:make-span #:null-handle-p + #:obtain-system-metrics #:point-x #:point-y #:point-z Added: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/metrics.lisp Wed Nov 29 13:23:14 2006 @@ -0,0 +1,383 @@ +;;;; +;;;; metrics.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.system) + +(defun obtain-system-metrics () + "Query system metrics and return them via a hash table." + (let ((table (make-hash-table))) + ;; + ;; :arrangement + ;; + ;; A two-valued result describing the starting position and direction + ;; of minimized windows." + ;; + (setf (gethash :arrangement table) + (let ((metric (get-system-metrics +sm-arrange+)) + (topright-bits (logior +arw-startright+ +arw-starttop+))) + (list (cond + ((= (logand metric topright-bits) topright-bits) + :top-right) + ((= (logand metric +arw-starttop+) +arw-starttop+) + :top-left) + ((= (logand metric +arw-startright+) +arw-startright+) + :bottom-right) + ((= (logand metric +arw-hide+) +arw-hide+) + :hide) + (t + :bottom-left)) + (if (= (logand metric +arw-up+) +arw-up+) + :vertical + :horizontal)))) + ;; + ;; :boot-mode + ;; + ;; A keyword symbol describing how the system was started. + ;; + (setf (gethash :boot-mode table) + (case (get-system-metrics +sm-cleanboot+) + (0 :normal) + (1 :fail-safe) + (2 :fail-safe-no-network) + (otherwise :unknown))) + ;; + ;; :border-sizes + ;; + ;; The thickness of resizable and fixes window borders in pixels. + ;; + (setf (gethash :border-sizes table) + (list (make-size :width (get-system-metrics +sm-cxedge+) + :height (get-system-metrics +sm-cyedge+)) + (make-size :width (get-system-metrics +sm-cxborder+) + :height (get-system-metrics +sm-cyborder+)))) + ;; + ;; :button-count + ;; + ;; The number of mouse buttons, or zero if no mouse is installed. + ;; + (setf (gethash :button-count table) + (get-system-metrics +sm-cmousebuttons+)) + ;; + ;; :buttons-swapped + ;; + ;; T if the meaning of the left and right mouse buttons are swapped; + ;; NIL otherwise. + ;; + (setf (gethash :buttons-swapped table) + (/= (get-system-metrics +sm-swapbutton+) 0)) + ;; + ;; :caption-button-sizes + ;; + ;; A list of the sizes of a button in a window's caption or title bar in pixels. + ;; + (setf (gethash :caption-button-sizes table) + (list (make-size :width (get-system-metrics +sm-cxsize+) + :height (get-system-metrics +sm-cysize+)) + (make-size :width (get-system-metrics +sm-cxsmsize+) + :height (get-system-metrics +sm-cysmsize+)))) + ;; + ;; :cursor-size + ;; + ;; The size of the cursor image in pixels. + ;; + (setf (gethash :cursor-size table) + (make-size :width (get-system-metrics +sm-cxcursor+) + :height (get-system-metrics +sm-cycursor+))) + ;; + ;; :dbcs-enabled + ;; + ;; T if user32.dll supports DBCS; NIL otherwise. + ;; + (setf (gethash :dbcs-enabled table) + (/= (get-system-metrics +sm-dbcsenabled+) 0)) + ;; + ;; :debug-version + ;; + ;; T if the debug version of user32.dll is installed; NIL otherwise. + ;; + (setf (gethash :debug-version table) + (/= (get-system-metrics +sm-debug+) 0)) + ;; + ;; :display-count + ;; + ;; A count of the display monitors on the desktop. + ;; + (setf (gethash :display-count table) + (get-system-metrics +sm-cmonitors+)) + ;; + ;; :display-sizes + ;; + ;; A list containing two sizes of the display (with and without the taskbar). + ;; + (setf (gethash :display-sizes table) + (list (make-size :width (get-system-metrics +sm-cxscreen+) + :height (get-system-metrics +sm-cyscreen+)) + (cffi:with-foreign-object (rect-ptr 'rect) + (if (zerop (system-parameters-info +spi-getworkarea+ 0 rect-ptr 0)) + (error 'win32-error :detail "system-parameters-info failed")) + (let ((tmp (cffi:convert-from-foreign rect-ptr 'rect-pointer))) + (size tmp))))) + ;; + ;; :double-click-size + ;; + ;; The size in pixels of the area surrounding a first click in a double-click sequence. + ;; + (setf (gethash :double-click-size table) + (make-size :width (get-system-metrics +sm-cxdoubleclk+) + :height (get-system-metrics +sm-cydoubleclk+))) + ;; + ;; :drag-size + ;; + ;; The size in pixels of the area surrounding the start of a drag gesture. + ;; + (setf (gethash :drag-size table) + (make-size :width (get-system-metrics +sm-cxdrag+) + :height (get-system-metrics +sm-cydrag+))) + ;; + ;; :frame-sizes + ;; + ;; The thickness of a fixed border (or dialog border) in pixels. + ;; + (setf (gethash :frame-sizes table) + (list (make-size :width (get-system-metrics +sm-cxframe+) + :height (get-system-metrics +sm-cyframe+)) + (make-size :width (get-system-metrics +sm-cxdlgframe+) + :height (get-system-metrics +sm-cydlgframe+)))) + ;; + ;; :focus-size + ;; + ;; The thickness in pixels of the edges of the focus rectangle. + ;; + (setf (gethash :focus-size table) + (make-size :width (get-system-metrics +sm-cxfocusborder+) + :height (get-system-metrics +sm-cyfocusborder+))) + ;; + ;; :icon-sizes + ;; + ;; The default and small sizes of an icon in pixels. + ;; + (setf (gethash :icon-sizes table) + (list (make-size :width (get-system-metrics +sm-cxicon+) + :height (get-system-metrics +sm-cyicon+)) + (make-size :width (get-system-metrics +sm-cxsmicon+) + :height (get-system-metrics +sm-cysmicon+)))) + ;; + ;; :icon-spacing + ;; + ;; The width and height of a grid cell for items in a large icon view; + ;; these values will be greater than or equal to the large icon size. + ;; + (setf (gethash :icon-spacing table) + (make-size :width (get-system-metrics +sm-cxiconspacing+) + :height (get-system-metrics +sm-cyiconspacing+))) + ;; + ;; :ime-enabled + ;; + ;; T if Input Method Manager/Input Method Editor features are + ;; enabled; NIL otherwise. + ;; + (setf (gethash :ime-enabled table) + (/= (get-system-metrics +sm-immenabled+) 0)) + ;; + ;; :low-end-processor + ;; + ;; T if the system has determined that the CPU meets criteria associated + ;; with a low-end (slow) model. + ;; + (setf (gethash :low-end-processor table) + (/= (get-system-metrics +sm-slowmachine+) 0)) + ;; + ;; :media-center + ;; + ;; T if the installed system is Media Center Edition; NIL otherwise. + ;; + (setf (gethash :media-center table) + (/= (get-system-metrics +sm-mediacenter+) 0)) + ;; + ;; :menu-button-size + ;; + ;; The size of menubar buttons in pixels. + ;; + (setf (gethash :menu-button-size table) + (make-size :width (get-system-metrics +sm-cxmenusize+) + :height (get-system-metrics +sm-cymenusize+))) + ;; + ;; :menu-check-size + ;; + ;; The size of the default menu checkmark image in pixels. + ;; + (setf (gethash :menu-check-size table) + (make-size :width (get-system-metrics +sm-cxmenucheck+) + :height (get-system-metrics +sm-cymenucheck+))) + ;; + ;; :menu-drop-alignment + ;; + ;; Value is :right if menus are right-aligned with the corresponding menubar + ;; item, or :left if menus are left-aligned. + ;; + (setf (gethash :menu-drop-alignment table) + (if (zerop (get-system-metrics +sm-menudropalignment+)) :left :right)) + ;; + ;; :mideast-enabled + ;; + ;; T if the system is c0nfigured to support Hebrew and Arabic languages; NIL + ;; otherwise. + ;; + (setf (gethash :mideast-enabled table) + (/= (get-system-metrics +sm-mideastenabled+) 0)) + ;; + ;; :minimized-window-size + ;; + ;; The size of a minimized window in pixels. + ;; + (setf (gethash :minimized-window-size table) + (make-size :width (get-system-metrics +sm-cxminimized+) + :height (get-system-metrics +sm-cyminimized+))) + ;; + ;; :minimized-window-spacing + ;; + ;; The width and height of a grid cell for a minimized window in pixels. + ;; + (setf (gethash :minimized-window-spacing table) + (make-size :width (get-system-metrics +sm-cxminspacing+) + :height (get-system-metrics +sm-cyminspacing+))) + ;; + ;; :mouse-wheel + ;; + ;; T if a mouse with a wheel is installed; NIL otherwise. + ;; + (setf (gethash :mouse-wheel table) + (/= (get-system-metrics +sm-mousewheelpresent+) 0)) + ;; + ;; :notify-visually + ;; + ;; T if the user requires applications to provide visual notification + ;; in situations where only an audible notification would normally occur. + ;; + (setf (gethash :notify-visually table) + (/= (get-system-metrics +sm-showsounds+) 0)) + ;; + ;; :pen-extensions + ;; + ;; T if the Windows for Pen extensions are installed; NIL otherwise. + ;; + (setf (gethash :pen-extensions table) + (/= (get-system-metrics +sm-penwindows+) 0)) + ;; + ;; :remote-session + ;; + ;; T if the calling process is associated with a Terminal Services client + ;; session; NIL otherwise. + ;; + (setf (gethash :remote-session table) + (/= (get-system-metrics +sm-remotesession+) 0)) + ;; + ;; :remotely-controlled + ;; + ;; T if the current session is remotely controlled (in a Terminal Services + ;; environment); NIL otherwise. + ;; + (setf (gethash :remotely-controlled table) + (/= (get-system-metrics +sm-remotecontrol+) 0)) + ;; + ;; :same-display-format + ;; + ;; T if all displays use the same color encoding; NIL otherwise. + ;; + (setf (gethash :same-display-format table) + (/= (get-system-metrics +sm-samedisplayformat+) 0)) + ;; + ;; :scrollbar-dimensions + ;; + ;; The width of a vertical scrollbar and the height of a horizontal scrollbar. + ;; + (setf (gethash :scrollbar-dimensions table) + (make-size :width (get-system-metrics +sm-cxvscroll+) + :height (get-system-metrics +sm-cyhscroll+))) + ;; + ;; :scrollbar-arrow-dimensions + ;; + ;; The width of a vertical scrollbar's arrow bitmap and the height of a + ;; horizontal-scrollbar's arrow bitmap. + ;; + (setf (gethash :scrollbar-arrow-dimensions table) + (make-size :width (get-system-metrics +sm-cxhscroll+) + :height (get-system-metrics +sm-cyvscroll+))) + ;; + ;; :shutting-down + ;; + ;; T if the current session is shutting down; NIL otherwise. + ;; + (setf (gethash :shutting-down table) + (/= (get-system-metrics +sm-shuttingdown+) 0)) + ;; + ;; :tablet-pc + ;; + ;; T if the system is Windows XP Tablet PC edition; NIL otherwise. + ;; + (setf (gethash :tablet-pc table) + (/= (get-system-metrics +sm-tabletpc+) 0)) + ;; + ;; :tracking-sizes + ;; + ;; The minimum and maximum sizes to which a window can be dragged. + ;; + (setf (gethash :tracking-sizes table) + (list (make-size :width (get-system-metrics +sm-cxmintrack+) + :height (get-system-metrics +sm-cymintrack+)) + (make-size :width (get-system-metrics +sm-cxmaxtrack+) + :height (get-system-metrics +sm-cymaxtrack+)))) + ;; + ;; :virtual-display-size + ;; + ;; The size of the bounding rectangle for all displays. + ;; + (setf (gethash :virtual-display-size table) + (make-size :width (get-system-metrics +sm-cxvirtualscreen+) + :height (get-system-metrics +sm-cyvirtualscreen+))) + ;; + ;; :window-sizes + ;; + ;; A list of size objects representing various window extremums. + ;; + (setf (gethash :window-sizes table) + (list (make-size :width (get-system-metrics +sm-cxfullscreen+) + :height (get-system-metrics +sm-cyfullscreen+)) + (make-size :width (get-system-metrics +sm-cxmaximized+) + :height (get-system-metrics +sm-cymaximized+)) + (make-size :width (get-system-metrics +sm-cxminimized+) + :height (get-system-metrics +sm-cyminimized+)) + (make-size :width (get-system-metrics +sm-cxmin+) + :height (get-system-metrics +sm-cymin+)))) + + table)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Nov 29 13:23:14 2006 @@ -52,6 +52,20 @@ (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) +(defconstant +arw-bottomleft+ #x0000) +(defconstant +arw-bottomright+ #x0001) +(defconstant +arw-topleft+ #x0002) +(defconstant +arw-topright+ #x0003) +(defconstant +arw-startmask+ #x0003) +(defconstant +arw-startright+ #x0001) +(defconstant +arw-starttop+ #x0002) + +(defconstant +arw-left+ #x0000) +(defconstant +arw-right+ #x0000) +(defconstant +arw-up+ #x0004) +(defconstant +arw-down+ #x0004) +(defconstant +arw-hide+ #x0008) + (defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) (defconstant +bi-rle4+ 2) @@ -895,18 +909,18 @@ (defconstant +ps-insideframe+ 6) (defconstant +ps-userstyle+ 7) (defconstant +ps-alternate+ 8) -(defconstant +ps-style-mask+ #x0000000f) +(defconstant +ps-style-mask+ #x0000000F) (defconstant +ps-endcap-round+ #x00000000) (defconstant +ps-endcap-square+ #x00000100) (defconstant +ps-endcap-flat+ #x00000200) -(defconstant +ps-endcap-mask+ #x00000f00) +(defconstant +ps-endcap-mask+ #x00000F00) (defconstant +ps-join-round+ #x00000000) (defconstant +ps-join-bevel+ #x00001000) (defconstant +ps-join-miter+ #x00002000) -(defconstant +ps-join-mask+ #x0000f000) +(defconstant +ps-join-mask+ #x0000F000) (defconstant +ps-cosmetic+ #x00000000) (defconstant +ps-geometric+ #x00010000) -(defconstant +ps-type-mask+ #x000f0000) +(defconstant +ps-type-mask+ #x000F0000) (defconstant +sb-horz+ 0) (defconstant +sb-vert+ 1) @@ -1048,6 +1062,178 @@ (defconstant +sm-remotecontrol+ #x2001) (defconstant +sm-caretblinkingenabled+ #x2002) +(defconstant +spi-getbeep+ #x0001) +(defconstant +spi-setbeep+ #x0002) +(defconstant +spi-getmouse+ #x0003) +(defconstant +spi-setmouse+ #x0004) +(defconstant +spi-getborder+ #x0005) +(defconstant +spi-setborder+ #x0006) +(defconstant +spi-getkeyboardspeed+ #x000A) +(defconstant +spi-setkeyboardspeed+ #x000B) +(defconstant +spi-langdriver+ #x000C) +(defconstant +spi-iconhorizontalspacing+ #x000D) +(defconstant +spi-getscreensavetimeout+ #x000E) +(defconstant +spi-setscreensavetimeout+ #x000F) +(defconstant +spi-getscreensaveactive+ #x0010) +(defconstant +spi-setscreensaveactive+ #x0011) +(defconstant +spi-getgridgranularity+ #x0012) +(defconstant +spi-setgridgranularity+ #x0013) +(defconstant +spi-setdeskwallpaper+ #x0014) +(defconstant +spi-setdeskpattern+ #x0015) +(defconstant +spi-getkeyboarddelay+ #x0016) +(defconstant +spi-setkeyboarddelay+ #x0017) +(defconstant +spi-iconverticalspacing+ #x0018) +(defconstant +spi-geticontitlewrap+ #x0019) +(defconstant +spi-seticontitlewrap+ #x001A) +(defconstant +spi-getmenudropalignment+ #x001B) +(defconstant +spi-setmenudropalignment+ #x001C) +(defconstant +spi-setdoubleclkwidth+ #x001D) +(defconstant +spi-setdoubleclkheight+ #x001E) +(defconstant +spi-geticontitlelogfont+ #x001F) +(defconstant +spi-setdoubleclicktime+ #x0020) +(defconstant +spi-setmousebuttonswap+ #x0021) +(defconstant +spi-seticontitlelogfont+ #x0022) +(defconstant +spi-getfasttaskswitch+ #x0023) +(defconstant +spi-setfasttaskswitch+ #x0024) +(defconstant +spi-setdragfullwindows+ #x0025) +(defconstant +spi-getdragfullwindows+ #x0026) +(defconstant +spi-getnonclientmetrics+ #x0029) +(defconstant +spi-setnonclientmetrics+ #x002A) +(defconstant +spi-getminimizedmetrics+ #x002B) +(defconstant +spi-setminimizedmetrics+ #x002C) +(defconstant +spi-geticonmetrics+ #x002D) +(defconstant +spi-seticonmetrics+ #x002E) +(defconstant +spi-setworkarea+ #x002F) +(defconstant +spi-getworkarea+ #x0030) +(defconstant +spi-setpenwindows+ #x0031) +(defconstant +spi-gethighcontrast+ #x0042) +(defconstant +spi-sethighcontrast+ #x0043) +(defconstant +spi-getkeyboardpref+ #x0044) +(defconstant +spi-setkeyboardpref+ #x0045) +(defconstant +spi-getscreenreader+ #x0046) +(defconstant +spi-setscreenreader+ #x0047) +(defconstant +spi-getanimation+ #x0048) +(defconstant +spi-setanimation+ #x0049) +(defconstant +spi-getfontsmoothing+ #x004A) +(defconstant +spi-setfontsmoothing+ #x004B) +(defconstant +spi-setdragwidth+ #x004C) +(defconstant +spi-setdragheight+ #x004D) +(defconstant +spi-sethandheld+ #x004E) +(defconstant +spi-getlowpowertimeout+ #x004F) +(defconstant +spi-getpowerofftimeout+ #x0050) +(defconstant +spi-setlowpowertimeout+ #x0051) +(defconstant +spi-setpowerofftimeout+ #x0052) +(defconstant +spi-getlowpoweractive+ #x0053) +(defconstant +spi-getpoweroffactive+ #x0054) +(defconstant +spi-setlowpoweractive+ #x0055) +(defconstant +spi-setpoweroffactive+ #x0056) +(defconstant +spi-setcursors+ #x0057) +(defconstant +spi-seticons+ #x0058) +(defconstant +spi-getdefaultinputlang+ #x0059) +(defconstant +spi-setdefaultinputlang+ #x005A) +(defconstant +spi-setlangtoggle+ #x005B) +(defconstant +spi-getwindowsextension+ #x005C) +(defconstant +spi-setmousetrails+ #x005D) +(defconstant +spi-getmousetrails+ #x005E) +(defconstant +spi-setscreensaverrunning+ #x0061) +(defconstant +spi-screensaverrunning+ #x0061) +(defconstant +spi-getfilterkeys+ #x0032) +(defconstant +spi-setfilterkeys+ #x0033) +(defconstant +spi-gettogglekeys+ #x0034) +(defconstant +spi-settogglekeys+ #x0035) +(defconstant +spi-getmousekeys+ #x0036) +(defconstant +spi-setmousekeys+ #x0037) +(defconstant +spi-getshowsounds+ #x0038) +(defconstant +spi-setshowsounds+ #x0039) +(defconstant +spi-getstickykeys+ #x003A) +(defconstant +spi-setstickykeys+ #x003B) +(defconstant +spi-getaccesstimeout+ #x003C) +(defconstant +spi-setaccesstimeout+ #x003D) +(defconstant +spi-getserialkeys+ #x003E) +(defconstant +spi-setserialkeys+ #x003F) +(defconstant +spi-getsoundsentry+ #x0040) +(defconstant +spi-setsoundsentry+ #x0041) +(defconstant +spi-getsnaptodefbutton+ #x005F) +(defconstant +spi-setsnaptodefbutton+ #x0060) +(defconstant +spi-getmousehoverwidth+ #x0062) +(defconstant +spi-setmousehoverwidth+ #x0063) +(defconstant +spi-getmousehoverheight+ #x0064) +(defconstant +spi-setmousehoverheight+ #x0065) +(defconstant +spi-getmousehovertime+ #x0066) +(defconstant +spi-setmousehovertime+ #x0067) +(defconstant +spi-getwheelscrolllines+ #x0068) +(defconstant +spi-setwheelscrolllines+ #x0069) +(defconstant +spi-getmenushowdelay+ #x006A) +(defconstant +spi-setmenushowdelay+ #x006B) +(defconstant +spi-getshowimeui+ #x006E) +(defconstant +spi-setshowimeui+ #x006F) +(defconstant +spi-getmousespeed+ #x0070) +(defconstant +spi-setmousespeed+ #x0071) +(defconstant +spi-getscreensaverrunning+ #x0072) +(defconstant +spi-getdeskwallpaper+ #x0073) +(defconstant +spi-getactivewindowtracking+ #x1000) +(defconstant +spi-setactivewindowtracking+ #x1001) +(defconstant +spi-getmenuanimation+ #x1002) +(defconstant +spi-setmenuanimation+ #x1003) +(defconstant +spi-getcomboboxanimation+ #x1004) +(defconstant +spi-setcomboboxanimation+ #x1005) +(defconstant +spi-getlistboxsmoothscrolling+ #x1006) +(defconstant +spi-setlistboxsmoothscrolling+ #x1007) +(defconstant +spi-getgradientcaptions+ #x1008) +(defconstant +spi-setgradientcaptions+ #x1009) +(defconstant +spi-getkeyboardcues+ #x100A) +(defconstant +spi-setkeyboardcues+ #x100B) +(defconstant +spi-getmenuunderlines+ #x100A) +(defconstant +spi-setmenuunderlines+ #x100B) +(defconstant +spi-getactivewndtrkzorder+ #x100C) +(defconstant +spi-setactivewndtrkzorder+ #x100D) +(defconstant +spi-gethottracking+ #x100E) +(defconstant +spi-sethottracking+ #x100F) +(defconstant +spi-getmenufade+ #x1012) +(defconstant +spi-setmenufade+ #x1013) +(defconstant +spi-getselectionfade+ #x1014) +(defconstant +spi-setselectionfade+ #x1015) +(defconstant +spi-gettooltipanimation+ #x1016) +(defconstant +spi-settooltipanimation+ #x1017) +(defconstant +spi-gettooltipfade+ #x1018) +(defconstant +spi-settooltipfade+ #x1019) +(defconstant +spi-getcursorshadow+ #x101A) +(defconstant +spi-setcursorshadow+ #x101B) +(defconstant +spi-getmousesonar+ #x101C) +(defconstant +spi-setmousesonar+ #x101D) +(defconstant +spi-getmouseclicklock+ #x101E) +(defconstant +spi-setmouseclicklock+ #x101F) +(defconstant +spi-getmousevanish+ #x1020) +(defconstant +spi-setmousevanish+ #x1021) +(defconstant +spi-getflatmenu+ #x1022) +(defconstant +spi-setflatmenu+ #x1023) +(defconstant +spi-getdropshadow+ #x1024) +(defconstant +spi-setdropshadow+ #x1025) +(defconstant +spi-getblocksendinputresets+ #x1026) +(defconstant +spi-setblocksendinputresets+ #x1027) +(defconstant +spi-getuieffects+ #x103E) +(defconstant +spi-setuieffects+ #x103F) +(defconstant +spi-getforegroundlocktimeout+ #x2000) +(defconstant +spi-setforegroundlocktimeout+ #x2001) +(defconstant +spi-getactivewndtrktimeout+ #x2002) +(defconstant +spi-setactivewndtrktimeout+ #x2003) +(defconstant +spi-getforegroundflashcount+ #x2004) +(defconstant +spi-setforegroundflashcount+ #x2005) +(defconstant +spi-getcaretwidth+ #x2006) +(defconstant +spi-setcaretwidth+ #x2007) +(defconstant +spi-getmouseclicklocktime+ #x2008) +(defconstant +spi-setmouseclicklocktime+ #x2009) +(defconstant +spi-getfontsmoothingtype+ #x200A) +(defconstant +spi-setfontsmoothingtype+ #x200B) +(defconstant +spi-getfontsmoothingcontrast+ #x200C) +(defconstant +spi-setfontsmoothingcontrast+ #x200D) +(defconstant +spi-getfocusborderwidth+ #x200E) +(defconstant +spi-setfocusborderwidth+ #x200F) +(defconstant +spi-getfocusborderheight+ #x2010) +(defconstant +spi-setfocusborderheight+ #x2011) +(defconstant +spi-getfontsmoothingorientation+ #x2012) +(defconstant +spi-setfontsmoothingorientation+ #x2013) + (defconstant +ss-left+ #x00000000) (defconstant +ss-center+ #x00000001) (defconstant +ss-right+ #x00000002) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed Nov 29 13:23:14 2006 @@ -785,6 +785,14 @@ (cmd INT)) (defcfun + ("SystemParametersInfoA" system-parameters-info) + BOOL + (action UINT) + (iparam UINT) + (vparam LPTR) + (ini UINT)) + +(defcfun ("TrackPopupMenuEx" track-popup-menu) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Nov 29 13:23:14 2006 @@ -97,8 +97,7 @@ (process-events) (unwind-protect (setf ,retval (progn ,@body)) - (setf (slot-value ,widget 'cursor) ,old) - (gfs:dispose ,new)) + (setf (cursor-of ,widget) ,old)) ,retval))) (defmacro with-wait-cursor ((widget) &body body)

1 0

[graphic-forms-cvs] r404 - in trunk: . docs/manual src src/demos/textedit src/uitoolkit/widgets
by junrue＠common-lisp.net 27 Nov '06

27 Nov '06

Author: junrue Date: Mon Nov 27 02:18:14 2006 New Revision: 404 Modified: trunk/NEWS.txt trunk/docs/manual/gfw-symbols.xml trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented with-cursor/with-wait-cursor macros; implemented process-events function; textedit demo now uses wait cursor when loading or saving files Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 27 02:18:14 2006 @@ -1,8 +1,14 @@ +. Implemented cursor support. Applications can choose from the system-defined + cursors or load them from external files. Also provided are convenience + macros GFW:WITH-CURSOR and GFW:WITH-WAIT-CURSOR. + +. Implemented a new layout manager called GFW:BORDER-LAYOUT which allows + applications to assign children to 5 possible regions, identified by + :top, :left, :right, :bottom, or :center. -. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns - children to 5 possible regions identified by :top, :left, :right, - :bottom, or :center. +. Implemented the function GFW:PROCESS-EVENTS to help applications flush + the event queue of pending events. . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 27 02:18:14 2006 @@ -2195,6 +2195,22 @@  + <function name="process-events"> + <syntax> + <return> + <emphasis>undefined</emphasis> + </return> + </syntax> + <description> + Call this function to processing pending events until the event queue + is empty. + </description> + <seealso> + <reftopic>gfw:default-message-filter</reftopic> + <reftopic>gfw:message-loop</reftopic> + </seealso> + </function> + <function name="obtain-pointer-location"> <syntax> <return> @@ -2462,6 +2478,9 @@ it is passed to <reftopic>gfw:message-loop</reftopic>. </para> </description> + <seealso> + <reftopic>gfw:process-events</reftopic> + </seealso> </function> <function name="message-loop"> @@ -2487,6 +2506,7 @@ </description> <seealso> <reftopic>gfw:default-message-filter</reftopic> + <reftopic>gfw:process-events</reftopic> </seealso> </function> Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Nov 27 02:18:14 2006 @@ -62,13 +62,15 @@ paths :filters *textedit-file-filters*) (when paths - (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (gfw:with-wait-cursor (*textedit-win*) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths)))) (setf (file-path-of *textedit-model*) (namestring (first paths))) (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) (if (file-path-of *textedit-model*) - (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) + (gfw:with-wait-cursor (*textedit-win*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*))) (textedit-file-save-as disp item)) (if (file-path-of *textedit-model*) (setf (gfw:text-modified-p *textedit-control*) nil))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 27 02:18:14 2006 @@ -561,11 +561,13 @@ #:visible-item-count #:visible-p #:with-color-dialog + #:with-cursor #:with-drawing-disabled #:with-file-dialog #:with-font-dialog #:with-graphics-context #:with-root-window + #:with-wait-cursor ;; conditions )) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Nov 27 02:18:14 2006 @@ -68,13 +68,23 @@ ;;; (defun message-loop (msg-filter) + (push msg-filter (message-filters (thread-context))) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg) (when (funcall msg-filter gm msg-ptr) + (pop (message-filters (thread-context))) (return-from message-loop gfs::wparam))))))) +(defun process-events () + (let ((filter (first (message-filters (thread-context))))) + (unless filter + (return-from process-events nil)) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) + (loop until (zerop (gfs::peek-message msg-ptr (cffi:null-pointer) 0 0 gfs::+pm-remove+)) + do (funcall filter 1 msg-ptr))))) + (defun key-down-p (key-code) "Return T if the key corresponding to key-code is currently down." (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Nov 27 02:18:14 2006 @@ -42,6 +42,7 @@ (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) (items-by-id :initform (make-hash-table :test #'equal)) + (message-filters :initform nil :accessor message-filters) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) @@ -70,7 +71,7 @@ (setf *the-thread-context* (make-instance 'thread-context)) (handler-case (init-utility-hwnd *the-thread-context*) - (win32-error (e) + (gfs:win32-error (e) (setf *the-thread-context* nil) (format *error-output* "~a~%" e)))) *the-thread-context*) @@ -90,7 +91,7 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) (handler-case (init-utility-hwnd tc) - (win32-error (e) + (gfs:win32-error (e) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil) (format *error-output* "~a~%" e)))) tc)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Nov 27 02:18:14 2006 @@ -104,7 +104,6 @@ (funcall start-fn) (message-loop #'default-message-filter)))) -(declaim (inline shutdown)) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Nov 27 02:18:14 2006 @@ -83,6 +83,27 @@ (cffi:pointer-eq capture-hwnd (gfs:handle widget))) (gfs::set-cursor (gfs:handle cursor))))) +(defmacro with-cursor ((widget &key file hotspot image system) &body body) + (lispworks:with-unique-names (old new retval) + `(let ((,old (slot-value ,widget 'cursor)) + (,new (make-instance 'gfg:cursor + :file ,file + :hotspot ,hotspot + :image ,image + :system ,system)) + (,retval nil)) + (setf (slot-value ,widget 'cursor) nil) + (setf (cursor-of ,widget) ,new) + (process-events) + (unwind-protect + (setf ,retval (progn ,@body)) + (setf (slot-value ,widget 'cursor) ,old) + (gfs:dispose ,new)) + ,retval))) + +(defmacro with-wait-cursor ((widget) &body body) + `(with-cursor (,widget :system gfg:+wait-cursor+) + ,@body)) ;;; ;;; widget methods ;;; Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Nov 27 02:18:14 2006 @@ -116,7 +116,8 @@ (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")) + (warn 'gfs:win32-warning + :detail (format nil "class ~a not registered" (get-window-class-name hwnd))) (return-from get-window-class-cursor nil)) (if (not (gfs::null-handle-p gfs::hcursor)) (make-instance 'gfg:cursor :handle gfs::hcursor :shared t))))))

1 0

[graphic-forms-cvs] r403 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Nov '06

26 Nov '06

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

1 0

[graphic-forms-cvs] r402 - in trunk: . docs/manual src src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Nov '06

26 Nov '06

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

1 0

[graphic-forms-cvs] r401 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/default src/uitoolkit/widgets
by junrue＠common-lisp.net 24 Nov '06

24 Nov '06

Author: junrue Date: Fri Nov 24 17:44:47 2006 New Revision: 401 Modified: trunk/docs/manual/constants.xml trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: cursor documentation Modified: trunk/docs/manual/constants.xml ============================================================================== --- trunk/docs/manual/constants.xml (original) +++ trunk/docs/manual/constants.xml Fri Nov 24 17:44:47 2006 @@ -8,15 +8,21 @@ <indexterm><primary>constants</primary></indexterm> <para role="normal"> - This section lists the symbols for constants and variables exported from - each package. + This section lists the symbols for the constants and variables that help + comprise the public API. </para> - <bridgehead renderas="sect2">Character Sets [GFG]</bridgehead> - - <informaltable frame="none"> + <bridgehead renderas="sect2"> + Character Sets [GFG] <anchor id="character sets"/> <indexterm><primary>character sets</primary></indexterm> + </bridgehead> + + <para role="normal"> + Character set constants to be used when requesting fonts. + </para> + + <informaltable frame="none"> <tgroup cols="1"> <tbody> <row><entry><para role="normal">+ansi-charset+</para></entry></row> @@ -43,11 +49,17 @@ </tgroup> </informaltable> - <bridgehead renderas="sect2">Standard Colors [GFG]</bridgehead> - - <informaltable frame="none"> + <bridgehead renderas="sect2"> + Standard Colors [GFG] <anchor id="colors"/> <indexterm><primary>colors</primary></indexterm> + </bridgehead> + + <para role="normal"> + Predefined color constants. + </para> + + <informaltable frame="none"> <tgroup cols="1"> <tbody> <row><entry><para role="normal">*color-black*</para></entry></row> @@ -59,11 +71,48 @@ </tgroup> </informaltable> - <bridgehead renderas="sect2">System Icons [GFG]</bridgehead> + <bridgehead renderas="sect2"> + System Cursors [GFG] + <indexterm><primary>system cursors</primary></indexterm> + <anchor id="system cursors"/> + </bridgehead> + + <para role="normal"> + Constants identifying predefined cursors. + </para> <informaltable frame="none"> + <tgroup cols="1"> + <tbody> + <row><entry><para role="normal">+app-starting-cursor+</para></entry></row> + <row><entry><para role="normal">+crosshair-cursor+</para></entry></row> + <row><entry><para role="normal">+default-cursor+</para></entry></row> + <row><entry><para role="normal">+hand-cursor+</para></entry></row> + <row><entry><para role="normal">+help-cursor+</para></entry></row> + <row><entry><para role="normal">+ibeam-cursor+</para></entry></row> + <row><entry><para role="normal">+no-cursor+</para></entry></row> + <row><entry><para role="normal">+size-all-cursor+</para></entry></row> + <row><entry><para role="normal">+size-nesw-cursor+</para></entry></row> + <row><entry><para role="normal">+size-ns-cursor+</para></entry></row> + <row><entry><para role="normal">+size-nwse-cursor+</para></entry></row> + <row><entry><para role="normal">+size-we-cursor+</para></entry></row> + <row><entry><para role="normal">+up-arrow-cursor+</para></entry></row> + <row><entry><para role="normal">+wait-cursor+</para></entry></row> + </tbody> + </tgroup> + </informaltable> + + <bridgehead renderas="sect2"> + System Icons [GFG] <anchor id="system icons"/> <indexterm><primary>system icons</primary></indexterm> + </bridgehead> + + <para role="normal"> + Constants identifying predefined icons. + </para> + + <informaltable frame="none"> <tgroup cols="1"> <tbody> <row><entry><para role="normal">+application-icon+</para></entry></row> @@ -75,11 +124,17 @@ </tgroup> </informaltable> - <bridgehead renderas="sect2">Virtual Key Codes [GFW]</bridgehead> - - <informaltable frame="none"> + <bridgehead renderas="sect2"> + Virtual Key Codes [GFW] <anchor id="virtual key codes"/> <indexterm><primary>virtual key codes</primary></indexterm> + </bridgehead> + + <para role="normal"> + Device-independent keyboard codes. + </para> + + <informaltable frame="none"> <tgroup cols="1"> <tbody> <row><entry><para role="normal">+vk-break+</para></entry></row> @@ -146,6 +201,25 @@ </tgroup> </informaltable> + <bridgehead renderas="sect2"> + Widget Defaults [GFW] + <anchor id="widget defaults"/> + <indexterm><primary>widget defaults</primary></indexterm> + </bridgehead> + + <para role="normal"> + Constants providing defaults for various widget attributes such as size. + </para> + + <informaltable frame="none"> + <tgroup cols="1"> + <tbody> + <row><entry><para role="normal">+default-widget-height+</para></entry></row> + <row><entry><para role="normal">+default-widget-width+</para></entry></row> + </tbody> + </tgroup> + </informaltable> + <para role="normal"/> </chapter> Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Fri Nov 24 17:44:47 2006 @@ -17,6 +17,51 @@  + <class name="cursor"> + <description> + <hierarchy> + <inherits> + <reftopic>gfs:native-object</reftopic> + </inherits> + </hierarchy> + This class encapsulates a native cursor handle. A cursor is an image whose + screen location is determined by a pointing device; when the user moves the + pointing device, the system changes the location of the cursor image to + match. + </description> + <initargs> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + <argument name=":file"> + <description> + Specifies a <refclhs>pathname</refclhs> for a file containing cursor image + data. + </description> + </argument> + <argument name=":image"> + <description> + Specifies a <reftopic>gfg:image</reftopic> whose data will be copied and + transformed into a cursor. + </description> + </argument> + <argument name=":system"> + <description> + Identifies the cursor to be displayed. See <reftopic>system cursors</reftopic> + for a list of cursor identifiers. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfw:with-wait-cursor</reftopic> + <reftopic>gfw:set-cursor</reftopic> + <reftopic>gfw:show-cursor</reftopic> + <reftopic>gfw:cursor-of</reftopic> + </seealso> + </class> + <class name="font"> <description> <hierarchy> @@ -778,6 +823,7 @@ If <arg2/> and <arg3/> are the same, a complete ellipse is drawn. </description> <seealso> + <reftopic>colors</reftopic> <reftopic>gfg:draw-pie-wedge</reftopic> <reftopic>gfg:draw-filled-pie-wedge</reftopic> <reftopic>gfg:foreground-color</reftopic> @@ -1696,6 +1742,7 @@ interior of closed shapes. </description> <seealso> + <reftopic>colors</reftopic> <reftopic>gfg:foreground-color</reftopic> <reftopic>gfg:graphics-context</reftopic> </seealso> Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Fri Nov 24 17:44:47 2006 @@ -433,6 +433,7 @@ <function name="create-rectangle"> <syntax> <arguments> + <notarg name="&key"/> <argument name=":x"> <description> An <refclhs>integer</refclhs> specifying the X coordinate of the Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 24 17:44:47 2006 @@ -2195,7 +2195,7 @@  - <function name="cursor"> + <function name="cursor-of"> <syntax with-setf="t"> <arguments> <argument name="window"> @@ -2206,18 +2206,19 @@ </argument> </arguments> <return> - <reftopic>gfw:cursor</reftopic> + <reftopic>gfg:cursor</reftopic> </return> </syntax> <description> - This function returns (sets) the cursor associated with a window. Such - an association remains in effect until either the next call to the - SETF function or the assigned cursor is disposed. + 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. </description> <seealso> <reftopic>gfw:show-cursor</reftopic> <reftopic>gfw:with-cursor</reftopic> <reftopic>gfw:with-wait-cursor</reftopic> + <reftopic>gfg:cursor</reftopic> </seealso> </function> @@ -2249,9 +2250,10 @@ non-NIL, the system counter is incremented. </description> <seealso> - <reftopic>gfw:cursor</reftopic> + <reftopic>gfw:cursor-of</reftopic> <reftopic>gfw:with-cursor</reftopic> <reftopic>gfw:with-wait-cursor</reftopic> + <reftopic>gfg:cursor</reftopic> </seealso> </function> @@ -5982,12 +5984,25 @@ will be set as determined by <arg1/>. </description> </argument> - <argument name="cursor-id"> + <notarg name="&key"/> + <argument name=":file"> + <description> + See <reftopic>gfg:cursor</reftopic>. + </description> + </argument> + <notarg name="pathname"/> + <argument name=":image"> + <description> + See <reftopic>gfg:cursor</reftopic>. + </description> + </argument> + <notarg name="gfg:image"/> + <argument name=":system"> <description> - Identifies the cursor to be displayed. See <reftopic>gfw:cursor</reftopic> - for details on what values may be specified for this argument. + See <reftopic>gfg:cursor</reftopic>. </description> </argument> + <notarg name="integer"/> <notarg name=")"/> <notarg name="&body"/> <argument name="body"> @@ -6001,14 +6016,16 @@ </return> </syntax> <description> - This macro temporarily sets the cursor specified by <arg1/> in <arg0/> + This macro temporarily sets a cursor in <arg0/> for the duration of <arg2/>. The previous cursor set in <arg0/> is restored afterwards. </description> <seealso> + <reftopic>system cursors</reftopic> <reftopic>gfw:with-wait-cursor</reftopic> - <reftopic>gfw:set-cursor</reftopic> <reftopic>gfw:show-cursor</reftopic> + <reftopic>gfw:cursor-of</reftopic> + <reftopic>gfg:cursor</reftopic> </seealso> </macro> @@ -6035,14 +6052,22 @@ </return> </syntax> <description> - This macro temporarily sets the wait cursor in <arg0/> - for the duration of <arg1/>. The previous cursor set in - <arg0/> is restored afterwards. + <para role="normal"> + This macro temporarily sets the wait cursor in <arg0/> + for the duration of <arg1/>. The previous cursor set in + <arg0/> is restored afterwards. Use of this macro is equivalent + to: + </para> + <para role="normal"> + (gfw:with-cursor (window :system gfg:+wait-cursor+) body...) + </para> </description> <seealso> + <reftopic>system cursors</reftopic> <reftopic>gfw:with-cursor</reftopic> - <reftopic>gfw:set-cursor</reftopic> <reftopic>gfw:show-cursor</reftopic> + <reftopic>gfw:cursor-of</reftopic> + <reftopic>gfg:cursor</reftopic> </seealso> </macro> Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Nov 24 17:44:47 2006 @@ -126,10 +126,24 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+app-starting-cursor+ #:+application-icon+ + #:+crosshair-cursor+ + #:+default-cursor+ #:+error-icon+ + #:+hand-cursor+ + #:+help-cursor+ + #:+ibeam-cursor+ #:+information-icon+ + #:+no-cursor+ #:+question-icon+ + #:+size-all-cursor+ + #:+size-nesw-cursor+ + #:+size-ns-cursor+ + #:+size-nwse-cursor+ + #:+size-we-cursor+ + #:+up-arrow-cursor+ + #:+wait-cursor+ #:+warning-icon+ ;; methods, functions, macros @@ -275,6 +289,8 @@ #:window ;; constants + #:+default-widget-height+ + #:+default-widget-width+ #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Fri Nov 24 17:44:47 2006 @@ -33,12 +33,12 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defvar *image-win* nil) -(defvar *happy-image* nil) -(defvar *bw-image* nil) -(defvar *comp-image* nil) -(defvar *folder-image* nil) -(defvar *true-image* nil) +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *comp-image* nil) +(defvar *folder-image* nil) +(defvar *true-image* nil) (defclass image-events (gfw:event-dispatcher) ()) @@ -95,18 +95,14 @@ (defun load-images () (let ((*default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))) - (setf *happy-image* (make-instance 'gfg:image)) - (gfg::load *happy-image* "happy.bmp") - (setf *bw-image* (make-instance 'gfg:image)) - (gfg::load *bw-image* "blackwhite20x16.bmp") - (setf *true-image* (make-instance 'gfg:image)) - (gfg::load *true-image* "truecolor16x16.bmp") + (setf *happy-image* (make-instance 'gfg:image :file "happy.bmp") + *bw-image* (make-instance 'gfg:image :file "blackwhite20x16.bmp") + *true-image* (make-instance 'gfg:image :file "truecolor16x16.bmp")) + #+load-imagemagick-plugin (progn - (setf *folder-image* (make-instance 'gfg:image)) - (gfg::load *folder-image* "open-folder.gif") - (setf *comp-image* (make-instance 'gfg:image)) - (gfg::load *comp-image* "computer.png")))) + (setf *folder-image* (make-instance 'gfg:image :file "open-folder.gif") + *comp-image* (make-instance 'gfg:image :file "computer.png"))))) (defun image-tester-internal () (load-images) @@ -118,7 +114,8 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) - (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) + (setf (gfw:image *image-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Fri Nov 24 17:44:47 2006 @@ -67,3 +67,23 @@ (defconstant +information-icon+ 32516) (defconstant +question-icon+ 32514) (defconstant +warning-icon+ 32515) + + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an image. +;;; +(defconstant +app-starting-cursor+ gfs::+ocr-appstarting+) +(defconstant +crosshair-cursor+ gfs::+ocr-cross+) +(defconstant +default-cursor+ gfs::+ocr-normal+) +(defconstant +hand-cursor+ gfs::+ocr-hand+) +(defconstant +help-cursor+ 32651) +(defconstant +ibeam-cursor+ gfs::+ocr-ibeam+) +(defconstant +no-cursor+ gfs::+ocr-no+) +(defconstant +size-all-cursor+ gfs::+ocr-sizeall+) +(defconstant +size-nesw-cursor+ gfs::+ocr-sizenesw+) +(defconstant +size-ns-cursor+ gfs::+ocr-sizens+) +(defconstant +size-nwse-cursor+ gfs::+ocr-sizenwse+) +(defconstant +size-we-cursor+ gfs::+ocr-sizewe+) +(defconstant +up-arrow-cursor+ gfs::+ocr-up+) +(defconstant +wait-cursor+ gfs::+ocr-wait+) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Fri Nov 24 17:44:47 2006 @@ -158,8 +158,7 @@ (#.+error-icon+ (cffi:make-pointer system)) (#.+information-icon+ (cffi:make-pointer system)) (#.+question-icon+ (cffi:make-pointer system)) - (#.+warning-icon+ (cffi:make-pointer system)) - (otherwise nil)))) + (#.+warning-icon+ (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/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Nov 24 17:44:47 2006 @@ -44,7 +44,8 @@ ;; this extant in the world, so add more as needed) ;; (defvar *image-file-types* (let ((table (make-hash-table :test #'equal))) - (loop for (key value) in '(("bmp" "Microsoft Windows bitmap") + (loop for (key value) in '(("ani" "Microsoft Windows animated cursor") + ("bmp" "Microsoft Windows bitmap") ("cur" "Microsoft Windows cursor") ("dib" "Microsoft Windows device-independent bitmap") ("emf" "Microsoft Windows Enhanced Metafile") Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Fri Nov 24 17:44:47 2006 @@ -108,6 +108,7 @@ (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) + ((string-equal file-type "cur") #'load-icon-data) (t (return-from loader nil))))) (with-open-file (stream path :element-type '(unsigned-byte 8)) (funcall helper stream)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Nov 24 17:44:47 2006 @@ -33,9 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defclass cursor (gfs:native-object) () - (:documentation "The cursor class represents the sprite controlled by the pointing device.")) - (defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system."))

1 0

[graphic-forms-cvs] r400 - in trunk: docs/manual src/tests/mcclim src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 24 Nov '06

24 Nov '06

Author: junrue Date: Fri Nov 24 02:01:22 2006 New Revision: 400 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/tests/mcclim/hello-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: initial work on cursor support Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 24 02:01:22 2006 @@ -2195,6 +2195,66 @@  + <function name="cursor"> + <syntax with-setf="t"> + <arguments> + <argument name="window"> + <description> + The <reftopic>gfw:window</reftopic> whose cursor is to be + returned (modified). + </description> + </argument> + </arguments> + <return> + <reftopic>gfw:cursor</reftopic> + </return> + </syntax> + <description> + This function returns (sets) the cursor associated with a window. Such + an association remains in effect until either the next call to the + SETF function or the assigned cursor is disposed. + </description> + <seealso> + <reftopic>gfw:show-cursor</reftopic> + <reftopic>gfw:with-cursor</reftopic> + <reftopic>gfw:with-wait-cursor</reftopic> + </seealso> + </function> + + <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 + non-NIL to make the cursor visible. + </description> + </argument> + </arguments> + <return> + <emphasis>undefined</emphasis> + </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 + 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. + </description> + <seealso> + <reftopic>gfw:cursor</reftopic> + <reftopic>gfw:with-cursor</reftopic> + <reftopic>gfw:with-wait-cursor</reftopic> + </seealso> + </function> + <function name="startup"> <syntax> <arguments> @@ -5912,6 +5972,80 @@  + <macro name="with-cursor"> + <syntax> + <arguments> + <notarg name="("/> + <argument name="window"> + <description> + The <reftopic>gfw:window</reftopic> object for which the cursor + will be set as determined by <arg1/>. + </description> + </argument> + <argument name="cursor-id"> + <description> + Identifies the cursor to be displayed. See <reftopic>gfw:cursor</reftopic> + for details on what values may be specified for this argument. + </description> + </argument> + <notarg name=")"/> + <notarg name="&body"/> + <argument name="body"> + <description> + Application code. + </description> + </argument> + </arguments> + <return> + <emphasis>results</emphasis> + </return> + </syntax> + <description> + This macro temporarily sets the cursor specified by <arg1/> in <arg0/> + for the duration of <arg2/>. The previous cursor set in + <arg0/> is restored afterwards. + </description> + <seealso> + <reftopic>gfw:with-wait-cursor</reftopic> + <reftopic>gfw:set-cursor</reftopic> + <reftopic>gfw:show-cursor</reftopic> + </seealso> + </macro> + + <macro name="with-wait-cursor"> + <syntax> + <arguments> + <notarg name="("/> + <argument name="window"> + <description> + The <reftopic>gfw:window</reftopic> object for which the cursor + will be set as determined by <arg1/>. + </description> + </argument> + <notarg name=")"/> + <notarg name="&body"/> + <argument name="body"> + <description> + Application code. + </description> + </argument> + </arguments> + <return> + <emphasis>results</emphasis> + </return> + </syntax> + <description> + This macro temporarily sets the wait cursor in <arg0/> + for the duration of <arg1/>. The previous cursor set in + <arg0/> is restored afterwards. + </description> + <seealso> + <reftopic>gfw:with-cursor</reftopic> + <reftopic>gfw:set-cursor</reftopic> + <reftopic>gfw:show-cursor</reftopic> + </seealso> + </macro> + <macro name="with-color-dialog"> <syntax> <arguments> Modified: trunk/src/tests/mcclim/hello-tester.lisp ============================================================================== --- trunk/src/tests/mcclim/hello-tester.lisp (original) +++ trunk/src/tests/mcclim/hello-tester.lisp Fri Nov 24 02:01:22 2006 @@ -13,11 +13,11 @@ (:fill some-pane))))) (define-command com-hello () - (clim-graphic-forms::debug-print "com-hello called ") + #+graphic-forms (gfs::debug-print "com-hello called ") (setf (message *application-frame*) "Hello there!")) (define-command com-hi () - (clim-graphic-forms::debug-print "com-hi called ") + #+graphic-forms (gfs::debug-print "com-hi called ") (setf (message *application-frame*) "Hi there!")) (define-command-table menu-command-table @@ -33,5 +33,5 @@ (frame-exit *application-frame*)) (defmethod display-some-pane ((frame hello-frame) stream) - (clim-graphic-forms::debug-print "display-some-pane called ") + #+graphic-forms (gfs::debug-print "display-some-pane called ") (format stream (message frame))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Nov 24 02:01:22 2006 @@ -129,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyCursor" destroy-cursor) + BOOL + (hcursor HANDLE)) + +(defcfun ("DestroyIcon" destroy-icon) BOOL (hicon HANDLE)) @@ -670,6 +675,11 @@ (hwnd HANDLE)) (defcfun + ("SetCursor" set-cursor) + HANDLE + (hcursor HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE)) @@ -741,6 +751,11 @@ (str :string)) (defcfun + ("ShowCursor" show-cursor) + INT + (flag BOOL)) + +(defcfun ("ShowWindow" show-window) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Nov 24 02:01:22 2006 @@ -33,6 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defclass cursor (gfs:native-object) () + (:documentation "The cursor class represents the sprite controlled by the pointing device.")) + (defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) @@ -129,9 +132,6 @@ :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) -(defclass caret (widget) () - (:documentation "The caret class provides an i-beam typically representing an insertion point.")) - (defclass item-manager () ((sort-predicate :accessor sort-predicate-of

1 0

[graphic-forms-cvs] r399 - trunk/src/tests/uitoolkit
by junrue＠common-lisp.net 19 Nov '06

19 Nov '06

Author: junrue Date: Sun Nov 19 17:27:49 2006 New Revision: 399 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Log: define-layout-test now accepts a function to use to customize the target layout Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Sun Nov 19 17:27:49 2006 @@ -64,35 +64,59 @@ (define-layout-test border-layout-test1 -1 -1 80 50 + nil '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test2 -1 -1 40 20 + nil '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10)) #'make-border-layout *outer-border-kids*) (define-layout-test border-layout-test3 -1 -1 40 40 + nil '((0 0 40 40)) #'make-border-layout *center-border-kid*) (define-layout-test border-layout-test4 -1 -1 25 15 + nil '((0 0 25 5) (0 5 20 10)) #'make-border-layout *top-right-border-kids*) (define-layout-test border-layout-test5 -1 -1 25 10 + nil '((0 0 25 5) (0 5 25 5)) #'make-border-layout *top-bottom-border-kids*) (define-layout-test border-layout-test6 26 -1 26 50 + nil '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test7 -1 -1 90 58 + nil '((24 8 40 40) (4 3 80 5) (4 8 20 40) (4 48 80 5) (64 8 20 40)) #'make-border-layout *all-border-kids* 4 3 6 5) + +(defun border-layout-spacing (layout) + (loop for pair in (gfw::data-of layout) + for widget = (first pair) + for key = (first (second pair)) + do (case key + ;; note - we leave :center region with default spacing + (:top (setf (gfw:layout-attribute layout widget :leading-spacing) 2)) + (:left (setf (gfw:layout-attribute layout widget :trailing-spacing) 3)) + (:right (setf (gfw:layout-attribute layout widget :spacing) 4)) + (:bottom (setf (gfw:layout-attribute layout widget :center-spacing) 5))))) + +(define-layout-test border-layout-test8 + -1 -1 80 50 + #'border-layout-spacing + '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) + #'make-border-layout *all-border-kids*) Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Sun Nov 19 17:27:49 2006 @@ -42,70 +42,84 @@ (define-layout-test flow-layout-test1 -1 -1 60 10 + nil '((0 0 20 10) (20 0 20 10) (40 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal)) (define-layout-test flow-layout-test2 -1 -1 20 30 + nil '((0 0 20 10) (0 10 20 10) (0 20 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical)) (define-layout-test flow-layout-test3 45 -1 40 20 + nil '((0 0 20 10) (20 0 20 10) (0 10 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) (define-layout-test flow-layout-test4 -1 25 20 20 + nil '((0 0 20 10) (0 10 20 10) (20 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) (define-layout-test flow-layout-test5 45 18 40 20 + nil '((0 0 20 10) (20 0 20 10) (0 10 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) (define-layout-test flow-layout-test6 30 25 40 20 + nil '((0 0 20 10) (0 10 20 10) (20 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) (define-layout-test flow-layout-test7 -1 -1 68 10 + nil '((0 0 20 10) (24 0 20 10) (48 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal) 4) (define-layout-test flow-layout-test8 -1 -1 20 38 + nil '((0 0 20 10) (0 14 20 10) (0 28 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical) 4) (define-layout-test flow-layout-test9 45 18 0 0 + nil '((0 0 20 10) (24 0 20 10) (0 14 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4) (define-layout-test flow-layout-test10 30 25 0 0 + nil '((0 0 20 10) (0 14 20 10) (24 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4) (define-layout-test flow-layout-test11 -1 -1 63 13 + nil '((3 3 20 10) (23 3 20 10) (43 3 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3) (define-layout-test flow-layout-test12 -1 -1 23 33 + nil '((0 0 20 10) (0 10 20 10) (0 20 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3) (define-layout-test flow-layout-test13 -1 -1 75 10 + nil '((0 0 25 10) (25 0 25 10) (50 0 25 10)) #'make-flow-layout *flow-mixed-kids* '(:horizontal :normalize)) (define-layout-test flow-layout-test14 -1 -1 25 30 + nil '((0 0 25 10) (0 10 25 10) (0 20 25 10)) #'make-flow-layout *flow-mixed-kids* '(:vertical :normalize)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Nov 19 17:27:49 2006 @@ -83,13 +83,16 @@ actual-rects))) (defmacro define-layout-test (name width-hint height-hint - expected-width expected-height expected-rects + expected-width expected-height + customizer expected-rects factory &rest factory-args) (let ((layout (gensym)) (size (gensym)) + (dummy (gensym)) (data (gensym))) `(define-test ,name (let* ((,layout (apply ,factory (list ,@factory-args))) + (,dummy (if ,customizer (funcall ,customizer ,layout))) (,size (gfw::compute-size ,layout *mock-container* ,width-hint ,height-hint)) (,data (gfw::compute-layout ,layout *mock-container* ,width-hint ,height-hint))) (assert-equal ,expected-width (gfs::size-width ,size))

1 0

[graphic-forms-cvs] r398 - trunk/docs/manual
by junrue＠common-lisp.net 18 Nov '06

18 Nov '06

Author: junrue Date: Sat Nov 18 09:05:48 2006 New Revision: 398 Modified: trunk/docs/manual/gf-data.xsl Log: fixed multi-arg setf syntax Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Sat Nov 18 09:05:48 2006 @@ -209,7 +209,7 @@ syntax </xsl:element> - <xsl:element name="para"> + <para role="normal"> <xsl:attribute name="role">normal</xsl:attribute> (<xsl:value-of select="concat(../../@name,':',../@name)"/> <xsl:element name="emphasis"> @@ -223,26 +223,23 @@ <xsl:if test="not(position()=last())">, </xsl:if> </xsl:for-each> </xsl:element> - </xsl:element> + </para> <xsl:if test="@with-setf"> <xsl:element name="para"> <xsl:attribute name="role">normal</xsl:attribute> (setf (<xsl:value-of select="concat(../../@name,':',../@name,' ')"/> - <emphasis> - <xsl:call-template name="first-word"> - <xsl:with-param name="raw-text" select="arguments/argument[1]/@name"/> - </xsl:call-template> - </emphasis>) <emphasis> - <xsl:for-each select="arguments/argument"> - <xsl:if test="position() > 1"> - <xsl:value-of select="concat(' ', @name)"/> - </xsl:if> + <xsl:for-each select="arguments/argument | arguments/notarg"> + <xsl:value-of select="concat(' ', @name)"/> </xsl:for-each> </emphasis> <xsl:element name="emphasis"> - <xsl:apply-templates select="return"/> + <xsl:for-each select="return/*"> + <xsl:if test="position()=last()">)</xsl:if> + <xsl:value-of select="' '"/> + <xsl:apply-templates select="."/> + </xsl:for-each> </xsl:element>) </xsl:element> </xsl:if>

1 0