[graphic-forms-cvs] r405 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Nov 29 18:23:16 UTC 2006
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="&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 , at body))
- (setf (slot-value ,widget 'cursor) ,old)
- (gfs:dispose ,new))
+ (setf (cursor-of ,widget) ,old))
,retval)))
(defmacro with-wait-cursor ((widget) &body body)
More information about the Graphic-forms-cvs
mailing list