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 ;;;