' com/variant.ab

'#require <com/index.ab>

Namespace ActiveBasic
Namespace COM

Class Variant
	Implements System.IDisposable, System.ICloneable
Public
	Sub Variant()
		VariantInit(v)
	End Sub

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

	' 仮
	Sub Variant(y As Variant)
		VariantInit(v)
		VariantCopy(v, y.v)
	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 ObjPtr(unk) <> 0 Then unk.AddRef()
		v.vt = VT_UNKNOWN
		SetPointer(VarPtr(v.val), ObjPtr(unk))
	End Sub

	Sub Variant(disp As IDispatch)
		If ObjPtr(disp) <> 0 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)
		v.vt = VT_BSTR
		If IsNothing(s) Then
			initWithStr(0)
		Else
			initWithStr(0)
		End If
	End Sub

	Sub Variant(s As BSTR)
		initWithStr(s)
	End Sub
Private
	Sub initWithStr(bs As BSTR)
		v.vt = VT_BSTR
		If bs = NULL Then
			SetPointer(VarPtr(v.val), SysAllocStringLen(0, 0))
		Else
			SetPointer(VarPtr(v.val), SysAllocStringByteLen(bs As PCSTR, SysStringByteLen(bs)))
		End If
	End Sub

Public

	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()
		Dispose()
	End Sub

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

	Sub Clear()
		Dispose()
	End Sub

	Virtual Function Clone() As Variant
		Clone = New Variant(This)
	End Function

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

	Function Detach() As VARIANT
		Variant.Move(Detach, v)
	End Function

	Static Function CopyFrom(ByRef from As VARIANT) As Variant
		CopyFrom = New Variant
		Variant.Copy(CopyFrom.v, from)
	End Function

	Static Function Attach(ByRef from As VARIANT) As Variant
		Attach = New Variant
		Variant.Move(Attach.v, from)
	End Function

	Static Function CopyIndirectFrom(ByRef from As VARIANT) As Variant
		CopyIndirectFrom = New Variant
		VariantCopyInd(CopyIndirectFrom.v, from)
	End Function

	'Operators
/*
	Function Operator ^(y As Variant) As Variant
		Dim ret = New Variant
		Windows.ThrowIfFailed(VarPow(This.v, y.v, ret.v))
		Return ret
	End Function
*/
	Function Operator +() As Variant
'		Return Clone()
	End Function

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

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

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

	Function Operator \(y As Variant) As Variant
		Dim ret = New Variant
		Windows.ThrowIfFailed(VarIdiv(This.v, y.v, ret.v))
		Return ret
	End Function

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

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

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

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

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

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

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

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

	Static Function Imp(x As Variant, y As Variant) As Variant
		Dim ret = New Variant
		Windows.ThrowIfFailed(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
		Windows.ThrowIfFailed(VarEqv(x.v, y.v, ret.v))
		Return ret
	End Function

	Function Abs() As Variant
		Abs = New Variant
		Windows.ThrowIfFailed(VarAbs(This.v, Abs.v))
	End Function

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

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

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

	' ThrowIfFailedを使っていないことに注意
	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

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

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

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

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

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

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

	Function ChangeType(vt As VARTYPE, flags = 0 As Word) As Variant
		ChangeType = New Variant
		changeType(ChangeType.v, vt, flags)
	End Function
Private
	Sub changeType(ByRef ret As VARIANT, vt As VARTYPE, flags = 0 As Word)
		Windows.ThrowIfFailed(VariantChangeType(ret, v, flags, vt))
	End Sub
Public

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

	Override Function ToString() As String
		Using bs = ValStr
			ToString = bs.ToString()
		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

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

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

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

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

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

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

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

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

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

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

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

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

	Function ValCy() As Currency
		Dim r = ChangeType(VT_CY)
		ValCy = Currency.FromCy(GetQWord(VarPtr(r.v.val)))
	End Function

	'ValDate

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

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

	Function ValObject() As VBObject
		Dim r As VARIANT
		changeType(r, VT_DISPATCH)
		ValObject = VBObject.Attach(_System_PtrUnknown(r.val As ULONG_PTR As VoidPtr) As IDispatch)
	End Function

	'ValArray

	Function ValDecimal() As Decimal
		Dim p = VarPtr(v) As *DECIMAL
		Return New Decimal(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
			Using lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
				If IsNothing(optionalParam) Then
					Dim t = New Variant
					Dim p = t.PtrToVariant
					p->vt = VT_ERROR
					p->val = DISP_E_PARAMNOTFOUND
					optionalParam = t
				End If
			End Using
		End If
		Return optionalParam
	End Function

	Static Function Null() As Variant
		If IsNothing(null) Then
			Using lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
				If IsNothing(null) Then
					Dim t = New Variant
					Dim p = t.PtrToVariant
					p->vt = VT_NULL
					null = t
				End If
			End Using
		End If
		Return null
	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 Variant
		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

Namespace Detail

Sub CopyFromVariant(ByRef x As Byte, v As Variant)
	x = v.ValUI1
End Sub

Sub CopyFromVariant(ByRef x As Word, v As Variant)
	x = v.ValUI2
End Sub

Sub CopyFromVariant(ByRef x As DWord, v As Variant)
	x = v.ValUI4
End Sub

Sub CopyFromVariant(ByRef x As QWord, v As Variant)
	x = v.ValUI8
End Sub

Sub CopyFromVariant(ByRef x As SByte, v As Variant)
	x = v.ValI1
End Sub

Sub CopyFromVariant(ByRef x As Integer, v As Variant)
	x = v.ValI2
End Sub

Sub CopyFromVariant(ByRef x As Long, v As Variant)
	x = v.ValI4
End Sub

Sub CopyFromVariant(ByRef x As Int64, v As Variant)
	x = v.ValI8
End Sub

Sub CopyFromVariant(ByRef x As Single, v As Variant)
	x = v.ValR4
End Sub

Sub CopyFromVariant(ByRef x As Double, v As Variant)
	x = v.ValR8
End Sub

Sub CopyFromVariant(ByRef x As Boolean, v As Variant)
	x = v.ValBool As Boolean
End Sub

Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Currency, v As Variant)
	x = v.ValCy
End Sub

Sub CopyFromVariant(ByRef x As String, v As Variant)
	x = v.ValStr.ToString()
End Sub

Sub CopyFromVariant(ByRef x As ActiveBasic.COM.VBObject, v As Variant)
	x = v.ValObject
End Sub

Sub CopyFromVariant(ByRef x As ActiveBasic.COM.Decimal, v As Variant)
	x = v.ValDecimal
End Sub

Sub CopyFromVariant(ByRef x As IUnknown, v As Variant)
	x = v.ValUnknown
End Sub

Sub CopyFromVariant(ByRef x As Variant, v As Variant)
	x = v.Clone()
End Sub

End Namespace

End Namespace 'COM
End Namespace 'ActiveBasic