[graphic-forms-cvs] r419 - in trunk: . src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Thu Dec 21 04:31:34 UTC 2006
Author: junrue
Date: Wed Dec 20 23:31:33 2006
New Revision: 419
Modified:
trunk/NEWS.txt
trunk/README.txt
trunk/src/uitoolkit/system/comctl32.lisp
trunk/src/uitoolkit/system/kernel32.lisp
trunk/src/uitoolkit/system/metrics.lisp
trunk/src/uitoolkit/system/native-object.lisp
trunk/src/uitoolkit/system/shell32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/system-utils.lisp
Log:
implemented manual DLL loading and function pointer querying; fixed comctl32 and shell32 version querying; changed gfs:null-handle-p to an inlined function from a macro
Modified: trunk/NEWS.txt
==============================================================================
--- trunk/NEWS.txt (original)
+++ trunk/NEWS.txt Wed Dec 20 23:31:33 2006
@@ -1,6 +1,9 @@
. Graphic-Forms has been ported to Allegro CL 8.0.
+. GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll
+ and shell32.dll.
+
==============================================================================
Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI
Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt (original)
+++ trunk/README.txt Wed Dec 20 23:31:33 2006
@@ -17,7 +17,7 @@
http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/
*note: ASDF is bundled with SBCL*
- - CFFI (cffi-060925 or later)
+ - CFFI (cffi-061208 or later)
http://common-lisp.net/project/cffi/
- Closer to MOP
Modified: trunk/src/uitoolkit/system/comctl32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/comctl32.lisp (original)
+++ trunk/src/uitoolkit/system/comctl32.lisp Wed Dec 20 23:31:33 2006
@@ -38,10 +38,18 @@
(load-foreign-library "comctl32.dll")
+;;; See this thread:
+;;;
+;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html
+;;;
+;;; for a discussion of why the following is commented out.
+;;;
+#|
(defcfun
("DllGetVersion" comctl-dll-get-version)
HRESULT
(info :pointer))
+|#
(defcfun
("InitCommonControlsEx" init-common-controls)
Modified: trunk/src/uitoolkit/system/kernel32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/kernel32.lisp (original)
+++ trunk/src/uitoolkit/system/kernel32.lisp Wed Dec 20 23:31:33 2006
@@ -39,11 +39,29 @@
(load-foreign-library "kernel32.dll")
(defcfun
+ ("FreeLibrary" free-library)
+ BOOL
+ (hmodule HANDLE))
+
+(defcfun
("GetLastError" get-last-error)
DWORD)
(defcfun
("GetModuleHandleA" get-module-handle)
HANDLE
- (module-name LPTR)) ; FIXME: ought to be LPTSTR but I can't see how to define
- ; a null string pointer
+ (module-name LPTSTR))
+
+(defcfun
+ ("GetProcAddress" get-proc-address)
+ :pointer
+ (hmodule HANDLE)
+ (proc-name LPTSTR))
+
+(defcfun
+ ("LoadLibraryExA" load-library)
+ HANDLE
+ (file-name LPTSTR)
+ (hfile HANDLE) ; currently reserved and must be a NULL pointer
+ (flags DWORD))
+
Modified: trunk/src/uitoolkit/system/metrics.lisp
==============================================================================
--- trunk/src/uitoolkit/system/metrics.lisp (original)
+++ trunk/src/uitoolkit/system/metrics.lisp Wed Dec 20 23:31:33 2006
@@ -33,12 +33,21 @@
(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-dll-version-info (dll-path)
+ (let ((hmodule (load-library-wrapper dll-path))
+ (version (list 0 0 0)))
+ (unless (null-handle-p hmodule)
+ (unwind-protect
+ (let ((func-ptr (retrieve-function-pointer hmodule "DllGetVersion")))
+ (unless (cffi:null-pointer-p func-ptr)
+ (cffi:with-foreign-object (info-ptr 'gfs::dllversioninfo)
+ (cffi:with-foreign-slots ((gfs::size gfs::vermajor gfs::verminor gfs::buildnum)
+ info-ptr gfs::dllversioninfo)
+ (setf gfs::size (cffi:foreign-type-size 'gfs::dllversioninfo))
+ (cffi:foreign-funcall func-ptr gfs::dllversioninfo info-ptr gfs::hresult)
+ (setf version (list gfs::vermajor gfs::verminor gfs::buildnum))))))
+ (gfs::free-library hmodule)))
+ version))
(defun obtain-system-metrics ()
"Query system metrics and return them via a hash table."
@@ -118,7 +127,7 @@
;; A list of integers describing the version of comctl32.dll.
;;
(setf (gethash :comctl32-version table)
- (obtain-dll-version-info #'comctl-dll-get-version))
+ (obtain-dll-version-info "comctl32.dll"))
;;
;; :cursor-size
;;
@@ -353,7 +362,7 @@
;; A list of integers describing the version of comctl32.dll.
;;
(setf (gethash :shell32-version table)
- (obtain-dll-version-info #'shell-dll-get-version))
+ (obtain-dll-version-info "shell32.dll"))
;;
;; :shutting-down
;;
Modified: trunk/src/uitoolkit/system/native-object.lisp
==============================================================================
--- trunk/src/uitoolkit/system/native-object.lisp (original)
+++ trunk/src/uitoolkit/system/native-object.lisp Wed Dec 20 23:31:33 2006
@@ -36,5 +36,6 @@
(defmethod disposed-p ((obj native-object))
(null (handle obj)))
-(defmacro null-handle-p (handle)
- `(cffi:null-pointer-p ,handle))
+(declaim (inline null-handle-p))
+(defun null-handle-p (handle)
+ (cffi:null-pointer-p handle))
Modified: trunk/src/uitoolkit/system/shell32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/shell32.lisp (original)
+++ trunk/src/uitoolkit/system/shell32.lisp Wed Dec 20 23:31:33 2006
@@ -38,7 +38,15 @@
(load-foreign-library "shell32.dll")
+;;; See this thread:
+;;;
+;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html
+;;;
+;;; for a discussion of why the following is commented out.
+;;;
+#|
(defcfun
("DllGetVersion" shell-dll-get-version)
HRESULT
(info :pointer))
+|#
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Wed Dec 20 23:31:33 2006
@@ -1687,6 +1687,14 @@
(defconstant +colormgmtcaps+ 121)
;;;
+;;; LoadLibraryEx flags
+;;;
+(defconstant +dont-resolve-dll-references+ #x00000001)
+(defconstant +load-library-as-datafile+ #x00000002)
+(defconstant +load-with-altered-search-path+ #x00000008)
+(defconstant +load-ignore-code-authz-level+ #x00000010)
+
+;;;
;;; Background modes (Get/SetBkMode)
;;;
(defconstant +transparent+ 1)
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Wed Dec 20 23:31:33 2006
@@ -163,6 +163,25 @@
(defun make-lparam (hi lo)
(logior (ash (logand lo #xFFFF) 16) (logand hi #xFFFF)))
+(defun load-library-wrapper (dll-path)
+ (let ((hmodule (cffi:null-pointer)))
+ (cffi:with-foreign-string (str-ptr dll-path)
+ (setf hmodule (load-library str-ptr (cffi:null-pointer) 0)))
+ (when (null-handle-p hmodule)
+ (warn 'toolkit-warning :detail (format nil "could not load ~s" dll-path)))
+ hmodule))
+
+(defun retrieve-function-pointer (hmodule func-name)
+ (let ((func-ptr (cffi:null-pointer)))
+ (if (null-handle-p hmodule)
+ (error 'toolkit-error :detail "null module handle"))
+ (cffi:with-foreign-string (str-ptr func-name)
+ (setf func-ptr (gfs::get-proc-address hmodule str-ptr)))
+ (if (gfs:null-handle-p func-ptr)
+ (let ((detail (format nil "could not get function pointer for ~s" func-name)))
+ (warn 'gfs:toolkit-warning :detail detail)))
+ func-ptr))
+
;;;
;;; convenience macros
;;;
More information about the Graphic-forms-cvs
mailing list