Author: junrue Date: Mon Dec 18 00:22:52 2006 New Revision: 417 Added: trunk/src/uitoolkit/system/shell32.lisp Modified: trunk/docs/manual/gfc-symbols.xml trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/legal.xml trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/system/metrics.lisp trunk/src/uitoolkit/system/system-types.lisp Log: enhanced obtain-system-metrics to include version info for comctl32.dll and shell32.dll, but still need to track down why duplicate version info is returned Modified: trunk/docs/manual/gfc-symbols.xml ============================================================================== --- trunk/docs/manual/gfc-symbols.xml (original) +++ trunk/docs/manual/gfc-symbols.xml Mon Dec 18 00:22:52 2006 @@ -17,6 +17,51 @@ <!-- CLASSES --> + <class name="listener-panel"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:panel</reftopic> + </inherits> + </hierarchy> + This class implements a text-based input/output component which + can serve as a REPL. Its size and location can be + maintained by its parent's layout manager; however, note that best + visual results are achieved when the panel is allowed to maintain + integral height and width. + </description> + <initargs> + <argument name=":callbacks"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":dispatcher"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + <argument name=":parent"> + <description> + See <reftopic>gfw:panel</reftopic>. + </description> + </argument> + <argument name=":style"> + <description> + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + <reftopic>gfw:parent</reftopic> + </seealso> + </class> + <!-- STRUCTURES --> <!-- FUNCTIONS --> Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Dec 18 00:22:52 2006 @@ -370,6 +370,13 @@ button type. </description> </argument> + <argument name=":comctl32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + comctl32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":cursor-size"> <description> A <reftopic>gfs:size</reftopic> describing the dimensions of a cursor @@ -535,6 +542,13 @@ arrow bitmap. </description> </argument> + <argument name=":shell32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + shell32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":shutting-down"> <description> T if the current session is shutting down; NIL otherwise. Modified: trunk/docs/manual/legal.xml ============================================================================== --- trunk/docs/manual/legal.xml (original) +++ trunk/docs/manual/legal.xml Mon Dec 18 00:22:52 2006 @@ -1,12 +1,12 @@ <!-- legal.xml - Copyright (c) 2006, Jack D. Unrue + Copyright (c) 2006-2007, Jack D. Unrue --> <chapter id="legal"> <title>Legal Notices</title> <para> - Copyright © 2006, Jack D. Unrue <jdunrue at gmail dot com> + Copyright © 2006-2007, Jack D. Unrue <jdunrue at gmail dot com> </para> <para role="normal"> Redistribution and use in source and binary forms, with or without Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Dec 18 00:22:52 2006 @@ -67,8 +67,9 @@ (:file "system-types") (:file "datastructs") (:file "clib") - (:file "comdlg32") (:file "comctl32") + (:file "comdlg32") + (:file "shell32") (:file "gdi32") (:file "kernel32") (:file "user32") Modified: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comctl32.lisp (original) +++ trunk/src/uitoolkit/system/comctl32.lisp Mon Dec 18 00:22:52 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comctl32.dll") (defcfun + ("DllGetVersion" comctl-dll-get-version) + HRESULT + (info :pointer)) + +(defcfun ("InitCommonControlsEx" init-common-controls) BOOL (init LPTR)) Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Mon Dec 18 00:22:52 2006 @@ -33,6 +33,13 @@ (in-package :graphic-forms.uitoolkit.system) +(defun obtain-dll-version-info (foreign-func) + (cffi:with-foreign-object (ptr 'dllversioninfo) + (cffi:with-foreign-slots ((size vermajor verminor buildnum) ptr dllversioninfo) + (setf size (cffi:foreign-type-size 'dllversioninfo)) + (funcall foreign-func ptr) + (list vermajor verminor buildnum)))) + (defun obtain-system-metrics () "Query system metrics and return them via a hash table." (let ((table (make-hash-table))) @@ -106,6 +113,13 @@ (make-size :width (get-system-metrics +sm-cxsmsize+) :height (get-system-metrics +sm-cysmsize+)))) ;; + ;; :comctl32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :comctl32-version table) + (obtain-dll-version-info #'comctl-dll-get-version)) + ;; ;; :cursor-size ;; ;; The size of the cursor image in pixels. @@ -334,6 +348,13 @@ (make-size :width (get-system-metrics +sm-cxhscroll+) :height (get-system-metrics +sm-cyvscroll+))) ;; + ;; :shell32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :shell32-version table) + (obtain-dll-version-info #'shell-dll-get-version)) + ;; ;; :shutting-down ;; ;; T if the current session is shutting down; NIL otherwise. Added: trunk/src/uitoolkit/system/shell32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/shell32.lisp Mon Dec 18 00:22:52 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; shell32.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "shell32.dll") + +(defcfun + ("DllGetVersion" shell-dll-get-version) + HRESULT + (info :pointer)) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Dec 18 00:22:52 2006 @@ -45,33 +45,33 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in gfs: package -(defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) +(defctype ATOM :unsigned-short) ; shadowed in gfs: package +(defctype BOOL :int) +(defctype BOOLEAN :char) ; shadowed in gfs: package +(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) -(defctype DWORD :unsigned-long) -(defctype HANDLE :pointer) -(defctype INT :int) -(defctype LANGID :short) -(defctype LONG :long) -(defctype LPARAM :long) -(defctype LPCSTR :pointer) -(defctype LPCTSTR :pointer) -(defctype LPFN :long) ; FIXME: not currently used; maybe should be :pointer instead -(defctype LPRECT :pointer) -(defctype LPSTR :pointer) -(defctype LPTR :pointer) -(defctype LPTSTR :pointer) -(defctype LPVOID :long) -(defctype LRESULT :unsigned-long) -(defctype SHORT :unsigned-short) -(defctype TCHAR :char) -(defctype UINT :unsigned-int) -(defctype ULONG :unsigned-long) -(defctype USHORT :unsigned-short) -(defctype WORD :short) -(defctype WPARAM :unsigned-int) +(defctype DWORD :unsigned-long) +(defctype HANDLE :pointer) +(defctype HRESULT :unsigned-int) +(defctype INT :int) +(defctype LANGID :short) +(defctype LONG :long) +(defctype LPARAM :long) +(defctype LPCSTR :pointer) +(defctype LPCTSTR :pointer) +(defctype LPRECT :pointer) +(defctype LPSTR :pointer) +(defctype LPTR :pointer) +(defctype LPTSTR :pointer) +(defctype LPVOID :long) +(defctype LRESULT :unsigned-long) +(defctype SHORT :unsigned-short) +(defctype TCHAR :char) +(defctype UINT :unsigned-int) +(defctype ULONG :unsigned-long) +(defctype USHORT :unsigned-short) +(defctype WORD :short) +(defctype WPARAM :unsigned-int) #+sbcl (sb-alien:define-alien-type enumchildproc @@ -178,6 +178,15 @@ (minsize INT) (maxsize INT)) +(defcstruct dllversioninfo + (size DWORD) + (vermajor DWORD) + (verminor DWORD) + (buildnum DWORD) + (platform DWORD)) + +(defctype dllversioninfo-pointer :pointer) + (defcstruct drawtextparams (cbsize UINT) (tablength INT) @@ -209,7 +218,7 @@ (defcstruct initcommoncontrolsex (size DWORD) - (icc DWORD)) + (icc DWORD)) (defcstruct logbrush (style UINT)