hashtable.cls

这是一个在vb下实现的各种加密程序,可以实现一般的文本加密和文件加密,但是很多算法都是已经被人破解过的.

' Sets the value associated to the specified key.
'
' @param Key The key used to look up a value.
' @param Value The value to associate with the key.
' @remarks If the key is not found, then the key/value are added to
' the table. If the key IS found, then the associated value with the
' key is replaced with the new value.
' <p>The key can be any datatype other than vbUserDefinedType.
' If an object is being used as a key, then it should implement the
' IObject interface to allow for custom hashcode creation. If the
' object doesn't not implement the interface, then the objects memory
' location is used for a hashcode. If two different objects should
' represent the same hashcode, then they need to implement the IObject
' interface and override the GetHashCode function.</p>
'
Public Property Let Item(ByRef Key As Variant, ByRef Value As Variant)
    Call InsertItem(Key, Value, False, False)
End Property

''
' Sets the value associated to the specified key.
'
' @param Key The key used to look up a value.
' @param Value The value to associate with the key.
' @remarks If the key is not found, then the key/value are added to
' the table. If the key IS found, then the associated value with the
' key is replaced with the new value.
' <p>The key can be any datatype other than vbUserDefinedType.
' If an object is being used as a key, then it should implement the
' IObject interface to allow for custom hashcode creation. If the
' object does not implement the interface, then the objects memory
' location is used for a hashcode. If two different objects should
' represent the same hashcode, then they need to implement the IObject
' interface and override the GetHashCode function.</p>
'
Public Property Set Item(ByRef Key As Variant, ByRef Value As Variant)
    Call InsertItem(Key, Value, False, False)
End Property

''
' Retuns an ICollection object used to access the keys of the table.
'
' @return An ICollection object used to access the keys of the table.
'
Public Property Get Keys() As ICollection
    Dim Ret As New HTKeyCollection
    Call Ret.Init(Me)
    Set Keys = Ret
End Property

''
' Returns an enumerator for the table.
'
' @return The enumerator.
'
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = CreateEnumerator(GetEnumerator)
End Function

''
' Removes a key/value pair associated with a specific key.
'
' @param Key The key use to lookup the key/value pair to be removed.
'
Public Sub Remove(ByRef Key As Variant)
    Dim i As Long
    i = GetKeyIndex(Key)
    If i >= 0 Then
        With mBuckets(i)
            .HashCode = 0
            .Key = Empty
            .State = bsDeleted
            .Value = Empty
        End With
        
        mCount = mCount - 1
        
        ' If there are no more items, we want to ensure all buckets
        ' are marked as empty for faster instertions.
        If mCount = 0 Then
            For i = 0 To UBound(mBuckets)
                mBuckets(i).State = bsEmpty
            Next i
        End If
        
        mVersion = mVersion + 1
    End If
End Sub

''
' Returns a string representation of this object instance.
'
' @return String representing this instance.
'
Public Function ToString() As String
    ToString = Object.ToString(Me, App)
End Function

''
' Retuns an ICollection object used to access the values of the table.
'
' @return An ICollection object used to access the values of the table.
'
Public Property Get Values() As ICollection
    Dim Ret As New HTValueCollection
    Call Ret.Init(Me)
    Set Values = Ret
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Sub CloneHelper(ByRef buckets() As Bucket, ByVal Count As Long, LoadThreshold As Long, ByVal Provider As IHashcodeProvider, ByVal Comparer As IComparer)
    mCount = Count
    mBuckets = buckets
    mCapacity = UBound(buckets) + 1
    mLoadThreshold = LoadThreshold
    Set mProvider = Provider
    Set mComparer = Comparer
End Sub

Friend Sub CopyKeys(ByRef DstArray As Variant, ByVal Index As Long)
    Call InternalCopyTo(DstArray, Index, detKeys)
End Sub

Friend Sub CopyValues(ByRef DstArray As Variant, ByVal Index As Long)
    Call InternalCopyTo(DstArray, Index, detValues)
End Sub

Friend Function GetKeyEnumerator() As IEnumerator
    Dim Ret As New HashtableEnumerator
    Call Ret.Init(Me, SAPtr(mBuckets), detKeys)
    Set GetKeyEnumerator = Ret
End Function

Friend Function GetValueEnumerator() As IEnumerator
    Dim Ret As New HashtableEnumerator
    Call Ret.Init(Me, SAPtr(mBuckets), detValues)
    Set GetValueEnumerator = Ret
End Function

Friend Sub InitCapacity(ByVal Capacity As Long, ByVal hcp As IHashcodeProvider, ByVal Comparer As IComparer)
    mCapacity = GetPrime(Capacity)
    mLoadThreshold = mCapacity * LOAD_FACTOR
    ReDim mBuckets(0 To mCapacity - 1)
    Set mProvider = hcp
    Set mComparer = Comparer
End Sub

Friend Sub InitDictionary(ByVal dic As IDictionary, ByVal hcp As IHashcodeProvider, ByVal Comparer As IComparer)
    If dic Is Nothing Then
        Call InitCapacity(DEF_CAPACITY, hcp, Comparer)
    Else
        Call InitCapacity(dic.Count, hcp, Comparer)
        Dim Entry As DictionaryEntry
        For Each Entry In dic
            Call InsertItem(Entry.Key, Entry.Value, True, True)
        Next Entry
    End If
End Sub

Friend Property Get Version() As Long
    Version = mVersion
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ExpandTable()
    mCapacity = GetPrime(mCapacity * 2)
    mLoadThreshold = mCapacity * LOAD_FACTOR
    Call ReinsertItems
End Sub

Private Sub ReinsertItems()
    Dim OldBuckets() As Bucket
    ReDim OldBuckets(0 To mCapacity - 1)
    Call Helper.Swap4(ByVal ArrPtr(OldBuckets), ByVal ArrPtr(mBuckets))
    
    mCount = 0
    
    Dim i As Long
    For i = 0 To UBound(OldBuckets)
        If OldBuckets(i).State = bsOccupied Then
            Call InsertItem(OldBuckets(i).Key, OldBuckets(i).Value, True, True)
        End If
    Next i
End Sub

Private Function GetKeyIndex(ByRef Key As Variant) As Long
    Dim Step                As Long
    Dim Index               As Long
    Dim HashCode            As Long
    Dim FirstIndex          As Long
    Dim ComparerIsNothing   As Boolean
    
    HashCode = InitHashCode(Key, Step, Index)
    FirstIndex = Index
    ComparerIsNothing = mComparer Is Nothing
    
    Do
        Select Case mBuckets(Index).State
            Case bsEmpty
                GetKeyIndex = -1
                Exit Function
            Case bsOccupied
                If mBuckets(Index).HashCode = HashCode Then
                    If ComparerIsNothing Then
                        If EqualsVariants(Key, mBuckets(Index).Key) Then
                            GetKeyIndex = Index
                            Exit Function
                        End If
                    ElseIf mComparer.Compare(Key, mBuckets(Index).Key) = 0 Then
                        GetKeyIndex = Index
                        Exit Function
                    End If
                End If
        End Select
        Index = (Index + Step) Mod mCapacity
    Loop While Index <> FirstIndex
    
    GetKeyIndex = -1
End Function

Private Function InitHashCode(ByRef Key As Variant, ByRef Step As Long, ByRef Index As Long) As Long
    If mProvider Is Nothing Then
        InitHashCode = Object.GetHashCode(Key) And &H7FFFFFFF
    Else
        InitHashCode = mProvider.GetHashCode(Key) And &H7FFFFFFF
    End If
    Step = 1 + (((InitHashCode \ 32) + 1) Mod (mCapacity - 1))
    Index = InitHashCode Mod mCapacity
End Function

Private Sub InsertItem(ByRef Key As Variant, ByRef Value As Variant, ByVal Adding As Boolean, ByVal Steal As Boolean)
    Dim Step                As Long
    Dim Index               As Long
    Dim FirstEmpty          As Long
    Dim HashCode            As Long
    Dim UseDefaultCompare   As Boolean
    Dim FirstIndex          As Long
    
    If mCount > mLoadThreshold Then Call ExpandTable
    
    HashCode = InitHashCode(Key, Step, Index)
    FirstIndex = Index
    FirstEmpty = -1
    UseDefaultCompare = mComparer Is Nothing
    
    Do
        Select Case mBuckets(Index).State
            Case bsEmpty
                ' we bookmark this bucket as our first available bucket.
                If FirstEmpty = -1 Then FirstEmpty = Index
                
                ' we can exit here because we have found an empty bucket.
                ' Meaning there are no more buckets on this chain so no
                ' duplicate key could exist.
                Exit Do
                
            Case bsOccupied
                If mBuckets(Index).HashCode = HashCode Then
                    If UseDefaultCompare Then
                        If EqualsVariants(Key, mBuckets(Index).Key) Then
                            If Adding Then _
                                Throw Cor.NewArgumentException("An element with the same key already exists in the collection.", "key")
                            
                            ' v2.0 - we copy the key so the same updated key stays with the updated value.
                            Call VariantCopyInd(mBuckets(Index).Key, Key)
                            Call VariantCopyInd(mBuckets(Index).Value, Value)
                            mVersion = mVersion + 1
                            Exit Sub
                        End If
                    ElseIf mComparer.Compare(Key, mBuckets(Index).Key) = 0 Then
                        If Adding Then _
                            Throw Cor.NewArgumentException("An element with the same key already exists in the collection.", "key")
                        
                        ' v2.0 - we copy the key so the same updated key stays with the updated value.
                        Call VariantCopyInd(mBuckets(Index).Key, Key)
                        Call VariantCopyInd(mBuckets(Index).Value, Value)
                        mVersion = mVersion + 1
                        Exit Sub
                    End If
                End If
            
            Case bsDeleted