How To: Consume COM server in Common Lisp
Goal: Simple example to consume COM server/object using Common Lisp
Version info:
- OS: Windows 11 23H2 (Microsoft Windows [Version 10.0.22631.7079])
- Emacs: 30.2
- SBCL : 2.6.4
- SLIME: 2.32
Pre-Requisites:
- Install CFFI
Save below say as shell-min.lisp
(defpackage #:shell-min
(:use #:cl #:cffi)
(:export #:demo
#:create-shell
#:get-current-directory))
(in-package #:shell-min)
;;; --------------------------------------------------------------------------
;;; DLLs
;;; --------------------------------------------------------------------------
(define-foreign-library ole32
(t (:default "ole32")))
(define-foreign-library oleaut32
(t (:default "oleaut32")))
(use-foreign-library ole32)
(use-foreign-library oleaut32)
;;; --------------------------------------------------------------------------
;;; Types
;;; --------------------------------------------------------------------------
(defctype hresult :long)
(defctype dword :uint32)
(defctype word :uint16)
(defctype uint :uint32)
(defctype lcid :uint32)
(defctype dispid :long)
(defctype ulong :uint32)
(defcstruct guid
(data1 :uint32)
(data2 :uint16)
(data3 :uint16)
(data4 (:array :uint8 8)))
(defcstruct dispparams
(rgvarg :pointer)
(rgdispidNamedArgs :pointer)
(cArgs uint)
(cNamedArgs uint))
;; Windows VARIANT = 16 bytes
(defcstruct variant
(vt word)
(w1 word)
(w2 word)
(w3 word)
(data (:array :uint8 8)))
;;; --------------------------------------------------------------------------
;;; Constants
;;; --------------------------------------------------------------------------
(defparameter +coinit-apartmentthreaded+ #x2)
(defparameter +clsctx-server+ #x5)
(defparameter +dispatch-propertyget+ #x2)
(defparameter +vt-bstr+ 8)
(defparameter +iid-idispatch+
"{00020400-0000-0000-C000-000000000046}")
;;; --------------------------------------------------------------------------
;;; COM APIs
;;; --------------------------------------------------------------------------
(defcfun ("CoInitializeEx" coinit) hresult
(reserved :pointer)
(coinit dword))
(defcfun ("CoUninitialize" couninit) :void)
(defcfun ("CLSIDFromProgID" clsid-from-progid) hresult
(progid :pointer)
(clsid :pointer))
(defcfun ("IIDFromString" iid-from-string) hresult
(str :pointer)
(iid :pointer))
(defcfun ("CoCreateInstance" cocreate) hresult
(clsid :pointer)
(outer :pointer)
(ctx dword)
(iid :pointer)
(ppv :pointer))
(defcfun ("SysStringLen" syslen) :uint32
(bstr :pointer))
;;; --------------------------------------------------------------------------
;;; Helpers
;;; --------------------------------------------------------------------------
(defun check (hr msg)
(when (minusp hr)
(error "~A failed: 0x~8,'0X" msg (ldb (byte 32 0) hr))))
(defun zero-memory (ptr size)
(dotimes (i size)
(setf (mem-aref ptr :uint8 i) 0))
ptr)
(defun vt-fn (p index)
(mem-aref (mem-ref p :pointer) :pointer index))
(defun release (p)
(foreign-funcall-pointer (vt-fn p 2)
(:convention :stdcall)
:pointer p
ulong))
(defun create-shell ()
"Create WScript.Shell and return IDispatch*."
(with-foreign-object (clsid '(:struct guid))
(with-foreign-object (iid '(:struct guid))
(with-foreign-string (progid "WScript.Shell" :encoding :utf-16le)
(check (clsid-from-progid progid clsid)
"CLSIDFromProgID"))
(with-foreign-string (iid-str +iid-idispatch+ :encoding :utf-16le)
(check (iid-from-string iid-str iid)
"IIDFromString(IID_IDispatch)"))
(with-foreign-object (ppv :pointer)
(setf (mem-ref ppv :pointer) (null-pointer))
(check (cocreate clsid
(null-pointer)
+clsctx-server+
iid
ppv)
"CoCreateInstance")
(mem-ref ppv :pointer)))))
(defun get-dispid (obj name)
"Resolve a member name to DISPID via IDispatch::GetIDsOfNames."
(let ((fn (vt-fn obj 5))) ; IDispatch::GetIDsOfNames
(with-foreign-object (iid-null '(:struct guid))
(with-foreign-object (names :pointer 1)
(with-foreign-object (id 'dispid)
;; riid must be IID_NULL (all zeros)
(zero-memory iid-null (foreign-type-size '(:struct guid)))
(with-foreign-string (n name :encoding :utf-16le)
(setf (mem-aref names :pointer 0) n)
(check
(foreign-funcall-pointer fn
(:convention :stdcall)
:pointer obj
:pointer iid-null
:pointer names
uint 1
lcid 0
:pointer id
hresult)
(format nil "GetIDsOfNames(~A)" name))
(mem-ref id 'dispid)))))))
(defun bstr->string (bstr)
"Convert BSTR to Lisp string."
;; SysStringLen returns UTF-16 code units, not bytes.
(let ((chars (syslen bstr)))
(foreign-string-to-lisp bstr
:count (* chars 2)
:encoding :utf-16le)))
(defun get-current-directory (obj)
"Call WScript.Shell.CurrentDirectory via IDispatch::Invoke."
(let ((fn (vt-fn obj 6)) ; IDispatch::Invoke
(id (get-dispid obj "CurrentDirectory")))
(with-foreign-object (iid-null '(:struct guid))
(with-foreign-object (dp '(:struct dispparams))
(with-foreign-object (res '(:struct variant))
;; riid must be IID_NULL
(zero-memory iid-null (foreign-type-size '(:struct guid)))
(zero-memory dp (foreign-type-size '(:struct dispparams)))
(zero-memory res (foreign-type-size '(:struct variant)))
;; no arguments for property get
(setf (foreign-slot-value dp '(:struct dispparams) 'rgvarg)
(null-pointer))
(setf (foreign-slot-value dp '(:struct dispparams) 'rgdispidNamedArgs)
(null-pointer))
(setf (foreign-slot-value dp '(:struct dispparams) 'cArgs) 0)
(setf (foreign-slot-value dp '(:struct dispparams) 'cNamedArgs) 0)
(check
(foreign-funcall-pointer fn
(:convention :stdcall)
:pointer obj
dispid id
:pointer iid-null
lcid 0
word +dispatch-propertyget+
:pointer dp
:pointer res
:pointer (null-pointer)
:pointer (null-pointer)
hresult)
"Invoke(CurrentDirectory)")
;; VT_BSTR expected
(unless (= (foreign-slot-value res '(:struct variant) 'vt) +vt-bstr+)
(error "CurrentDirectory returned unexpected VT=~A"
(foreign-slot-value res '(:struct variant) 'vt)))
(let ((bstr (mem-ref (inc-pointer res 8) :pointer)))
(bstr->string bstr)))))))
(defun demo ()
"Create WScript.Shell, read CurrentDirectory, print and return it."
(check (coinit (null-pointer) +coinit-apartmentthreaded+)
"CoInitializeEx")
(let ((obj (null-pointer)))
(unwind-protect
(progn
(setf obj (create-shell))
(let ((dir (get-current-directory obj)))
(format t "CurrentDirectory => ~A~%" dir)
dir))
(unless (null-pointer-p obj)
(ignore-errors
(release obj)))
(ignore-errors
(couninit)))))
You can run it like below
; SLIME 2.32
CL-USER> (load "~/quicklisp/setup.lisp")
T
CL-USER> (ql:quickload :cffi)
To load "cffi":
Load 1 ASDF system:
cffi
; Loading "cffi"
..............
(:CFFI)
CL-USER> (load "c:/lang/sbclwork/shell-min.lisp")
T
CL-USER> (shell-min:demo)
CurrentDirectory => c:\lang\emacs-30.2\bin
"c:\\lang\\emacs-30.2\\bin"
CL-USER>
