[graphic-forms-cvs] r417 - in trunk: . docs/manual src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Mon Dec 18 05:22:53 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list