clisp-ole

OLE bindings for CLisp
git clone https://logand.com/git/clisp-ole.git/
Log | Files | Refs | README

commit 8e4f786e5900ad4af48a8cfe2eeee43cff7a11c3
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat, 18 Sep 2010 03:44:20 +0200

Initial commit

Diffstat:
AMakefile | 42++++++++++++++++++++++++++++++++++++++++++
AREADME | 57+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Aexcel.lisp | 182+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alink.sh | 9+++++++++
Aole.lisp | 644+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 934 insertions(+), 0 deletions(-)

diff --git a/Makefile b/Makefile @@ -0,0 +1,42 @@ +# Makefile for OLE CLISP module + +CC = gcc +CFLAGS = -g -O2 -Wall -DCOBJMACROS +# -DOLE2ANSI + +CLISP = clisp + +INCLUDES = -I../../linkkit -I"/lib/clisp/linkkit" + +LN = ln + +MAKE = make + +SHELL = /bin/sh + +DISTRIBFILES = link.sh Makefile ole.lisp +distribdir = + +.c.o: + $(CC) $(CFLAGS) $(INCLUDES) -c $< + +all: ole.o + +ole.c: ole.lisp + $(CLISP) -c ole.lisp + +# Make a module +clisp-module: all + +# Make a module distribution into $(distribdir) +clisp-module-distrib: clisp-module force + $(LN) $(DISTRIBFILES) $(distribdir) + +clean: force + rm -f core *.o *.a *~ *.bak + rm -f *.aux *.cp *.fn *.ky *.log *.pg *.toc *.tp *.vr + +distclean: clean + +force: + rm -f *.fas *.lib ole.c diff --git a/README b/README @@ -0,0 +1,57 @@ +-*- Outline -*- + +CLisp OLE Automation interface + +Copyright (C) 2005 Tomas Hlavaty <kvietaag@seznam.cz> + +This is Free Software, covered by the GNU GPL (v2) +See http://www.gnu.org/copyleft/gpl.html + +* Warning + +This is experimental version that can seriously damage your computer. +Be ready for blue screen and MS Windows recovery:-( + +* Introduction + +This module provides rather incomplete and experimental interface to +OLE Automation. + +* Motivation + +- Use CLisp for OLE Automation. + +- Thank and contribute to GNU. + +- Learn more about Lisp. + +- Learn about OLE Automation. + +* Platform + +Developed on Cygwin, GNU CLISP 2.34, GNU C 3.4.4 + +* TODO + +Important: + +1) Add error handling. + +2) Check for memory leaks and do resource management properly + especially on errors! + +3) Add other IDispatch methods. + +4) Build more OLE classes and methods on top of the low level + interface. + +5) Replace RAW parameter of OLE:INVOKE by something like + :default-idispatch-class? + +Minor: + +5) Use c-struct for variant type instead of c-pointer and + getter/setter C functions. + +6) wstring->string conversion: inverse function to with-foreign-string + to replace WideCharToMultiByte() in bstr2lisp? diff --git a/excel.lisp b/excel.lisp @@ -0,0 +1,182 @@ +;;; CLisp OLE Automation interface +;;; +;;; Copyright (C) 2005 Tomas Hlavaty <kvietaag@seznam.cz> +;;; +;;; This is Free Software, covered by the GNU GPL (v2) +;;; See http://www.gnu.org/copyleft/gpl.html + +(defpackage "EXCEL" + (:use "OLE" "LISP") + (:export "EXCEL" "WORKBOOKS" "WORKBOOK" "WORKSHEETS" "WORKSHEET" "RANGE")) + +(in-package "EXCEL") + +(pushnew :excel *features*) + +;;; classes + +(defclass excel (idispatch) + () + (:default-initargs :interface (ole:create "excel.application" t))) + +(defclass workbooks (idispatch) + ()) + +(defclass workbook (idispatch) + ()) + +(defclass worksheets (idispatch) + ()) + +(defclass worksheet (idispatch) + ()) + +(defclass range (idispatch) + ()) + +;;; methods + +(defmethod quit-excel ((excel excel)) + (ole:invoke-method excel "quit")) + +(defmethod excel-version ((excel excel)) + (ole:invoke-get excel "version")) + +(defmethod visible ((excel excel)) + (ole:invoke-get excel "visible")) + +(defmethod (setf visible) (visible (excel excel)) + (ole:invoke-put excel "visible" (if visible 1 0)) + visible) + +;;(with-ole ((excel (make-instance 'excel))) +;; (setf (visible excel) t) +;; (format t "@@@ *ole-objects* ~s~%" ole::*ole-objects*)) + +;; (with-ole () +;; (with-iunknown (excel (make-instance 'excel :interface (create "excel.application" t))) +;; (format t "-- visible ~s~%" (visible excel)) +;; (format t "-- visible ~s~%" (setf (visible excel) t)) +;; (format t "-- visible ~s~%" (visible excel)) +;; (format t "-- visible ~s~%" (setf (visible excel) nil)) +;; (format t "-- visible ~s~%" (visible excel)))) + +(defmethod user-control ((excel excel)) + (ole:invoke-get excel "usercontrol")) + +(defmethod active-book ((excel excel)) + (let ((dispatch (ole:invoke excel ole::DISPATCH_PROPERTYGET "activebook" nil t))) + (when dispatch + (make-instance 'workbook :interface dispatch)))) + +(defmethod active-sheet ((excel excel)) + (let ((dispatch (ole:invoke excel ole::DISPATCH_PROPERTYGET "activesheet" nil t))) + (when dispatch + (make-instance 'worksheet :interface dispatch)))) + +;(defmethod active-cell ((excel excel)) +; (ole:invoke-get excel "activecell")) + +(defmethod open-excel-file ((self workbooks) filename) + (ole:invoke-get self "open" filename)) + +(defmethod add-workbook ((books workbooks) &optional name) + (let ((dispatch (if name + (ole:invoke books ole::DISPATCH_PROPERTYGET "add" (list name) t) + (ole:invoke books ole::DISPATCH_PROPERTYGET "add" nil t)))) + (when dispatch + (make-instance 'workbook :interface dispatch)))) + +(defmethod add-worksheet ((book workbook) &optional name) + (let ((dispatch (if name + (ole:invoke book ole::DISPATCH_PROPERTYGET "add" (list name) t) + (ole:invoke book ole::DISPATCH_PROPERTYGET "add" nil t)))) + (when dispatch + (make-instance 'worksheet :interface dispatch)))) + +(defmethod count-workbooks ((self workbooks)) + (ole:invoke-get self "count")) + +(defmethod count-worksheets ((self worksheets)) + (ole:invoke-get self "count")) + +(defmethod name ((self workbook)) + (ole:invoke-get self "name")) + +(defmethod name ((self worksheet)) + (ole:invoke-get self "name")) + +(defmethod workbooks ((self excel)) + (let ((dispatch (ole:invoke self ole::DISPATCH_PROPERTYGET "workbooks" nil t))) + (when dispatch + (make-instance 'workbooks :interface dispatch)))) + +(defmethod workbook ((self excel) i) + (let ((dispatch (ole:invoke self ole::DISPATCH_PROPERTYGET "workbooks" + (list i) t))) + (when dispatch + (make-instance 'workbook :interface dispatch)))) + +(defmethod worksheets ((self workbook)) + (let ((dispatch (ole:invoke self ole::DISPATCH_PROPERTYGET "worksheets" nil t))) + (when dispatch + (make-instance 'worksheets :interface dispatch)))) + +(defmethod worksheet ((self workbook) i) + (let ((dispatch (ole:invoke self ole::DISPATCH_PROPERTYGET "worksheets" + (list i) t))) + (when dispatch + (make-instance 'worksheet :interface dispatch)))) + +(defmethod range ((sheet worksheet) &optional name) + (let ((dispatch (if name + (ole:invoke sheet ole::DISPATCH_PROPERTYGET "range" (list name) t) + (ole:invoke sheet ole::DISPATCH_PROPERTYGET "range" nil t)))) + (when dispatch + (make-instance 'range :interface dispatch)))) + +(defmethod (setf value) (val (range range)) + (ole:invoke-put range "value" val) + val) + +(defmethod (setf saved) (val (book workbook)) + (ole:invoke-put book "saved" (if val 1 0)) + val) + +;;; examples + +(defun get-structure (filename) + (ole:with-ole ((excel (make-instance 'excel)) + (books (workbooks excel))) + (open-excel-file books filename) + (prog1 (loop for i from 1 to (count-workbooks books) + for book = (workbook excel i) + for sheets = (worksheets book) + collect (cons (name book) + (list + (loop for i from 1 to (count-worksheets sheets) + for sheet = (worksheet book i) + collect (name sheet))))) + (quit-excel excel)))) + +;;(get-structure "c:/Program Files/Microsoft Office/OFFICE11/SAMPLES/SOLVSAMP.XLS") + +(defun example1 () + (ole:with-ole ((excel (make-instance 'excel)) + (books (workbooks excel))) + (setf (visible excel) t) + (let* ((book (add-workbook books)) + (sheet (active-sheet excel)) + (range (range sheet "A1:E7"))) ; intentionally isn't 3x3 array;-) + (prog1 (list (name book) (name sheet)) + (let* ((n 3) ; 3x3 array:-) + (data (make-array `(,n ,n)))) + (dotimes (i n) + (dotimes (j n) + (setf (aref data i j) (* (1+ i) (1+ j))))) + (setf (value range) data)) + (sleep 3) ; watch the sheet for a while + (setf (saved book) t) + (quit-excel excel))))) + +;;(example1) diff --git a/link.sh b/link.sh @@ -0,0 +1,9 @@ +files='ole.o' + +make clisp-module \ + CC="${CC}" CPPFLAGS="${CPPFLAGS} -I/usr/local/include" CFLAGS="${CFLAGS}" \ + INCLUDES="$absolute_linkkitdir" +NEW_FILES="${files}" +NEW_LIBS="-L/usr/local/lib ${files}" +NEW_MODULES='ole' +TO_LOAD='ole' diff --git a/ole.lisp b/ole.lisp @@ -0,0 +1,644 @@ +;;; CLisp OLE Automation interface +;;; +;;; Copyright (C) 2005 Tomas Hlavaty <kvietaag@seznam.cz> +;;; +;;; 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 <windows.h> +#include <ole2.h> +") + +;;; 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)))