' com/vbobject.ab

#require <com/variant.ab>

Namespace ActiveBasic
Namespace COM

Class VBObjectBase
	Implements System.IDisposable, System.IEquatable<VBObjectBase>
Public
	Sub VBObjectBase()
		disp = Nothing
	End Sub

	Sub VBObjectBase(dispObj As IDispatch)
		copy(disp, dispObj)
	End Sub

	Sub ~VBObjectBase()
		Dispose()
	End Sub

	Sub Clear()
		Dispose()
	End Sub

	Virtual Sub Dispose()
		If ObjPtr(disp) <> 0 Then
			disp.Release()
			disp = Nothing
		End If
	End Sub

'	Override Function Equals(y As Object) As Boolean
'	End Function

	Virtual Function Equals(y As VBObjectBase) As Boolean
		Return Detail.COMReferenceEquals(This.Dispatch, y.Dispatch)
	End Function
/*
	Override Function GetHashCode() As Long
		Dim punk = _System_GetUnknown(pdisp)
		GetHashCode = _System_HashFromPtr(punk)
		punk->Release()
	End Function
*/

	Function Copy() As IDispatch
		copy(Copy, disp)
	End Function

	Sub Attach(ByRef y As IDispatch)
'		Clear()
'		move(pdisp, y)
	End Sub

	Function Detach() As IDispatch
		move(Detach, disp)
	End Function

	Function Dispatch() As IDispatch
		Dispatch = disp
	End Function
Protected

	Sub attach(ByRef y As IDispatch)
		Clear()
		move(disp, y)
	End Sub

Private
	disp As IDispatch

	Static Sub copy(ByRef dst As IDispatch, ByVal src As IDispatch)
		dst = src
		If ObjPtr(src) <> 0 Then
			src.AddRef()
		End If
	End Sub

	Static Sub move(ByRef dst As IDispatch, ByRef src As IDispatch)
		dst = src
		src = Nothing
	End Sub

End Class

Class VBObject
	Inherits VBObjectBase
Public
	Static Function Attach(y As IDispatch) As VBObject
		Attach = New VBObject
		Attach.attach(y)
	End Function

	Sub VBObject()
		disp = Nothing
	End Sub

	Sub VBObject(className As String, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
		VBObjectBase(createInstance(className, outer, clsContext))
	End Sub

	Sub VBObject(ByRef clsid As CLSID, outer = Nothing As IUnknown, clsContext = CLSCTX_ALL As DWord)
		VBObjectBase(createInstance(clsid, outer, clsContext))
	End Sub
Private
	Function createInstance(className As String, outer As IUnknown, clsContext As DWord) As IDispatch
		Dim clsid = Detail.StringToCLSID(ToWCStr(className))
		createInstance = createInstance(clsid, outer, clsContext)
	End Function

	Function createInstance(ByRef clsid As CLSID, outer As IUnknown, clsContext As DWord) As IDispatch
		Dim hr = CoCreateInstance(clsid, ObjPtr(outer), clsContext, IID_IDispatch, createInstance)
		Windows.ThrowIfFailed(hr)
	End Function
Public

	Function Operator [](name As PCWSTR) As DispatchCaller
		Return GetCaller(name)
	End Function

	Function Operator [](name As String) As DispatchCaller
		Return GetCaller(ToWCStr(name))
	End Function

Private
	Function GetCaller(name As PCWSTR) As DispatchCaller
		Dim dispid As DISPID
		Dim hr = Dispatch.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
		Windows.ThrowIfFailed(hr)
		Return New DispatchCaller(disp, dispid)
	End Function
End Class

Class DispatchCaller
	Implements System.IDisposable
Public
	Sub DispatchCaller()
	End Sub
	Sub DispatchCaller(dispObj As IDispatch, dispatchId As DISPID)
		disp = dispObj
		disp.AddRef()
		dispid = dispatchId
	End Sub

	Sub Dispose()
		If ObjPtr(disp) <> NULL Then
			disp.Release()
			disp = Nothing
		End If
	End Sub

	Sub ~DispatchCaller()
		Dispose()
	End Sub

	Function Prop() As Variant
		Dim dispParams As DISPPARAMS
		With dispParams
			.rgvarg = 0
			.rgdispidNamedArgs = 0
			.cArgs = 0
			.cNamedArgs = 0
		End With
		Call = New Variant
		Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_PROPERTYGET, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
		Windows.ThrowIfFailed(hr)
		Dispose()
	End Function

	Sub Prop(arg As Variant)
		Prop(ByVal arg.PtrToVariant)
	End Sub

	Sub Prop(ByRef arg As VARIANT)
		setProp(arg, DISPATCH_PROPERTYPUT)
	End Sub

	Sub PropRef(arg As Variant)
		PropRef(ByVal arg.PtrToVariant)
	End Sub

	Sub PropRef(ByRef arg As VARIANT)
		setProp(arg, DISPATCH_PROPERTYPUTREF)
	End Sub

	Function Call(cArgs As Long, args As *VARIANT) As Variant
		Dim dispParams As DISPPARAMS
		With dispParams
			.rgvarg = args
			.rgdispidNamedArgs = 0
			.cArgs = cArgs
			.cNamedArgs = 0
		End With
		Call = New Variant
		Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal Call.PtrToVariant, ByVal 0, 0)
		Windows.ThrowIfFailed(hr)
		Dispose()
	End Function

'	Function Call(cArgs As Long, args As *Variant) As Variant
'	End Function

	Function Call() As Variant
		Return Call(0, 0)
	End Function

	Function Call(arg0 As Variant) As Variant
		Return Call(1, arg0.PtrToVariant)
	End Function

	Function Call(arg0 As Variant, arg1 As Variant) As Variant
		Dim arg[ELM(2)] As VARIANT
		arg[0] = arg0.Copy()
		arg[1] = arg1.Copy()
		Return Call(2, arg)
	End Function

	Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant) As Variant
		Dim arg[ELM(3)] As VARIANT
		arg[0] = arg0.Copy()
		arg[1] = arg1.Copy()
		arg[2] = arg2.Copy()
		Return Call(3, arg)
	End Function

	Function Call(arg0 As Variant, arg1 As Variant, arg2 As Variant, arg3 As Variant) As Variant
		Dim arg[ELM(4)] As VARIANT
		arg[0] = arg0.Copy()
		arg[1] = arg1.Copy()
		arg[2] = arg2.Copy()
		arg[3] = arg3.Copy()
		Return Call(4, arg)
	End Function

/*
	Function Call(arg0 = Variant.OptionalParam As Variant, arg1 = Variant.OptionalParam As Variant,
		arg2 = Variant.OptionalParam As Variant, arg3 = Variant.OptionalParam As Variant,
		arg4 = Variant.OptionalParam As Variant, arg5 = Variant.OptionalParam As Variant,
		arg6 = Variant.OptionalParam As Variant, arg7 = Variant.OptionalParam As Variant,
		arg8 = Variant.OptionalParam As Variant, arg9 = Variant.OptionalParam As Variant) As Variant
		Dim arg[ELM(10)] As VARIANT
		arg[0] = arg0.Copy()
		arg[1] = arg1.Copy()
		arg[2] = arg2.Copy()
		arg[3] = arg3.Copy()
		arg[4] = arg3.Copy()
		arg[5] = arg4.Copy()
		arg[6] = arg5.Copy()
		arg[7] = arg6.Copy()
		arg[8] = arg7.Copy()
		arg[9] = arg8.Copy()
		Return Call(10, arg)
	End Function
*/
Private
	Sub setProp(ByRef arg As VARIANT, callType As Word)
		Dim dispidNamed = DISPID_PROPERTYPUT As DISPID
		Dim dispParams As DISPPARAMS
		With dispParams
			.rgvarg = VarPtr(arg)
			.rgdispidNamedArgs = VarPtr(dispidNamed)
			.cArgs = 1
			.cNamedArgs = 1
		End With
		Dim hr = disp.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, callType, dispParams, ByVal 0, ByVal 0, 0)
		Windows.ThrowIfFailed(hr)
		Dispose()
	End Sub

	disp As IDispatch
	dispid As DISPID
End Class

Function CallByName(obj As VBObject, procName As String, callType As Word, cArgs As Long, args As *VARIANT) As Variant
	Return CallByName(obj.Dispatch, ToWCStr(procName), callType, cArgs, args)
End Function

Function CallByName(obj As VBObject, procName As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
	Return CallByName(obj.Dispatch, procName, callType, cArgs, args)
End Function

Function CallByName(obj As IDispatch, name As PCWSTR, callType As Word, cArgs As Long, args As *VARIANT) As Variant
	Dim dispid As DISPID
	Dim hr = obj.GetIDsOfNames(GUID_NULL, VarPtr(name), 1, LOCALE_USER_DEFAULT, VarPtr(dispid))
	Windows.ThrowIfFailed(hr)
	Dim dispParams As DISPPARAMS
	With dispParams
		.rgvarg = args
		.rgdispidNamedArgs = 0
		.cArgs = cArgs
		.cNamedArgs = 0
	End With
	CallByName = New Variant
	hr = obj.Invoke(dispid, GUID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, dispParams, ByVal CallByName.PtrToVariant, ByVal 0, 0)
	Windows.ThrowIfFailed(hr)
End Function
/*
Function CreateObject(className As PCWSTR) As VBObject
	Return New VBObject(className, 0, CLSCTX_ALL)
End Function

Function CreateObject(className As String) As VBObject
	Return New VBObject(ToWCStr(className), 0, CLSCTX_ALL)
End Function
*/
#ifdef _WIN32_DCOM
Function CreateObject(className As PCWSTR, serverName As PCWSTR) As VBObject
	Dim clsid As CLSID
	Dim si As COSERVERINFO
	Dim context As DWord
	If /*Server = 0 OrElse*/ Server[0] = 0 Then
		context = CLSCTX_SERVER
	Else
		context = CLSCTX_REMOTE_SERVER
		si.pwszName = serverName
	End If

	Dim hr = _System_CLSIDFromString(className, clsid)

	Dim mqi As MULTI_QI
	mqi.pIID = VarPtr(IID_IUnknown)
	hr = CoCreateInstanceEx(clsid, 0, context, si, 1, VarPtr(mqi))
	If SUCCEEDED(hr) Then
		Dim obj As VBObject
		obj.Attach(mqi.pItf As IDispatch)
		Return obj
	Else
		'Throw
		Return Nothing
	End If
End Function

Function CreateObject(className As String, serverName As String) As VBObject
	Return CreateObject(ToWCStr(className), ToWCStr(serverName))
End Function
#endif


Namespace Detail
Function StringToCLSID(pwString As PCWSTR) As CLSID
	If pwString[0] = &h007b As WCHAR Then
		' 1文字目が { ならクラスIDの文字列表現と見なしCLSIDFromStringで変換。
		Windows.ThrowIfFailed(CLSIDFromString(pwString, StringToCLSID))
	Else
		Windows.ThrowIfFailed(CLSIDFromProgID(pwString, StringToCLSID))
	End If
End Function

Function COMReferenceEquals(p As IUnknown, q As IUnknown) As Boolean
	If ObjPtr(p) = ObjPtr(q) Then
		Return True
	Else If ObjPtr(p) = 0 Or ObjPtr(q) = 0 Then
		Return False
	End If

	Dim punkX = GetUnknown(p)
	Dim punkY = GetUnknown(q)
	If ObjPtr(punkX) = ObjPtr(punkY) Then
		COMReferenceEquals = True
	Else
		COMReferenceEquals = False
	End If
	punkX.Release()
	punkY.Release()
End Function

Function GetUnknown(p As IUnknown) As IUnknown 'pは任意のCOMインタフェース
	If FAILED(p.QueryInterface(IID_IUnknown, GetUnknown)) Then
		GetUnknown = Nothing
	End If
End Function
End Namespace 'Detail

End Namespace 'COM
End Namespace 'ActiveBasic