commit 8e4f786e5900ad4af48a8cfe2eeee43cff7a11c3
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 18 Sep 2010 03:44:20 +0200
Initial commit
Diffstat:
| A | Makefile | | | 42 | ++++++++++++++++++++++++++++++++++++++++++ |
| A | README | | | 57 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | excel.lisp | | | 182 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | link.sh | | | 9 | +++++++++ |
| A | ole.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)))
