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>