source: trunk/ab5.0/ablib/src/com/variant.ab@ 709

' 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