;; @module winscript
;; @description Embedded VBScript/JScript in newLISP.
;; @version 0.23
;; @author m35
;;
;; @location http://www.autohotkey.net/~easycom/winscript.lsp
;;
;;  http://www.autohotkey.net/~easycom/winscript.lsp
;; This module uses the COM/OLE Microsoft Scripting Control object to execute
;; VBScript or JScript. Most computers have it installed by default. It can
;; also be downloaded directly from Microsoft.
;;
;; http://www.microsoft.com/downloads/details.aspx?FamilyId=D7E31492-2595-49E6-8C02-1426FEC693AC
;;
;; Change log:
;;
;; 0.10 - Initial release.
;;
;; 0.11 - Fixed memory leak when unhandled type is returned.
;;        Improved get-short and get-single functions.
;;
;; 0.12 - Fixed handling of automation errors.
;;
;; 0.20 - Large internal changes to properly handle errors. This fixes
;;        memory leaks and provides more comprehensive error information.
;;        Added '(WINSCRIPT:LastResult)' function to return the results of
;;        win32api calls.
;;
;; 0.21 - Added missing cleanup if failure during initialization.
;;
;; 0.22 - Minor documentation improvements.
;;        Added check at initialization if already initialized.
;;        Fixed error handling when the error doesn't come from the script control.
;;        Lots of internal cleaning and comments.
;;
;; 0.23 - changed import type constant 265 to 2312 as required since 10.4.0 , L.M.
;;
;; Tested with newLISP 9.2.0 and 9.4.3.
;;
;; Contact me (m35) in the newLISP Fan Club forum
;; @link http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1983
;; http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1983
;;
;; A good list of automation error descriptions can be found in
;; @link http://support.microsoft.com/kb/186063 KB186063

;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec {foo = "bar"})
;; true
;; > (WINSCRIPT:Eval {foo})
;; "bar"
;; > (WINSCRIPT:Uninitialize)
;; true

;; @example
;; > (WINSCRIPT:Initialize "VBScript")
;; true
;; > (WINSCRIPT:Exec {Set oSp = CreateObject("SAPI.SpVoice")})
;; true
;; > (WINSCRIPT:Exec {oSp.Speak "newLISP: Puts the fun back in LISP"})
;; true

;; @example
;; ; this example requires Microsoft Excel to be installed.
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec {Set xl = CreateObject("Excel.Application")})
;; true
;; > (WINSCRIPT:Exec {xl.Visible = True})
;; true
;; > (WINSCRIPT:Exec {Set rng = xl.Workbooks.Add().Worksheets(1).Cells(1, 1)})
;; true
;; > (WINSCRIPT:Exec {rng.Value = 1.2345})
;; true
;; > (WINSCRIPT:Eval {rng.Value})
;; 1.2345
;; > (WINSCRIPT:Exec {xl.DisplayAlerts = False})
;; true
;; > (WINSCRIPT:Exec {xl.Quit})
;; true
;; > (WINSCRIPT:Uninitialize)
;; true


(context 'WINSCRIPT)

(constant 'IID_IDispatch        "{00020400-0000-0000-C000-000000000046}" )
(constant 'IID_IUnknown         "{00000000-0000-0000-C000-000000000046}" )
(constant 'ProgId_ScriptControl "MSScriptControl.ScriptControl"          )
(constant 'CLSID_ScriptControl  "{0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC}" )
(constant 'IID_ScriptControl    "{0E59F1D3-1FBE-11D0-8FF2-00A0D10038BC}" )

(constant 'CLSCTX_INPROC_SERVER   1   )
(constant 'CLSCTX_INPROC_HANDLER  2   )
(constant 'CLSCTX_LOCAL_SERVER    4   )
(constant 'CLSCTX_INPROC_SERVER16 8   )
(constant 'CLSCTX_REMOTE_SERVER   16  )

(define __iScriptControlObj__ nil)
(define __iScriptErrorObj__   nil)
(define __sScriptLanguage__   nil)
(define __LastResult__        '())


;; @syntax (WINSCRIPT:Initialize [<str-language>="VBScript"])
;; @param <str-language> either '"VBScript"' or '"JScript"'
;; @return true on success, '(throw-error)' on error
;; Initializes the scripting environment. Must be called before any other
;; functions can be used.
;;
;; If the scripting environment has already been initialized,
;; this function does nothing.
(define (Initialize (sLanguage "VBScript")
    , @iCoInit @iScriptCtrl @iScriptErr @xLangRet)

    ; Check if already initialized
    (if (not (and (integer? __iScriptControlObj__) (!= __iScriptControlObj__ 0)))
    (begin

        ; initialize COM
        (setq @iCoInit (_CoInitialize))
        (if (failed? @iCoInit)
            (throw-error (last (setq __LastResult__
                (err-msg @iCoInit)
            )))
        )

        ; create a scripting control
        (setq @iScriptCtrl (__CreateObjectProgId ProgId_ScriptControl IID_ScriptControl))
        (if (failed? @iScriptCtrl) (begin
            (Uninitialize)
            (throw-error (last (setq __LastResult__
                (join-err @iCoInit @iScriptCtrl)
            )))
        ))

        ; save it
        (setq __iScriptControlObj__ (ret-val @iScriptCtrl))

        ; get the scripting error object
        (setq @iScriptErr (IScriptControl.Error __iScriptControlObj__))
        (if (failed? @iScriptErr) (begin
            (Uninitialize)
            (throw-error (last (setq __LastResult__
                (join-err @iCoInit @iScriptCtrl @iScriptErr)
            )))
        ))

        ; save it
        (setq __iScriptErrorObj__ (ret-val @iScriptErr))

        ; set the scripting language
        (setq @xLangRet (IScriptControl.Language __iScriptControlObj__ sLanguage))
        (if (failed? @xLangRet) (begin
            (Uninitialize)
            (throw-error (last (setq __LastResult__
                (join-err @iCoInit @iScriptCtrl @iScriptErr @xLangRet)
            )))
        ))

        ; save it
        (setq __sScriptLanguage__ sLanguage)

        ; save the result stack
        (setq __LastResult__
            (join-err @iCoInit @iScriptCtrl @iScriptErr @xLangRet)
        )
    ));/if not already initialized
    true ; no error occured
)



(import "ole32.dll" "CoUninitialize")

;; @syntax (WINSCRIPT:Uninitialize)
;; @return 'true'
;; Releases memory for scripting environment. Does not have to be called before
;; exiting the program, but it is good practice.
;;
;; If the scripting environment is not initialized, this function does nothing.
(define (Uninitialize)
    (if (and (integer? __iScriptErrorObj__) (!= __iScriptErrorObj__ 0))
        (IUnknown.Release __iScriptErrorObj__)
    )

    (if (and (integer? __iScriptControlObj__) (!= __iScriptControlObj__ 0))
        (IUnknown.Release __iScriptControlObj__)
    )

    (CoUninitialize)

    (setq __iScriptControlObj__ nil)
    (setq __iScriptErrorObj__   nil)
    (setq __sScriptLanguage__   nil)
    (setq __LastResult__        '())
    true ; return
)


;; @syntax (WINSCRIPT:Exec <str-code>)
;; @param <str-code> code to execute
;; @return 'true' on success, '(throw-error)' on error.
;; Executes the scripting code.
(define (Exec sCode , @varReturn)
    ; make sure WINSCRIPT has been initialized
    (if (nil? __iScriptControlObj__)
        (throw-error "Windows scripting has not been initialized")
    )

    ; try to execute the code
    (setq @varReturn (IScriptControl.ExecuteStatement __iScriptControlObj__ sCode))

    ; was it successful?
    (if (success? @varReturn)
        ; then
        (begin
            ; set __LastResult__ to the returned stack of 'errors'
            (setq __LastResult__ (err-msg @varReturn))
            true ; return
        )
        ; else
        (begin
            (_HandleError @varReturn)
            ; __LastResult__ now holds all the 'errors' up to this point
            ; clear the scripting error
            (IScriptError.Clear __iScriptErrorObj__)
            ; throw-error only the top-most error on the stack
            (throw-error (last __LastResult__))
        ) ;/begin
    )
)


;; @syntax (WINSCRIPT:Eval <str-code>)
;; @param <str-code> code to evaluate
;; @return resulting value on success, '(throw-error)' on error.
;; Evaluates the scripting code and returns the result. Returned types can be
;; String, Byte, Integer, Long, Float, Double, Boolean ('true' or 'nil'),
;; or object pointer. Uninitialized variables ("Empty") are returned as an
;; empty list. The remaining types (Arrays, Currency, Date, VARIANT*, and
;; DECIMAL*) are not handled and will cause an error if returned. Convert these
;; unhandled types to handled type (such as String) to return the value.
;;
;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Eval "Now()")
;; user error : Unhandled variant type
;; called from user defined function WINSCRIPT:Eval
;; > (WINSCRIPT:Eval "CStr(Now())")
;; "1/9/2008 10:07:10 PM"

(define (Eval sCode , @varReturn @nlRet)
    ; make sure WINSCRIPT has been initialized
    (if (nil? __iScriptControlObj__)
        (throw-error "Windows scripting has not been initialized")
    )


    ; try to evaluate the code
    (setq @varReturn (IScriptControl.Eval __iScriptControlObj__ sCode))
    ; was it successful?
    (if (success? @varReturn)
        ; [then]
        (begin
            ; try to convert the return VARIANT to a newlisp variable
            (setq @nlRet (__UnpackVARIANT (ret-val @varReturn)))
            ; regardless of success, pack the 'error' stack into __LastResult__
            (setq __LastResult__
                (join-err @varReturn @nlRet)
            )
            ; now if it was actually successful...
            (if (success? @nlRet)
                ; return the result
                (ret-val @nlRet) ; return
                ; or throw an error
                (throw-error (last __LastResult__))
            )
        )
        ; [else]
        (begin
            (_HandleError @varReturn)
            ; __LastResult__ now holds all the 'errors' up to this point
            ; clear the scripting error
            (IScriptError.Clear __iScriptErrorObj__)
            ; throw-error only the top-most error on the stack
            (throw-error (last __LastResult__))
        )
    )
)

; Sets __LastResult__ with all the 'errors' found.
(define (_HandleError @varReturn , @sErrorDesc @iErrNum )

    ; If there was an error calling
    ; IScriptControl.ExecuteStatement or IScriptControl.Eval
    ; (this is kinda sloppy, but it'll work)
    (if (starts-with (last (err-msg @varReturn)) "IScriptControl.E")
        ; [then]
        (begin
            ; try to get the error description
            (setq @sErrorDesc (IScriptError.Description __iScriptErrorObj__))

            (if (or (= "" (ret-val @sErrorDesc)) ; if we got an empty string
                    (nil? (ret-val @sErrorDesc)) ; or a null string
                    (failed? @sErrorDesc))       ; or failed to get anything
                ; [then]
                (begin
                    ; try to get the error number instead
                    (setq @iErrNum (IScriptError.Number __iScriptErrorObj__))
                    ; did we get the number?
                    (if (success? @iErrNum)
                        ; [then]
                        ; set __LastResult__ to the stack of 'errors'
                        ; from all the calls up to this point,
                        ; including the automation error
                        (setq __LastResult__
                            (join-err @varReturn @sErrorDesc @iErrNum
                                (string "Automation error " (ret-val @iErrNum))
                            )
                        )
                        ; [else]
                        ; set __LastResult__ to the stack of 'errors'
                        ; from all the calls up to this point
                        ; (if we've reached this point, there has been a
                        ;  major failure somewhere)
                        (setq __LastResult__
                            (join-err @varReturn @sErrorDesc @iErrNum)
                        )
                    )
                )
                ; [else]
                ; we got an error description, set __LastResult__ to the stack
                ; of 'errors' from previous calls, including the error description.
                (setq __LastResult__
                    (join-err @varReturn @sErrorDesc (ret-val @sErrorDesc))
                )
            ) ;/if we didn't get any error message
        )
        ; [else]
        (begin
            (setq __LastResult__ @varReturn)
        )
    )
    nil ; this is a void function
)


;; @syntax (WINSCRIPT:LastResult)
;; @return list of win32api function results during the last WINSCRIPT call.
;; The returned list of strings will hold the results of all win32api functions
;; that could have failed during the last operation. If the most recent
;; operation threw an error, the last item in the list will be the error message
;; thrown.
;;
;; @example
;; > (WINSCRIPT:Initialize)
;; true
;; > (WINSCRIPT:Exec "#$@#$$^$&*&&")
;; user error : Expected statement
;; called from user defined function WINSCRIPT:Exec
;; > (WINSCRIPT:LastResult)
;; ("MultiByteToWideChar ok" "SysAllocString ok"
;;  "IScriptControl.ExecuteStatement -2146827264"
;;  "IScriptError.Description 0" "WideCharToMultiByte ok" "Expected statement")

(define (LastResult)
    __LastResult__
)


;###############################################################################

; == Tier 1 COM Internals ======================================================

(import "ole32.dll" "CoInitialize")

; Initializes COM
; @return (success? ret-val errmsg)
(define (_CoInitialize , iErr)
    (setq iErr (CoInitialize 0))

    (return
        (>= iErr 0) ; success?
        nil         ; never a return value
        (list (string "CoInitialize " iErr)) ; error result
    )
)

; == Tier 2 COM Internals ======================================================

; Creates an object from a Prog ID
; (e.g. "Excel.Application")
; @return (success? ret-val errmsg)
(define (__CreateObjectProgId sProgId sIId , @sbinClsId @sbinIId @iObjPtr)
    (catch (begin

        ; get the binary class id from the prog id
        (setq @sbinClsId (__CLSIDFromProgID sProgId))
        (if (failed? @sbinClsId) (throw
            (return
                nil ; fail
                nil
                (err-msg @sbinClsId)
            )
        ))

        ; convert the interface id to its binary form
        (setq @sbinIId (__IIDFromString sIId))
        (if (failed? @sbinIId) (throw
            (return
                nil ; fail
                nil
                (join-err @sbinClsId @sbinIId)
            )
        ))

        ; create the object
        (setq @iObjPtr (__CreateInstance (ret-val @sbinClsId) (ret-val @sbinIId)))
        (return
            (success? @iObjPtr)
            (ret-val @iObjPtr)
            (join-err @sbinClsId @sbinIId @iObjPtr)
        )
    ))
)

; == Tier 3 COM Internals ======================================================

(import "ole32.dll" "CoCreateInstance")

; Creates an object from the binary form of its Class ID and Interface ID
; @return (success? ret-val errmsg)
(define (__CreateInstance sbinClassId sbinIId , iObjPtr iErr)
    (setq iObjPtr 0)
    (setq iErr (CoCreateInstance
                    sbinClassId
                    0
                    (| CLSCTX_INPROC_SERVER CLSCTX_LOCAL_SERVER)
                    sbinIId
                    (address iObjPtr)))

    (return
        (>= iErr 0)
        (if (>= iErr 0) iObjPtr nil)
        (list (string "CoCreateInstance " iErr))
    )
)


(import "ole32.dll" "CLSIDFromProgID")

; Looks up the binary Class ID of a Program ID
(define (__CLSIDFromProgID sProgId , @wsProgId sbinClassId iErr)
    (catch (begin

        ; convert the progid to unicode
        (setq @wsProgId (__ANSI2Unicode sProgId))
        (if (failed? @wsProgId) (throw
            (return
                nil ; fail
                nil
                (err-msg @wsProgId)
            ))
        )

        ; get the binary class id for the prog id
        (setq sbinClassId (dup " " 16))
        (setq iErr (CLSIDFromProgID (ret-val @wsProgId) sbinClassId))

        (return
            (>= iErr 0) ; success?
            (if (>= iErr 0) sbinClassId nil) ; return value
            (join-err @wsProgId (string "CLSIDFromProgID " iErr)) ; error
        )
    ))
)


(import "ole32.dll" "IIDFromString")

; Converts a string Interface ID to a binary Interface ID
; (I really don't see why Win API has a separate function to do this)
; @return (success? ret-val errmsg)
(define (__IIDFromString sIId , @wsIId sbinIId iErr)
    (catch (begin
        ; convert the interface id to unicode
        (setq @wsIId (__ANSI2Unicode sIId))
        (if (failed? @wsIId) (throw
            (return
                nil ; fail
                nil
                (err-msg @wsIId)
            )
        ))

        ; convert it to binary
        (setq sbinIId (dup " " 16))
        (setq iErr (IIDFromString (ret-val @wsIId) sbinIId))
        (return
            (>= iErr 0) ; success?
            (if (>= iErr 0) sbinIId nil) ; return
            (join-err @wsIId (string "IIDFromString " iErr)) ; error
        )
    ))
)

; ## IScriptControl ############################################################
; The entire IScriptControl Vtable (only the * members are implemented)
; 0   call_QueryInterface   - Returns a pointer to a specified interface on an
;                             object to which a client currently holds an
;                             interface pointer
; 1   call_AddRef           - Increments the reference count for an interface
;                             on an object
; 2   call_Release          - Decrements the reference count for the calling
;                             interface on a object
; 3   call_GetTypeInfoCount - Retrieves the number of type information
;                             interfaces that an object provides (either 0 or 1)
; 4   call_GetTypeInfo      - Retrieves the type information for an object
; 5   call_GetIDsOfNames    - Maps a single member and an optional set of
;                             argument names to a corresponding set of integer
;                             DISPIDs
; 6   call_Invoke           - Provides access to properties and methods exposed
;                             by an object.
; 7 * get_Language          - Language engine to use
; 8 * put_Language          - Language engine to use
; 9   get_State             - State of the control
;10   put_State             - State of the control
;11   put_SitehWnd          - hWnd used as a parent for displaying UI
;12   get_SitehWnd          - hWnd used as a parent for displaying UI
;13   get_Timeout           - Length of time in milliseconds that a script can
;                             execute before being considered hung
;14   put_Timeout           - Length of time in milliseconds that a script can
;                             execute before being considered hung
;15   get_AllowUI           - Enable or disable display of the UI
;16   put_AllowUI           - Enable or disable display of the UI
;17   get_UseSafeSubset     - Force script to execute in safe mode and disallow
;                             potentially harmful actions
;18   put_UseSafeSubset     - Force script to execute in safe mode and disallow
;                             potentially harmful actions
;19   get_Modules           - Collection of modules for the ScriptControl
;20 * get_Error             - The last error reported by the scripting engine
;21   get_CodeObject        - Object exposed by the scripting engine that
;                             contains methods and properties defined in the
;                             code added to the global module
;22   get_Procedures        - Collection of procedures that are defined in the
;                             global module
;23   call__AboutBox        -
;24   call_AddObject        - Add an object to the global namespace of the
;                             scripting engine
;25   call_Reset            - Reset the scripting engine to a newly created
;                             state
;26   call_AddCode          - Add code to the global module
;27 * call_Eval             - Evaluate an expression within the context of the
;                             global module
;28 * call_ExecuteStatement - Execute a statement within the context of the
;                             global module
;29   call_Run              - Call a procedure defined in the global module
;


; @syntax (IScriptControl.Language [sLanguage])
; @param <ppvScriptControl> (int) Pointer to script control object
; @param <sLanguage> (optional string) Scripting language (VBScript or JScript)
; @return (success? ret-val errmsg)
;
; If sLanguage is provided, sets the scripting language. Otherwise returns the
; currenet scripting language.
; Note: Changing the scripting language seems to reset the environment
(define (IScriptControl.Language ppvScriptControl (sLanguage nil)
                                 , @bstrLang iErr)

    (catch
        (if sLanguage
            ; [then] Put language
            (begin
                ; convert string to BSTR
                (setq @bstrLang (__SysAllocStringA sLanguage))
                (if (failed? @bstrLang) (throw
                    (return
                        nil ; fail
                        nil
                        (err-msg @bstrLang)
                    )
                ))

                ; put the language
                (setq iErr
                    ((ptr-to-fn (__VTable ppvScriptControl 8)) ppvScriptControl
                                (ret-val @bstrLang)))
                (SysFreeString (ret-val @bstrLang))

                ; return
                (return
                    (>= iErr 0)
                    nil ; fail
                    (join-err
                        @bstrLang
                        (string "IScriptControl.Language put " iErr)
                    )
                )
            )
            ; [else] Get language
            (begin
                ; get the language
                (setq @bstrLang 0)
                (setq iErr
                    ((ptr-to-fn (__VTable ppvScriptControl 7)) ppvScriptControl
                                 (address @bstrLang)))
                (if (< iErr 0) (throw
                    (return
                        nil ; failed
                        nil ; no return value
                        (list (string "IScriptControl.Language get " iErr)) ; error
                    )
                ))

                ; convert the BSTR language to string
                (setq sLanguage (__Unicode2ANSI @bstrLang))
                (SysFreeString @bstrLang) ; free the BSTR
                (return
                    (success? sLanguage)
                    (if (success? sLanguage) (ret-val sLanguage) nil)
                    (join-err
                        (string "IScriptControl.Language get " iErr)
                        sLanguage
                    )
                )
            )
        );/if
    );/catch
)

; Pointer to Error object
; @return (success? ret-val errmsg)
(define (IScriptControl.Error ppvScriptControl , ppvScriptError iErr)
    (setq ppvScriptError 0)
    (setq iErr ((ptr-to-fn (__VTable ppvScriptControl 20)) ppvScriptControl
                (address ppvScriptError)))

    (return
        (>= iErr 0)
        (if (>= iErr 0) ppvScriptError nil)
        (list (string "IScriptControl.Error " iErr))
    )
)

; @return (success? ret-val errmsg)
(define (IScriptControl.Eval ppvScriptControl sExpression
                             , @bstrExpression VariantRet iErr)
    (catch (begin

        ; convert code to BSTR
        (setq @bstrExpression (__SysAllocStringA sExpression))
        (if (failed? @bstrExpression) (throw
            (return
                nil
                nil
                (err-msg @bstrExpression)
            )
        ))

        ; execute the code
        (setq VariantRet (dup " " 16))
        (setq iErr ((ptr-to-fn (__VTable ppvScriptControl 27)) ppvScriptControl
                (ret-val @bstrExpression)
                VariantRet))
        ; free the BSTR
        (SysFreeString (ret-val @bstrExpression))

        (return
            (>= iErr 0)
            (if (>= iErr 0) VariantRet nil)
            (join-err @bstrExpression (string "IScriptControl.Eval " iErr))
        )
    ))
)

; @return (success? ret-val errmsg)
(define (IScriptControl.ExecuteStatement ppvScriptControl sStatement
                                         , @bstrExpression iErr)

    (catch (begin
        ; convert code to BSTR
        (setq @bstrExpression (__SysAllocStringA sStatement))
        (if (failed? @bstrExpression) (throw
            (return
                nil ; fail
                nil
                (err-msg @bstrExpression)
            )
        ))

        ; execute the code
        (setq iErr ((ptr-to-fn (__VTable ppvScriptControl 28)) ppvScriptControl
                (ret-val @bstrExpression)))
        ; free the BSTR
        (SysFreeString (ret-val @bstrExpression))

        (return
            (>= iErr 0)
            nil
            (join-err @bstrExpression (string "IScriptControl.ExecuteStatement " iErr))
        )
    ))
)

; ## IScriptError ##############################################################
;The entire IScriptError Vtable (only the * members are implemented)
; 0   call_QueryInterface   - Returns a pointer to a specified interface on an
;                             object to which a client currently holds an
;                             interface pointer
; 1   call_AddRef           - Increments the reference count for an interface
;                             on an object
; 2   call_Release          - Decrements the reference count for the calling
;                             interface on a object
; 3   call_GetTypeInfoCount - Retrieves the number of type information
;                             interfaces that an object provides (either 0 or 1)
; 4   call_GetTypeInfo      - Retrieves the type information for an object
; 5   call_GetIDsOfNames    - Maps a single member and an optional set of
;                             argument names to a corresponding set of
;                             integer DISPIDs
; 6   call_Invoke           - Provides access to properties and methods
;                             exposed by an object.
; 7 * get_Number            - Error number
; 8   get_Source            - Source of the error
; 9 * get_Description       - Friendly description of error
;10   get_HelpFile          - File in which help for the error can be found
;11   get_HelpContext       - Context ID for the topic with information on
;                             the error
;12   get_Text              - Line of source code on which the error occurred
;13   get_Line              - Source code line number where the error occurred
;14   get_Column            - Source code column position where the
;                             error occurred
;15 * call_Clear            - Clear the script error

; @return (success? ret-val errmsg)
(define (IScriptError.Number ppvScriptError , iNum iErr)
    (setq iNum 0)
    (setq iErr ((ptr-to-fn (__VTable ppvScriptError 7)) ppvScriptError
                (address iNum)))

    (if (>= iErr 0)
        ; [then]
        (return
            true ; success
            (first (unpack "ld" (address iNum))) ; make signed int
            (list (string "IScriptError.Number " iErr))
        )
        ; [else]
        (return
            nil ; fail
            nil
            (list (string "IScriptError.Number " iErr))
        )
    )
)

; Returns either an error string, or nil if there is no error string.
; @return (success? ret-val errmsg)
(define (IScriptError.Description ppvScriptError , bstrDescription sAnsi iErr)
    (catch (begin

        (setq bstrDescription 0)
        (setq iErr ((ptr-to-fn (__VTable ppvScriptError 9)) ppvScriptError
                    (address bstrDescription)))
        (if (< iErr 0) (throw
            (return
                nil ; fail
                nil
                (list (string "IScriptError.Description " iErr))
            )
        ))

        ; if BSTR is null
        (if (zero? bstrDescription)
            ; then
            (return
                true ; success
                nil  ; but no description
                (list (string "IScriptError.Description " iErr))
            )
            ; else
            (begin
                ; convert to newlisp string
                (setq sAnsi (__Unicode2ANSI bstrDescription))
                ; free BSTR
                (SysFreeString bstrDescription)
                (return
                    (success? sAnsi)
                    (ret-val sAnsi)
                    (join-err (string "IScriptError.Description " iErr) sAnsi)
                )
            )
        )
    ))
)

; @return (success? ret-val errmsg)
(define (IScriptError.Clear ppvScriptError , iErr)

    (setq iErr ((ptr-to-fn (__VTable ppvScriptError 15)) ppvScriptError))

    (return
        (>= iErr 0)
        nil
        (list (string "IScriptError.Clear " iErr))
    )
)

; ## IUnknown ##################################################################
;The entire IUnknown Vtable (all members are implemented)
; 0   call_QueryInterface   - Returns a pointer to a specified interface on an
;                             object to which a client currently holds an
;                             interface pointer
; 1   call_AddRef           - Increments the reference count for an interface
;                             on an object
; 2   call_Release          - Decrements the reference count for the calling
;                             interface on a object

; @return (success? ret-val errmsg)
(define (IUnknown.QueryInterface ppVtbl sInterfaceId
    , @binInterfaceId ppvNewInterface iErr)

    (catch (begin
        ; convert interface id string to binary
        (setq @binInterfaceId (__IIDFromString sInterfaceId))
        (if (failed? @binInterfaceId) (throw
            (return
                nil ; failed
                nil
                (err-msg @binInterfaceId)
            )
        ))

        ; call QueryInterface
        (setq ppvNewInterface 0)
        (setq iErr ((ptr-to-fn (__VTable ppVtbl 0)) ppVtbl
                    (ret-val @binInterfaceId) (address ppvNewInterface)))

        (return
            (>= iErr 0)
            (if (>= iErr 0) ppvNewInterface nil)
            (join-err @binInterfaceId (string "IUnknown.QueryInterface " iErr))
        )
    ))
)

; @return number of references that remain
(define (IUnknown.Release ppv)
    ((ptr-to-fn (__VTable ppv 2)) ppv) ; return
)


; ## Helper functions ##########################################################

(define (__VTable ppVtbl iIdx)
    (get-int (+ (get-int ppVtbl) (* 4 iIdx)))
)


; Helper function to convert a pointer to a function
(define (ptr-to-fn iPtr , fnFuncPtr)
    ; get function template
    (set 'fnFuncPtr import)

    ; change type to library import and OS calling conventions
    (cpymem (pack "ld" 2312) (first (dump fnFuncPtr)) 4) ; Win32 stdcall
    ; set code pointer
    (cpymem (pack "ld" iPtr) (+ (first (dump fnFuncPtr)) 12) 4)
    fnFuncPtr
)


(import "oleaut32" "VariantInit")
(import "oleaut32" "VariantClear")
(import "oleaut32" "SysFreeString")
(import "oleaut32" "SysAllocString")

; @return (success? ret-val errmsg)
(define (__SysAllocStringA sAnsi , @sUnicode iBstrPtr)
    (catch (begin
        ; convert string to unicode
        (setq @sUnicode (__ANSI2Unicode sAnsi))
        (if (failed? @sUnicode) (throw
            (return
                nil ; failed
                nil
                (err-msg @sUnicode)
            )
        ))

        ; convert to BSTR
        (setq iBstrPtr (SysAllocString (ret-val @sUnicode)))

        (if (zero? iBstrPtr)
            ; [then]
            (return
                nil ; failed
                nil
                (join-err @sUnicode "SysAllocString fail")
            )
            ; [else]
            (return
                true ; success
                iBstrPtr
                (join-err @sUnicode "SysAllocString ok")
            )
        )
    ))
)

; Converts a VARIANT structure to a normal AHK variable.
; Not all VARIANT types are handled.
; @return (success? ret-val errmsg)
(define (__UnpackVARIANT sVariantStruct , iVariantType pData s)

    (setq iVariantType (get-short (address sVariantStruct)))
    (setq pData (+ (address sVariantStruct) 8))

    (case iVariantType
        ; VT_BSTR
        (0x0008
            (setq s (__Unicode2ANSI (get-int pData)))
            (VariantClear sVariantStruct)
            (if (success? s)
                (return true (ret-val s) (err-msg s))
                (return nil nil (err-msg s))
            )
        )
        (0x4008
            (setq s (__Unicode2ANSI (get-int (get-int pData))))
            (VariantClear sVariantStruct)
            (if (success? s)
                (return true (ret-val s) (err-msg s))
                (return nil nil (err-msg s))
            )
        )
        ; VT_EMPTY
        (0x0000 (return true '() '()))
        ; VT_UI1
        (0x0011 (return true (get-char pData) '()))
        (0x4011 (return true (get-char (get-int pData)) '()))
        ; VT_I2
        (0x0002 (return true (get-short pData) '()))
        (0x4002 (return true (get-short (get-int pData)) '()))
        ; VT_I4
        (0x0003 (return true (get-int pData) '()))
        (0x4003 (return true (get-int (get-int pData)) '()))
        ; VT_R4
        (0x0004 (return true (get-single pData) '()))
        (0x4004 (return true (get-single (get-int pData)) '()))
        ; VT_R8
        (0x0005 (return true (get-float pData) '()))
        (0x4005 (return true (get-float (get-int pData)) '()))
        ; VT_BOOL
        (0x000B (return true (!= 0 (get-short pData)) '()))
        (0x400B (return true (!= 0 (get-short (get-int pData))) '()))
        ; VT_ERROR
        (0x000A (return true (get-int pData) '()))
        (0x400A (return true (get-int (get-int pData)) '()))
        ; VT_DISPATCH
        (0x0009 (return true (get-int pData) '()))
        (0x4009 (return true (get-int (get-int pData)) '()))
        ; VT_UNKNOWN
        (0x000D (return true (get-int pData) '()))
        (0x400D (return true (get-int (get-int pData)) '()))
        (true
            ; Unhandled VARIANT types:
            ; Array, Currency, Date, VARIANT*, and DECIMAL*
            (VariantClear sVariantStruct)
            (return nil nil '("Unhandled variant type"))
        )

    )
)

(define (get-short int-address)
    (first (unpack "d" int-address))
)

(define (get-single int-address)
    (first (unpack "f" int-address))
)

(import "kernel32.dll" "MultiByteToWideChar")

; @return (success? ret-val errmsg)
(define (__ANSI2Unicode sAnsi , iSize sUtf16)
    (catch (begin
        ; TODO: Maybe check if this is utf8 enabled newLISP and convert from utf8 instead of ANSI
        (setq iSize (MultiByteToWideChar
                        0  ; from CP_ACP (ANSI)
                        0  ; no flags
                        sAnsi
                        -1 ; until NULL
                        0  ; NULL
                        0))

        (if (< iSize 1) (throw
            (return
                nil ; fail
                nil
                (list (string "MultiByteToWideChar failed to convert string " sAnsi))
            )
        ))

        (setq sUtf16 (dup " " (* iSize 2)))

        (setq iSize (MultiByteToWideChar
                        0  ; from CP_ACP (ANSI)
                        0  ; no flags
                        sAnsi
                        -1 ; until NULL
                        sUtf16
                        iSize))

        (if (< iSize 1) (throw
            (return
                nil ; fail
                nil
                (list (string "MultiByteToWideChar failed to convert string " sAnsi))
            )
        ))

        (return
            true ; success
            sUtf16
            (list "MultiByteToWideChar ok")
        )
    ))
)

(import "kernel32.dll" "WideCharToMultiByte")

; @param s|pUtf16  Can pass either a string or integer-pointer to utf16 string.
; @return (success? ret-val errmsg)
(define (__Unicode2ANSI s|pUtf16 , iSize sAnsi)
    (catch (begin
        ; TODO: Maybe check if this is utf8 enabled newLISP and convert to utf8 instead of ANSI
        (setq iSize (WideCharToMultiByte
                         0  ; to CP_API (ANSI)
                         0  ; no flags
                         s|pUtf16
                        -1  ; until NULL
                         0  ; NULL
                         0  ; Just find length
                         0  ; NULL
                         0) ; NULL
        )

        (if (< iSize 1) (throw
            (return
                nil
                nil
                (list (string "WideCharToMultiByte failed to convert string " s|pUtf16))
            )
        ))

        (setq sAnsi (dup " " (+ iSize 1)))

        (setq iSize (WideCharToMultiByte
                         0  ; to CP_API (ANSI)
                         0  ; no flags
                         s|pUtf16
                        -1  ; until NULL
                        sAnsi
                        iSize
                         0  ; NULL
                         0) ; NULL
        )

        (if (< iSize 1) (throw
            (return
                nil ; fail
                nil
                (list (string "WideCharToMultiByte failed to convert string " s|pUtf16))
            )
        ))

        (return
            true ; success
            (get-string sAnsi)
            (list "WideCharToMultiByte ok")
        )
    ))
)

;-------------------------------------------------------------------------------
; The following functions help with error handling.
;
; Most functions return a three item list:
; item 0 success?: true = function succeeded, false = function failed
; item 1 ret-val : on success, the actual return value. on failure, nil
; item 2 err-msg : a list of strings describing results of all win32 api calls
;
; Variables that hold this special type of list are prefixed with
; an at (@) symbol, followed by hungarian notaion of the
; data type found in the second item of the list.

(define return list)

(define (failed? lst)
    (not (lst 0))
)

(define (success? lst)
    (lst 0)
)

(define (ret-val lst)
    (lst 1)
)

(define (err-msg lst)
    (lst 2)
)

; joins all arguments into a list
; if an argument is a list, it is assume to be the
; (success? ret-val err-msg) format, so it only takes the 3rd item in the list.
; Otherwise it just uses the argument as is.
(define (join-err)
    (apply
        append
        (map
            (fn (x)
                (if (list? x) (err-msg x) (list x))
            )
            (args)
        )
    )
)

;-------------------------------------------------------------------------------

(context 'MAIN)