' com/variant.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), bs.Copy))
	End Sub

	Sub Variant(unk As IUnknown)
		If Not IsNothing(unk) Then unk.AddRef()
		v.vt = VT_UNKNOWN
		SetPointer(VarPtr(v.val), ObjPtr(unk))
	End Sub

	Sub Variant(disp As IDispatch)
		If Not IsNothing(disp) Then disp.AddRef()
		v.vt = VT_DISPATCH
		SetPointer(VarPtr(v.val), ObjPtr(disp))
	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)
		ValStr = New BString(s)
	End Sub

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

	Sub Variant(n As Decimal)
		Dim p = VarPtr(v) As *DECIMAL
		p[0] = n.Dec
		v.vt = VT_DECIMAL
	End Sub


	Sub ~Variant()
		Clear()
	End Sub

	Sub Clear()
		VariantClear(v)
		v.vt = VT_EMPTY
	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
		Abs = New Variant
		VarAbs(This.v, Abs.v)
	End Function

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

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

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

	Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT
		Return VarCmp(removeNull(x).v, removeNull(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)
		Return c = VARCMP_EQ
	End Function

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

	Const Function Operator <(y As Variant) As Boolean
		Dim c = Compare(This, y)
		Return c = VARCMP_LT
	End Function

	Const Function Operator >(y As Variant) As Boolean
		Dim c = Compare(This, y)
		Return c = VARCMP_GT
	End Function

	Const Function Operator <=(y As Variant) As Boolean
		Dim c = Compare(This, y)
		Return c = VARCMP_LT Or c = VARCMP_EQ
	End Function

	Const Function Operator >=(y As Variant) As Boolean
		Dim c = Compare(This, y)
		Return c = VARCMP_GT Or c = VARCMP_EQ
	End Function

	Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant
		ChangeType = New Variant
		ChangeType(ChangeType, flags, vt)
	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
		/*Using*/ Dim bs = ValStr
		ToString = bs.ToString
		bstr.Dispose() 'End Using
	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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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.v.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
		ValStr = New BString
		Dim r As VARIANT
		ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR)
		ValStr.Attach(GetPointer(VarPtr(r.val)) As BSTR)
	End Function

	Sub ValStr(x As BString)
		Clear()
		v.vt = VT_BSTR
		If IsNothing(x) Then
			SetPointer(VarPtr(v.val), SysAllocStringLen(0))
		Else
			SetPointer(VarPtr(v.val), x.Copy())
		End If
	End Sub

	Const Function ValUnknown() As IUnknown
		Dim r As VARIANT
		ChangeType(r, 0, VT_UNKNOWN)
		Return _System_PtrUnknown(r.val As ULONG_PTR As VoidPtr)
	End Function

	Sub ValUnknown(x As IUnknown)
		Clear()
		SetPointer(VarPtr(v.val), ObjPtr(x))
		If Not IsNothing(x) Then
			x.AddRef()
		End If
		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(ByVal p)
	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 IsNothing(optionalParam) Then
			Dim t = New Variant
			t.ValError = DISP_E_PARAMNOTFOUND
			InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)
		End If
		Return optionalParam
	End Function

	Static Function Null() As Variant
		If IsNothing(optionalParam) Then
			Dim t = New Variant
			Dim p = t.PtrToVariant
			p->vt = VT_NULL
			InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0)
		End If
		Return optionalParam
	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

	Static Function removeNull(v As Variant) As Varinat
		If IsNothing(v) Then
			removeNull = Null
		Else
			removeNull = v
		End If
	End Function

	Static optionalParam = Nothing As Variant
	Static null = Nothing As Variant
End Class

/*
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