' com/variant.ab

#ifndef _COM_VARIANT_AB
#define _COM_VARIANT_AB

#require <oaidl.ab>
#require <oleauto.ab>
#require <com/index.ab>

Namespace ActiveBasic
Namespace COM

Class Variant
Public
	Sub Variant()
		VariantInit(v)
	End Sub

	Sub Variant(y As Variant)
		VariantInit(v)
		VariantCopy(v, y.v)
	End Sub

	Sub Variant(ByRef y As VARIANT)
		VariantInit(v)
		VariantCopy(v, y)
	End Sub

	Sub Variant(n As SByte)
		v.vt = VT_I1
		SetByte(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Byte)
		v.vt = VT_UI1
		SetByte(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Integer)
		v.vt = VT_I2
		SetWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Word)
		v.vt = VT_UI2
		SetWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Long)
		v.vt = VT_I4
		SetDWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As DWord)
		v.vt = VT_UI4
		SetDWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Int64)
		v.vt = VT_I8
		SetQWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As QWord)
		v.vt = VT_UI8
		SetQWord(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Single)
		v.vt = VT_R4
		SetSingle(VarPtr(v.val), n)
	End Sub

	Sub Variant(n As Double)
		v.vt = VT_R8
		SetDouble(VarPtr(v.val), n)
	End Sub

	Sub Variant(bs As BString)
		v.vt = VT_BSTR
		SetPointer(VarPtr(v.val), SysAllocStringLen(bs.BStr, bs.Length))
	End Sub

	Sub Variant(p As *IUnknown)
		p->AddRef()
		v.vt = VT_UNKNOWN
		SetPointer(VarPtr(v.val), p)
	End Sub

	Sub Variant(p As *IDispatch)
		p->AddRef()
		v.vt = VT_DISPATCH
		SetPointer(VarPtr(v.val), p)
	End Sub
/*
	Sub Variant(b As VARIANT_BOOL)
		v.vt = VT_BOOL
		SetWord(VarPtr(v.val), b)
	End Sub
*/
	Sub Variant(b As Boolean)
		v.vt = VT_BOOL
		If b Then
			SetWord(VarPtr(v.val), VARIANT_TRUE)
		Else
			SetWord(VarPtr(v.val), VARIANT_FALSE)
		End If
	End Sub

	Sub Variant(s As String)
		Dim bs As BString(s)
		Variant(bs)
	End Sub

	Sub Variant(n As Currency)
		v.vt = VT_CY
		SetQWord(VarPtr(v.val), n.Cy As QWord)
	End Sub


	Sub ~Variant()
		Clear()
	End Sub

	Sub Clear()
		VariantClear(v)
		v.vt = VT_EMPTY
	End Sub

	Sub Operator =(y As Variant)
		Assign(y.v)
	End Sub

	Sub Operator =(y As VARIANT)
		Assign(y)
	End Sub

	Sub Assign(from As Variant)
		Assign(from.v)
	End Sub

	Sub Assign(ByRef from As VARIANT)
		Variant.Copy(v, from)
	End Sub

	Sub AssignInd(ByRef from As VARIANT)
		VariantCopyInd(v, from)
	End Sub

	Sub Attach(ByRef from As VARIANT)
		Variant.Move(v, from)
	End Sub

	Const Function Copy() As VARIANT
		Variant.Copy(Copy, v)
	End Function

	Function Detach() As VARIANT
		Variant.Move(Detach, v)
	End Function
/*
	Static Function Assgin(ByRef from As VARIANT) As Variant
		Assign = New Variant
		Assgin.Assign(from)
	End Function

	Static Function Attach(ByRef from As VARIANT) As Variant
		Attach = New Variant
		Attach.Attach(from)
	End Function
*/
	'Operators

	Const Function Operator ^(y As Variant) As Variant
		Dim ret = New Variant
		VarPow(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator +() As Variant
		Return New Variant(This)
	End Function

	Const Function Operator -() As Variant
		Dim ret = New Variant
		VarNeg(This.v, ret.v)
		Return ret
	End Function

	Const Function Operator *(y As Variant) As Variant
		Dim ret = New Variant
		VarMul(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator /(y As Variant) As Variant
		Dim ret = New Variant
		VarDiv(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator \(y As Variant) As Variant
		Dim ret = New Variant
		VarIDiv(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator Mod(y As Variant) As Variant
		Dim ret = New Variant
		VarMod(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator +(y As Variant) As Variant
		Dim ret = New Variant
		VarAdd(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator -(y As Variant) As Variant
		Dim ret = New Variant
		VarSub(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator &(y As Variant) As Variant
		Dim ret = New Variant
		VarCat(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator And(y As Variant) As Variant
		Dim ret = New Variant
		VarAnd(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator Or(y As Variant) As Variant
		Dim ret = New Variant
		VarOr(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator Xor(y As Variant) As Variant
		Dim ret = New Variant
		VarXor(This.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Operator Not() As Variant
		Dim ret = New Variant
		VarNot(This.v, ret.v)
		Return ret
	End Function

	Static Function Imp(x As Variant, y As Variant) As Variant
		Dim ret = New Variant
		VarImp(x.v, y.v, ret.v)
		Return ret
	End Function

	Static Function Eqv(x As Variant, y As Variant) As Variant
		Dim ret = New Variant
		VarEqv(x.v, y.v, ret.v)
		Return ret
	End Function

	Const Function Abs() As Variant
		Dim ret = New Variant
		VarAbs(This.v, ret.v)
		Return ret
	End Function

	Const Function Fix() As Variant
		Dim ret = New Variant
		VarFix(This.v, ret.v)
		Return ret
	End Function

	Const Function Int() As Variant
		Dim ret = New Variant
		VarInt(This.v, ret.v)
		Return ret
	End Function

	Const Function Round(cDecimals As Long) As Variant
		Dim ret = New Variant
		VarRound(This.v, cDecimals, ret)
		Return ret
	End Function

	Const Function Round() As Variant
		Return Round(0)
	End Function

	Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT
		Return VarCmp(x.v, y.v, lcid, flags)
	End Function

	Static Function Compare(x As Variant, y As Variant) As HRESULT
		Return VarCmp(x.v, y.v, LOCALE_USER_DEFAULT, 0) 'VARCMP_NULL = 3を返す場合があるので注意
	End Function

	Const Function Operator ==(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If c = VARCMP_EQ Then
			Return True
		Else
			Return False
		End If
	End Function

	Const Function Operator <>(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If c <> VARCMP_EQ Then
			Return True
		Else
			Return False
		End If
	End Function

	Const Function Operator <(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If c = VARCMP_LT Then
			Return True
		Else
			Return False
		End If
	End Function
/*
	Const Function Operator >(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If c = VARCMP_GT Then
			Return True
		Else
			Return False
		End If
	End Function
*/
	Const Function Operator <=(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If result = VARCMP_LT Or result = VARCMP_EQ Then
			Return True
		Else
			Return False
		End If
	End Function

	Const Function Operator >=(y As Variant) As Boolean
		Dim c = Compare(This, y)
		If result = VARCMP_GT Or result = VARCMP_EQ Then
			Return True
		Else
			Return False
		End If
	End Function

	Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant
		Dim ret = New Variant
		ChangeType(ret, flags, vt)
		Return ret
	End Function

	Const Function ChangeType(vt As VARTYPE) As Variant
		Return ChangeType(vt, 0)
	End Function

	Const Function ChangeType(ByRef ret As VARIANT, flags As Word, vt As VARTYPE) As HRESULT
		Return VariantChangeType(ret, v, flags, vt)
	End Function

	Const Function ChangeType(ByRef ret As Variant, flags As Word, vt As VARTYPE) As HRESULT
		Return ChangeType(ret.v, flags, vt)
	End Function

	Const Function VarType() As VARTYPE
		Return v.vt
	End Function

	Override Function ToString() As String
		Dim tmp = ChangeType(VT_BSTR, VARIANT_ALPHABOOL)
		Dim bs = ((tmp.v.val As ULONG_PTR) As BSTR)
		Return New String(bs As PCWSTR, SysStringLen(bs) As Long)
	End Function

	Override Function GetHashCode() As Long
		Dim p = (VarPtr(v) As *DWord)
		Return (p[0] Xor p[1] Xor p[2] Xor p[3]) As Long
	End Function

	Const Function ValUI1() As Byte
		Dim r = ChangeType(VT_UI1)
		Return GetByte(VarPtr(r.val))
	End Function

	Sub ValUI1(x As Byte)
		Clear()
		SetByte(VarPtr(v.val), x)
		v.vt = VT_UI1
	End Sub

	Const Function ValUI2() As Word
		Dim r = ChangeType(VT_UI2)
		Return GetWord(VarPtr(r.val))
	End Function

	Sub ValUI2(x As Word)
		Clear()
		SetWord(VarPtr(v.val), x)
		v.vt = VT_UI2
	End Sub

	Const Function ValUI4() As DWord
		Dim r = ChangeType(VT_UI4)
		Return GetDWord(VarPtr(r.val))
	End Function

	Sub ValUI4(x As DWord)
		Clear()
		SetDWord(VarPtr(v.val), x)
		v.vt = VT_UI4
	End Sub

	Const Function ValUI8() As QWord
		Dim r = ChangeType(VT_UI8)
		Return GetQWord(VarPtr(r.val))
	End Function

	Sub ValUI8(x As QWord)
		Clear()
		SetQWord(VarPtr(v.val), x)
		v.vt = VT_UI8
	End Sub

	Const Function ValI1() As SByte
		Dim r = ChangeType(VT_I1)
		Return GetByte(VarPtr(r.val)) As SByte
	End Function

	Sub ValI1(x As SByte)
		Clear()
		SetByte(VarPtr(v.val), x As Byte)
		v.vt = VT_I1
	End Sub

	Const Function ValI2() As Integer
		Dim r = ChangeType(VT_I2)
		Return GetWord(VarPtr(r.val)) As Integer
	End Function

	Sub ValI2(x As Integer)
		Clear()
		SetWord(VarPtr(v.val), x As Word)
		v.vt = VT_I2
	End Sub

	Const Function ValI4() As Long
		Dim r = ChangeType(VT_I4)
		Return GetDWord(VarPtr(r.val)) As Long
	End Function

	Sub ValI4(x As Long)
		Clear()
		SetDWord(VarPtr(v.val), x As DWord)
		v.vt = VT_I4
	End Sub

	Const Function ValI8() As Int64
		Dim r = ChangeType(VT_I8)
		Return GetQWord(VarPtr(r.val)) As Int64
	End Function

	Sub ValI8(x As Int64)
		Clear()
		SetQWord(VarPtr(v.val), x As QWord)
		v.vt = VT_I8
	End Sub

	Const Function ValR4() As Single
		Dim r = ChangeType(VT_R4)
		Return GetSingle(VarPtr(r.val))
	End Function

	Sub ValR4(x As Single)
		Clear()
		SetDWord(VarPtr(v.val), x)
		v.vt = VT_R4
	End Sub

	Const Function ValR8() As Double
		Dim r = ChangeType(VT_UI8)
		Return GetDouble(VarPtr(r.val))
	End Function

	Sub ValR8(x As Double)
		Clear()
		SetDouble(VarPtr(v.val), x)
		v.vt = VT_R8
	End Sub

	Const Function ValBool() As VARIANT_BOOL
		Dim r = ChangeType(VT_BOOL)
		Return GetWord(VarPtr(r.val))
	End Function

	Sub ValBool(x As VARIANT_BOOL)
		Clear()
		SetWord(VarPtr(v.val), x)
		v.vt = VT_BOOL
	End Sub

	Const Function ValError() As SCODE
		Dim r = ChangeType(VT_ERROR)
		Return GetDWord(VarPtr(r.val))
	End Function

	Sub ValError(x As SCODE)
		Clear()
		SetDWord(VarPtr(v.val), x)
		v.vt = VT_ERROR
	End Sub

	Const Function ValCy() As Currency
		Dim r = ChangeType(VT_CY)
		ValCy = New Currency
		ValCy.Cy = GetQWord(VarPtr(r.val))
	End Function

	Sub ValCy(x As Currency)
		Clear()
		SetQWord(VarPtr(v.val), x.Cy)
		v.vt = VT_CY
	End Sub
	
	'ValDate

	Const Function ValStr() As BString
		Dim r As VARIANT
		ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR)
		Dim bs = New BString
		bs.Attach(GetPointer(VarPtr(r.val)) As BSTR)
		Return bs
	End Function

	Sub ValStr(x As BString)
		Clear()
		v.vt = VT_BSTR
		SetPointer(VarPtr(v.val), x.Copy())
	End Sub

	Const Function ValUnknown() As *IUnknown
		Dim r As VARIANT
		ChangeType(r, 0, VT_UNKNOWN)
		Return GetPointer(VarPtr(r.val)) As *IUnknown
	End Function

	Sub ValUnknown(x As *IUnknown)
		Clear()
		SetPointer(VarPtr(v.val), x.Copy())
		x->AddRef()
		v.vt = VT_UNKNOWN
	End Sub

	Const Function ValObject() As VBObject
		Dim r As VARIANT
		ChangeType(r, 0, VT_DISPATCH)
		Dim o As VBObject
		o.Attach(GetPointer(VarPtr(r.val)) As *IDispatch)
		Return o
	End Function

	Sub ValObject(x As VBObject)
		Clear()
		SetPointer(VarPtr(v.val), x.Copy())
		x->AddRef()
		v.vt = VT_DISPATH
	End Sub

	'ValArray

	Const Function ValDecimal() As Decimal
		Dim p = VarPtr(v) As *Decimal
		Return New Deciaml(p[0])
	End Function

	Sub ValDecimal(x As Decimal)
		Clear()
		Dim p = VarPtr(v) As *Decimal
		p[0] = x.Dec
		v.vt = VT_DECIMAL '念の為
	End Sub
	

	Function PtrToVariant() As *VARIANT
		Return VarPtr(v)
	End Function

	Static Function OptionalParam() As Variant
'		If _System_VariantOptionalParam = Nothing Then
'			'ToDo マルチスレッド対応
			_System_VariantOptionalParam = New Variant
			_System_VariantOptionalParam.ValError = DISP_E_PARAMNOTFOUND
'		End If
		Return _System_VariantOptionalParam
	End Function
Private
	v As VARIANT

	Static Sub Copy(ByRef dst As VARIANT, ByRef src As VARIANT)
		VariantCopy(dst, src)
	End Sub

	Static Sub Move(ByRef dst As VARIANT, ByRef src As VARIANT)
		dst = src
'		src.vt = VT_EMPTY
	End Sub
End Class

'Dim _System_VariantOptionalParam = Nothing As Variant

/*
Function Abs(v As Variant) As Variant
	Return v.Abs()
End Function

Function Fix(v As Variant) As Variant
	Return v.Fix()
End Function

Function Int(v As Variant) As Variant
	Return v.Int()
End Function

Function VarType(v As Variant) As VARTYPE
	Return v.VarType()
End Function
*/

End Namespace 'COM
End Namespace 'ActiveBasic

#endif '_COM_VARIANT_AB