;;; CLisp OLE Automation interface ;;; ;;; Copyright (C) 2005 Tomas Hlavaty ;;; ;;; This is Free Software, covered by the GNU GPL (v2) ;;; See http://www.gnu.org/copyleft/gpl.html (defpackage "OLE" (:use "LISP" "FFI") (:export "INIT" "DONE" "CREATE" "RELEASE" "INVOKE" "INVOKE-GET" "INVOKE-PUT" "INVOKE-METHOD" "WITH-OLE" "WITH-IUNKNOWN" "IUNKNOWN" "IDISPATCH")) (in-package "OLE") (pushnew :ole *features*) (default-foreign-language :stdc) (c-lines " #include #include ") ;;; win32api constants are loaded from c header files (defconstant +cfiles+ "c:/cygwin/usr/include/w32api/*.h") ; update this! (defun load-win32api-constants (cfiles) (let ((n 0)) (dolist (filename (directory cfiles) n) (flet ((match (line regexp &optional hex) (multiple-value-bind (all key value) (regexp:match regexp line :extended t :ignore-case t) (when all (let ((sym (read-from-string (regexp:match-string line key)))) (eval `(defconstant ,sym ,(read-from-string (concatenate 'string (if hex "#x" "") (regexp:match-string line value))))) (incf n)))))) (with-open-file (in filename) (loop for line = (read-line in nil nil) while line do (or (match line "^#define ([a-zA-Z0-9_]+) ([0-9]+)$") (match line "#define ([a-zA-Z0-9_]+) \\((-[0-9]+)\\)$") (match line "^#define ([a-zA-Z0-9_]+) 0x([0-9]+)$" t)))))))) ;;(load-win32api-constants +cfiles+)) ;;; types (defconstant +wencoding+ charset:unicode-16-little-endian) ; used by OLE (defconstant CP_ACP 0) (defconstant LOCALE_USER_DEFAULT 1024) (defconstant LOCALE_SYSTEM_DEFAULT 2048) (defconstant DISPATCH_METHOD 1) (defconstant DISPATCH_PROPERTYGET 2) (defconstant DISPATCH_PROPERTYPUT 4) (defconstant DISPID_PROPERTYPUT -3) (def-c-type HRESULT ulong) (def-c-type WORD ushort) (def-c-type DWORD ulong) (def-c-type PVOID (c-ptr-null nil)) (def-c-type BSTR c-pointer) (def-c-type DISPID long) (def-c-type LCID DWORD) (def-c-enum VARTYPE (VT_EMPTY 0) VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL (VT_I1 16) VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT VT_UINT VT_VOID VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY VT_USERDEFINED VT_LPSTR VT_LPWSTR (VT_RECORD 36) (VT_INT_PTR 37) (VT_UINT_PTR 38) (VT_FILETIME 64) VT_BLOB VT_STREAM VT_STORAGE VT_STREAMED_OBJECT VT_STORED_OBJECT VT_BLOB_OBJECT VT_CF VT_CLSID (VT_BSTR_BLOB #xfff) (VT_VECTOR #x1000) (VT_ARRAY #x2000) (VT_BYREF #x4000) (VT_RESERVED #x8000) (VT_ILLEGAL #xffff) (VT_ILLEGALMASKED #xfff) (VT_TYPEMASK #xfff)) (def-c-struct SAFEARRAYBOUND (cElements ULONG) (lLbound LONG)) (def-c-struct SAFEARRAY (cDims USHORT) (fFeatures USHORT) (cbElements ULONG) (cLocks ULONG) (pvData PVOID) (rgsabound (c-array SAFEARRAYBOUND 1))) ; what about following bounds? ;;(sizeof 'SAFEARRAY) ;; (def-c-struct VARIANT ;; (vt ushort) ;VARTYPE) ;; (wReserved1 WORD) ;; (wReserved2 WORD) ;; (wReserved3 WORD) ;; (val (c-union ;; (bstrVal BSTR) ;; (pdispVal c-pointer) ;(pdispVal LPDISPATCH) ;; (parray (c-ptr SAFEARRAY)) ;; (dblVal double-float)))) ; to get the right size only (def-c-type VARIANT (c-array uint8 16)) ; must be equal to (%variant-size) ;;(sizeof 'VARIANT) (def-c-struct GUID (data1 ulong) (data2 ushort) (data3 ushort) (data4 (c-array uchar 8))) (def-c-var IID_NULL (:type GUID) (:name "IID_NULL") (:read-only t)) (def-c-var IID_IDispatch (:type GUID) (:name "IID_IDispatch") (:read-only t)) (def-c-enum CLSCTX (CLSCTX_INPROC_SERVER 1) (CLSCTX_INPROC_HANDLER 2) (CLSCTX_LOCAL_SERVER 4) (CLSCTX_INPROC_SERVER16 8) (CLSCTX_REMOTE_SERVER 16)) (def-c-struct DISPPARAMS (rgvarg (c-array-ptr VARIANT)) (rgdispidNamedArgs (c-array-ptr DISPID)) (cArgs UINT) (cNamedArgs UINT)) ;;; (de)initialisation (def-call-out %CoInitialize (:name "CoInitialize") (:arguments (reserved c-pointer)) (:return-type HRESULT)) (def-call-out %CoUninitialize (:name "CoUninitialize")) (defun init () (%CoInitialize nil)) (defun done () (%CoUninitialize)) (defparameter *ole-objects* nil) (defmacro with-ole (vars &body body) `(let ((*ole-objects* (make-hash-table :key-type 'foreign-address :value-type 'iunknown))) (ole:init) (unwind-protect (let* ,vars ,@body) (maphash #'(lambda (key val) (declare (ignore key)) (ole%Release val)) *ole-objects*) (clrhash *ole-objects*) (ole:done)))) ;;; objects (def-call-out %CLSIDFromProgID (:name "CLSIDFromProgID") (:arguments (wprogid c-pointer) (clsid (c-ptr GUID) :out :alloca)) (:return-type HRESULT)) (def-call-out %CoCreateInstance (:name "CoCreateInstance") (:arguments (clsid (c-ptr GUID)) (unknown c-pointer) (context DWORD) (iid c-pointer) (dispatch c-pointer)) (:return-type HRESULT)) (defmacro with-wstring ((wstr str) &body body) `(with-foreign-string (,wstr elems bytes ,str :encoding +wencoding+) (declare (ignore elems bytes)) ,@body)) (defun create (progid &optional raw) (with-wstring (wprogid progid) (multiple-value-bind (result clsid) (%CLSIDFromProgID wprogid) (with-c-var (dispatch 'c-pointer) (let ((result (%CoCreateInstance clsid nil CLSCTX_LOCAL_SERVER (c-var-address IID_IDispatch) (c-var-address dispatch)))) (when (= 0 result) ; ok (if raw dispatch (make-instance 'IDispatch :interface dispatch)))))))) (defmacro with-c-pointer ((var ptr type) &body body) (let ((pvar (gensym))) `(with-c-var (,pvar 'c-pointer) (setf ,pvar ,ptr) (let ((,var (cast ,pvar ,type))) ,@body)))) (defmacro def-ole-method (name (this type) niface iface-size nfn vtable-size &key arguments return-type) `(defmethod ,(intern (concatenate 'string "OLE%" (symbol-name name)) "OLE") ,(append (list (list this type)) (loop for arg in arguments when (not (eq :out (third arg))) collect (first arg))) ;; with interface (with-c-pointer (iface (interface ,this) '(c-ptr (c-array-max c-pointer ,iface-size))) ;; with vtable (with-c-pointer (vtable (aref iface ,niface) '(c-ptr (c-array-max c-pointer ,vtable-size))) ;; with method (with-c-pointer (fn (aref vtable ,nfn) '(c-function ,(append '(:arguments (interface c-pointer)) arguments) (:return-type ,return-type))) ;; call the method (funcall fn (interface ,this) ,@(loop for arg in arguments when (not (eq :out (third arg))) collect (first arg)))))))) ;;; IUnknown ;;; Q: are we always calling the right "virtual" method? (defclass IUnknown () ((interface :type 'foreign-address :initarg :interface :accessor interface)) (:documentation "OLE IUnknown interface.")) (defmethod initialize-instance :after ((self IUnknown) &rest args) (declare (ignore args)) (let ((iface (interface self))) (if iface ;; what about duplicate objects with same iface? (setf (gethash iface *ole-objects*) self) (error "IUnknown interface pointer cannot be null!" self)))) (def-ole-method QueryInterface (this IUnknown) 0 1 0 3 :arguments ((iid (c-ptr GUID)) (object c-pointer)) ; why c-pointer only? :return-type HRESULT) ;;(def-ole-method QueryInterface (this IUnknown) 0 1 0 3 ;; :arguments ((iid (c-ptr GUID)) (object (c-ptr c-pointer))) ;; :return-type HRESULT) (def-ole-method AddRef (this IUnknown) 0 1 1 3 :return-type ulong) (def-ole-method Release (this IUnknown) 0 1 2 3 :return-type ulong) (defmacro with-iunknown ((var cmd) &body body) `(let ((,var ,cmd)) (unwind-protect (progn ,@body) (ole%Release ,var)))) ;;(with-iunknown (a (create "excel.application")) t) ;;; too complicated usage QueryInterface, handle arg conversion in def-ole-method? ;; (with-iunknown (a (create "excel.application")) ;; (with-c-var (p 'c-pointer) ;; (let ((result (QueryInterface a IID_IDispatch (c-var-address p)))) ; addref automatically! ;; (format t "QueryInterface ~a ~a" result p) ;; (when (= 0 result) ; ok but I have p=nil:-( ;; (let ((o (make-instance 'IDispatch :interface p))) ;; (Release o) ;; o))))) ;;; IDispatch (defclass IDispatch (IUnknown) () (:documentation "OLE IDispatch interface.")) ;;(def-ole-method GetTypeInfoCount (this IDispatch) 0 1 3 7 :arguments ((count (c-ptr uint))) :return-type HRESULT) ;;(def-ole-method GetTypeInfo (this IDispatch) 0 1 4 7 :arguments ((type uint) ()):return-type ulong) (def-ole-method GetIDsOfNames (this IDispatch) 0 1 5 7 :arguments ((iid (c-ptr GUID)) (pwname c-pointer) (n uint) (locale LCID) (id (c-ptr DISPID) :out :alloca)) :return-type HRESULT) (def-ole-method Invoke (this IDispatch) 0 1 6 7 :arguments ((id DISPID) (iid (c-ptr GUID)) (locale LCID) (type WORD) (dp (c-ptr DISPPARAMS)) (result (c-ptr VARIANT) :out :alloca) (excepinfo c-pointer) (nn c-pointer)) :return-type HRESULT) ;;(init) ;;(setq a (make-instance 'IDispatch :interface nil)) ;;(setq a (create "excel.application")) ;;(QueryInterface a) ;;(interface a) ;;; variants (def-call-out %VariantClear (:name "VariantClear") (:arguments (this (c-ptr VARIANT) :in-out))) (def-call-out %VariantCopy (:name "VariantCopy") (:arguments (out (c-ptr VARIANT) :out :alloca) (in (c-ptr VARIANT)))) (def-call-out %VariantChangeType1 (:name "VariantChangeType") (:arguments (out (c-ptr VARIANT) :out :alloca) (in (c-ptr VARIANT)) (n ushort) ; have to be 1! (type VARTYPE))) (def-call-out %SysAllocString (:name "SysAllocString") (:arguments (bstr BSTR)) (:return-type c-pointer)) (def-call-out %SysFreeString (:name "SysFreeString") (:arguments (bstr BSTR))) (def-call-out %SysStringLen (:name "SysStringLen") (:arguments (bstr BSTR)) (:return-type uint)) (def-call-out %WideCharToMultiByte (:name "WideCharToMultiByte") (:arguments (cp uint) (x DWORD) (bstr BSTR) (nbstr int) (str c-pointer) (nstr int) (cstr c-pointer) (pbool c-pointer)) (:return-type int)) ;;(UINT,DWORD,LPCWSTR,int,LPSTR,int,LPCSTR,LPBOOL); (defun bstr2lisp (bstr) (let ((n (%SysStringLen bstr))) (with-c-var (str `(c-array char ,n)) (%WideCharToMultiByte CP_ACP 0 bstr -1 (c-var-address str) n nil nil) (ext:convert-string-from-bytes str custom:*default-file-encoding*)))) (defmacro with-variant ((v a) &body body) `(with-c-var (,v 'VARIANT) (let ((,a (c-var-address ,v))) ,@body))) (c-lines " void variant_set_string (VARIANT *this, BSTR value) { this->vt = VT_BSTR; this->bstrVal = value; } void variant_set_dispatch (VARIANT *this, IDispatch *value) { this->vt = VT_DISPATCH; this->pdispVal = value; } void variant_set_safearray (VARIANT *this, SAFEARRAY *value) { this->vt = VT_ARRAY | VT_VARIANT; //VT_SAFEARRAY; this->parray = value; } BSTR variant_get_string (VARIANT *this) { return this->bstrVal; } IDispatch *variant_get_dispatch (VARIANT *this) { return this->pdispVal; } SAFEARRAY *variant_get_safearray (VARIANT *this) { return this->parray; } int variant_size (void) { return sizeof (VARIANT); } int variant_type (VARIANT *this) { return this->vt; } ") (def-call-out %variant-set-string (:name "variant_set_string") (:arguments (this (c-ptr VARIANT) :in-out) (bstr BSTR))) (def-call-out %variant-set-dispatch (:name "variant_set_dispatch") (:arguments (this (c-ptr VARIANT) :in-out) (dispatch c-pointer))) (def-call-out %variant-set-safearray (:name "variant_set_safearray") (:arguments (this (c-ptr VARIANT) :in-out) (safearray c-pointer))) (def-call-out %variant-get-string (:name "variant_get_string") (:arguments (this (c-ptr VARIANT))) (:return-type BSTR)) (def-call-out %variant-get-dispatch (:name "variant_get_dispatch") (:arguments (this (c-ptr VARIANT))) (:return-type c-pointer)) (def-call-out %variant-get-safearray (:name "variant_get_safearray") (:arguments (this (c-ptr VARIANT))) (:return-type c-pointer)) (def-call-out %variant-size (:name "variant_size") (:return-type int)) (def-call-out %variant-type (:name "variant_type") (:arguments (this (c-ptr VARIANT))) (:return-type int)) (defun make-variant () (make-array (%variant-size) :element-type '(unsigned-byte 8) :initial-element 0)) ;;(%variant-type (%variant-set-string (make-variant) nil)) (defun variant-string (val) (with-wstring (wstr val) (%variant-set-string (make-variant) (%SysAllocString wstr)))) ;;(%variant-type (variant-string "1")) (defun variant-dispatch (val) (%variant-set-dispatch (make-variant) (interface val))) (defun variant-safearray (val) (%variant-set-safearray (make-variant) (safearray-from-lisp val))) (defun variant-convert (var vt) (%VariantChangeType1 var 1 vt)) ;;(variant-convert (variant-string "1") VT_R8) ;;(variant-convert (variant-string "1.23") VT_R8) (defun variant-number (val) (variant-convert (variant-string (format nil "~a" val)) VT_R8)) ;;(variant-number 1) ;;(variant-number 1.23) ;;(variant-convert (variant-string "1") VT_R8) ;;(variant-convert (variant-number 1) VT_BSTR) ;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 1) VT_BSTR))) ;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 1.23) VT_BSTR))) ;;(bstr2lisp (%variant-get-string (variant-convert (variant-number 3.141592653589) VT_BSTR))) (defun variant-new (val) (ctypecase val (real (variant-number val)) (string (variant-string val)) (idispatch (variant-dispatch val)) (array (variant-safearray val)))) ;;(variant-new 1) ;;(variant-new 1.23) ;;(variant-new 3.141592653589) ;;(variant-new "hello") (defun variant-get (var &optional raw) (ecase (enum-from-value 'VARTYPE (%variant-type var)) (VT_EMPTY (values-list nil)) (VT_NULL nil) (VT_BSTR (bstr2lisp (%variant-get-string var))) (VT_DISPATCH (let ((dispatch (%variant-get-dispatch var))) (if raw dispatch (make-instance 'IDispatch :interface dispatch)))) ((VT_DATE VT_CY) ; convert to string (variant-get (variant-convert var VT_BSTR))) (VT_BOOL ; read from string and convert to nil|t (let ((tmp (variant-convert var VT_BSTR))) (values (if (= 0 (read-from-string (bstr2lisp (%variant-get-string tmp)))) nil t)))) ((VT_I2 VT_I4 VT_R4 VT_R8 VT_DECIMAL VT_I1 VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT VT_UINT) ; read from string (let ((tmp (variant-convert var VT_BSTR))) (values (read-from-string (bstr2lisp (%variant-get-string tmp)))))) (VT_SAFEARRAY (safearray-to-lisp (%variant-get-safearray var) raw)))) ;;(variant-get (variant-new 1)) ;;(variant-get (variant-new 1.23)) ;;(variant-get (variant-new 3.141592653589)) ;;(variant-get (variant-new "hello")) ;;(variant-get (variant-new #2A((1 2) ("a" "b")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype variant () '(array (unsigned-byte 8) 16)) ;;(make-array 2 :element-type 'VARIANT) (defun invoke (this type name args &optional raw) (let* ((n (length args)) (params (make-array n :element-type 'VARIANT))) ;; set up params (loop for arg in args for i from 0 do (setf (aref params i) (variant-new arg))) ;; get DISPID for name passed (with-wstring (wname name) (with-c-var (wname2 'c-pointer) (setf wname2 wname) (multiple-value-bind (hresult id) (ole%GetIDsOfNames this IID_NULL (c-var-address wname2) 1 LOCALE_USER_DEFAULT) ;; call invoke (let ((dp (make-DISPPARAMS :cArgs n :rgvarg params :cNamedArgs 0 :rgdispidNamedArgs nil))) ;; handle special-case for property-puts! (when (not (zerop (logand type DISPATCH_PROPERTYPUT))) (setf (DISPPARAMS-cNamedArgs dp) 1) (setf (DISPPARAMS-rgdispidNamedArgs dp) (make-array 1 :initial-element DISPID_PROPERTYPUT))) (multiple-value-bind (hresult result) (ole%Invoke this id IID_NULL LOCALE_SYSTEM_DEFAULT type dp nil nil) ;; convert result to lisp (variant-get result raw)))))))) (defun invoke-get (this name &rest args) (invoke this DISPATCH_PROPERTYGET name args)) (defun invoke-put (this name &rest args) (invoke this DISPATCH_PROPERTYPUT name args)) (defun invoke-method (this name &rest args) (invoke this DISPATCH_METHOD name args)) ;;(with-ole () ;; (with-iunknown (excel (create "excel.application")) ;; (invoke-put excel "visible" 1))) ;;; SafeArray support ;;; ;;; A SafeArray is represented by c-pointer as it is created and ;;; destroyed outside lisp. (def-call-out %SafeArrayCreate (:name "SafeArrayCreate") (:arguments (type VARTYPE) (ndim uint) (bounds (c-array-ptr SAFEARRAYBOUND))) (:return-type c-pointer)) (def-call-out %SafeArrayPutElement (:name "SafeArrayPutElement") (:arguments (safearray c-pointer) (subscripts (c-array-ptr long)) (value (c-ptr VARIANT)))) (def-call-out %SafeArrayGetElement (:name "SafeArrayGetElement") (:arguments (safearray c-pointer) (subscripts (c-array-ptr long)) (value (c-ptr VARIANT) :out :alloca))) (def-call-out %SafeArrayDestroy (:name "SafeArrayDestroy") (:arguments (safearray c-pointer))) (def-call-out %SafeArrayGetDim (:name "SafeArrayGetDim") (:arguments (safearray c-pointer)) (:return-type uint)) (def-call-out %SafeArrayGetLBound (:name "SafeArrayGetLBound") (:arguments (safearray c-pointer) (dim uint) (lbounds (c-ptr long) :out :alloca))) (def-call-out %SafeArrayGetUBound (:name "SafeArrayGetUBound") (:arguments (safearray c-pointer) (dim uint) (ubound (c-ptr long) :out :alloca))) (defun safearray-create (dimensions) (let* ((rank (length dimensions)) (bounds (make-array rank :element-type 'SAFEARRAYBOUND))) (loop for n in dimensions for i from 0 do (setf (aref bounds i) (make-SAFEARRAYBOUND :celements n :llbound 0))) (%SafeArrayCreate VT_VARIANT rank bounds))) (defmacro with-safearray (safearray &body body) `(unwind-protect (progn ,@body) (%SafeArrayDestroy ,safearray))) ;;; Unfortunatelly, I can't use ROW-MAJOR_AREF for iteration through ;;; array elements because anything like that doesn't exist in winapi ;;; and I can't restore subscripts from index. ;;; ;;; (let ((a (make-array '(1 2 3)))) ;;; (dotimes (i (array-total-size a) a) ;;; (setf (row-major-aref a i) i))) (defun for-all-elements (dims fn) "Call FN for all elements of an array with dimensions DIMS." (let* ((rank (length dims)) (mods (make-array rank :element-type 'integer))) ;; set up mods (dotimes (i rank) (setf (aref mods i) (if (= 0 i) 1 (* (aref mods (1- i)) (nth (1- i) dims))))) ;; enumerate endices (dotimes (i (reduce #'* dims)) ; for each element of array (let ((subscripts nil)) (dotimes (j rank) ; for each dimension (push (mod (truncate i (aref mods j)) (nth j dims)) subscripts)) (funcall fn (nreverse subscripts)))))) ;;(for-all-elements '(2 3) (lambda (subscripts) (format t "~s~%" subscripts))) (defun safearray-from-lisp (array) "Convert lisp ARRAY to SAFEARRAY." (let ((safearray (safearray-create (array-dimensions array)))) (for-all-elements (array-dimensions array) (lambda (subscripts) (let ((variant (variant-new (apply #'aref array subscripts))) (subs (make-array (array-rank array) :initial-contents subscripts))) (%SafeArrayPutElement safearray subs variant)))) safearray)) (defun safearray-dimensions (safearray) (let ((dims nil) (rank (%SafeArrayGetDim safearray))) (dotimes (i rank (nreverse dims)) (let ((lbound (%SafeArrayGetLBound safearray (1+ i))) (ubound (%SafeArrayGetUBound safearray (1+ i)))) (push (- ubound lbound -1) dims))))) (defun safearray-to-lisp (safearray &optional raw) "Convert SAFEARRAY to lisp ARRAY." (let ((array (make-array (safearray-dimensions safearray)))) (for-all-elements (array-dimensions array) (lambda (subscripts) (let ((subs (make-array (array-rank array) :initial-contents subscripts))) (setf (apply #'aref array subscripts) (variant-get (%SafeArrayGetElement safearray subs) raw))))) array)) ;; (let ((array (make-array '(4 2 3) ;; :initial-contents '((("a" "b" "c") (1 2 3)) ;; (("d" "e" "f") (3 1 2)) ;; (("g" "h" "i") (2 3 1)) ;; (("j" "k" "l") (0 0 0)))))) ;; (let ((safearray (safearray-from-lisp array))) ;; (with-safearray safearray ;; (safearray-to-lisp safearray)))) ;;; wrappers and utilities ;; (def-ole-interface IUnknown () ;; (QueryInterface (p a b)) ;; (AddRef (p)) ;; (Release (p))) ;; (def-ole-interface IDispatch (IUnknown) ;; (GetTypeInfoCount (p a)) ;; (GetTypeInfo (p a b c)) ;; (GetIDsOfNames (p a b c d e)) ;; (Invoke (p a b c d e f g h)))