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#namestring"/> <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>

<!-- CONDITIONS --> @@ -301,6 +301,275 @@

<!-- FUNCTIONS -->

+ <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="&amp;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)