Results 1 to 3 of 3

Thread: [VB6/VBA] Pure VB6 impl of SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/256 incl. HMAC

  1. #1

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    [VB6/VBA] Pure VB6 impl of SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/256 incl. HMAC

    This mdSha2.bas module is a pure VB6 implementation of SHA-2 family of hashes.

    Public procedures CryptoSha2Init, CryptoSha2Update and CryptoSha2Finalize can be used to incrementally hash large volumes of data (that might not fit into memory e.g. GBs sized files) while CryptoSha2ByteArray and CryptoSha2Text are convenience wrappers which produce output SHA-2 hash in a byte-array or a string format in one go.

    Code:
    '--- mdSha2.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasSha512 = (CRYPT_HAS_SHA512 <> 0)
    #Const HasPtrSafe = (VBA7 <> 0)
    #Const HasOperators = (TWINBASIC <> 0)
    
    #If HasPtrSafe Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #End If
    
    Private Const LNG_BLOCKSZ               As Long = 64
    Private Const LNG_ROUNDS                As Long = 64
    
    Public Type CryptoSha2Context
        H0                  As Long
        H1                  As Long
        H2                  As Long
        H3                  As Long
        H4                  As Long
        H5                  As Long
        H6                  As Long
        H7                  As Long
        Partial(0 To LNG_BLOCKSZ - 1) As Byte
        NPartial            As Long
        NInput              As Currency
        BitSize             As Long
    End Type
    
    Private LNG_K(0 To LNG_ROUNDS - 1)  As Long
    
    #If Not HasOperators Then
    Private LNG_POW2(0 To 31)           As Long
    
    Private Function RotR32(ByVal lX As Long, ByVal lN As Long) As Long
        '--- RotR32 = RShift32(X, n) Or LShift32(X, 32 - n)
        Debug.Assert lN <> 0
        RotR32 = ((lX And &H7FFFFFFF) \ LNG_POW2(lN) - (lX < 0) * LNG_POW2(31 - lN)) Or _
            ((lX And (LNG_POW2(lN - 1) - 1)) * LNG_POW2(32 - lN) Or -((lX And LNG_POW2(lN - 1)) <> 0) * &H80000000)
    End Function
    
    'Private Function LShift32(ByVal lX As Long, ByVal lN As Long) As Long
    '    If lN = 0 Then
    '        LShift32 = lX
    '    Else
    '        LShift32 = (lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * &H80000000
    '    End If
    'End Function
    
    Private Function RShift32(ByVal lX As Long, ByVal lN As Long) As Long
        If lN = 0 Then
            RShift32 = lX
        Else
            RShift32 = (lX And &H7FFFFFFF) \ LNG_POW2(lN) Or -(lX < 0) * LNG_POW2(31 - lN)
        End If
    End Function
    
    Private Function UAdd32(ByVal lX As Long, ByVal lY As Long) As Long
        If (lX Xor lY) >= 0 Then
            UAdd32 = ((lX Xor &H80000000) + lY) Xor &H80000000
        Else
            UAdd32 = lX + lY
        End If
    End Function
    
    Private Function Ch(ByVal lX As Long, ByVal lY As Long, ByVal lZ As Long) As Long
        Ch = (lX And lY) Xor ((Not lX) And lZ)
    End Function
    
    Private Function Maj(ByVal lX As Long, ByVal lY As Long, ByVal lZ As Long) As Long
        Maj = (lX And lY) Xor (lX And lZ) Xor (lY And lZ)
    End Function
    
    Private Function BigSigma0(ByVal lX As Long) As Long
        BigSigma0 = RotR32(lX, 2) Xor RotR32(lX, 13) Xor RotR32(lX, 22)
    End Function
    
    Private Function BigSigma1(ByVal lX As Long) As Long
        BigSigma1 = RotR32(lX, 6) Xor RotR32(lX, 11) Xor RotR32(lX, 25)
    End Function
    
    Private Function SmallSigma0(ByVal lX As Long) As Long
        SmallSigma0 = RotR32(lX, 7) Xor RotR32(lX, 18) Xor RShift32(lX, 3)
    End Function
    
    Private Function SmallSigma1(ByVal lX As Long) As Long
        SmallSigma1 = RotR32(lX, 17) Xor RotR32(lX, 19) Xor RShift32(lX, 10)
    End Function
    #End If
    
    Private Function BSwap32(ByVal lX As Long) As Long
        BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
                     (lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
    End Function
    
    Public Sub CryptoSha2Init(uCtx As CryptoSha2Context, ByVal lBitSize As Long)
        Dim vElem           As Variant
        Dim lIdx            As Long
        
        If LNG_K(0) = 0 Then
            '--- K: first 32 bits of the fractional parts of the cube roots of the first 64 primes
            For Each vElem In Split("428A2F98 71374491 B5C0FBCF E9B5DBA5 3956C25B 59F111F1 923F82A4 AB1C5ED5 D807AA98 12835B01 243185BE 550C7DC3 72BE5D74 80DEB1FE 9BDC06A7 C19BF174 E49B69C1 EFBE4786 FC19DC6 240CA1CC 2DE92C6F 4A7484AA 5CB0A9DC 76F988DA 983E5152 A831C66D B00327C8 BF597FC7 C6E00BF3 D5A79147 6CA6351 14292967 27B70A85 2E1B2138 4D2C6DFC 53380D13 650A7354 766A0ABB 81C2C92E 92722C85 A2BFE8A1 A81A664B C24B8B70 C76C51A3 D192E819 D6990624 F40E3585 106AA070 19A4C116 1E376C08 2748774C 34B0BCB5 391C0CB3 4ED8AA4A 5B9CCA4F 682E6FF3 748F82EE 78A5636F 84C87814 8CC70208 90BEFFFA A4506CEB BEF9A3F7 C67178F2")
                LNG_K(lIdx) = "&H" & vElem
                lIdx = lIdx + 1
            Next
            #If Not HasOperators Then
                LNG_POW2(0) = 1
                For lIdx = 1 To 30
                    LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
                Next
                LNG_POW2(31) = &H80000000
            #End If
        End If
        With uCtx
            Select Case lBitSize
            Case 224
                .H0 = &HC1059ED8: .H1 = &H367CD507: .H2 = &H3070DD17: .H3 = &HF70E5939
                .H4 = &HFFC00B31: .H5 = &H68581511: .H6 = &H64F98FA7: .H7 = &HBEFA4FA4
            Case 256
                .H0 = &H6A09E667: .H1 = &HBB67AE85: .H2 = &H3C6EF372: .H3 = &HA54FF53A
                .H4 = &H510E527F: .H5 = &H9B05688C: .H6 = &H1F83D9AB: .H7 = &H5BE0CD19
            Case Else
                Err.Raise vbObjectError, , "Invalid bit-size for SHA-2 (" & lBitSize & ")"
            End Select
            .NPartial = 0
            .NInput = 0
            .BitSize = lBitSize
        End With
    End Sub
    
    #If HasOperators Then
    [ IntegerOverflowChecks (False) ]
    #End If
    Public Sub CryptoSha2Update(uCtx As CryptoSha2Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Static W(0 To LNG_ROUNDS - 1) As Long
        Static B(0 To 15)   As Long
        Dim lIdx            As Long
        Dim lA              As Long
        Dim lB              As Long
        Dim lC              As Long
        Dim lD              As Long
        Dim lE              As Long
        Dim lF              As Long
        Dim lG              As Long
        Dim lH              As Long
        Dim lT1             As Long
        Dim lT2             As Long
        Dim lX              As Long
        Dim lSigma1         As Long
        Dim lSigma0         As Long
        Dim lCh             As Long
        Dim lMaj            As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            .NInput = .NInput + Size
            If .NPartial > 0 Then
                lIdx = LNG_BLOCKSZ - .NPartial
                If lIdx > Size Then
                    lIdx = Size
                End If
                Call CopyMemory(.Partial(.NPartial), baInput(Pos), lIdx)
                .NPartial = .NPartial + lIdx
                Pos = Pos + lIdx
                Size = Size - lIdx
            End If
            Do While Size > 0 Or .NPartial = LNG_BLOCKSZ
                If .NPartial <> 0 Then
                    Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
                    .NPartial = 0
                ElseIf Size >= LNG_BLOCKSZ Then
                    Call CopyMemory(B(0), baInput(Pos), LNG_BLOCKSZ)
                    Pos = Pos + LNG_BLOCKSZ
                    Size = Size - LNG_BLOCKSZ
                Else
                    Call CopyMemory(.Partial(0), baInput(Pos), Size)
                    .NPartial = Size
                    Exit Do
                End If
                '--- sha2 step
                lA = .H0: lB = .H1: lC = .H2: lD = .H3
                lE = .H4: lF = .H5: lG = .H6: lH = .H7
                For lIdx = 0 To LNG_ROUNDS - 1
                    If lIdx < 16 Then
                        W(lIdx) = BSwap32(B(lIdx))
                    Else
                        #If HasOperators Then
                            lX = W(lIdx - 2)
                            lSigma1 = (lX >> 17 Or lX << 15) Xor (lX >> 19 Or lX << 13) Xor (lX >> 10)
                            lX = W(lIdx - 15)
                            lSigma0 = (lX >> 7 Or lX << 25) Xor (lX >> 18 Or lX << 14) Xor (lX >> 3)
                            W(lIdx) = lSigma1 + W(lIdx - 7) + lSigma0 + W(lIdx - 16)
                        #Else
                            W(lIdx) = UAdd32(UAdd32(UAdd32(SmallSigma1(W(lIdx - 2)), W(lIdx - 7)), SmallSigma0(W(lIdx - 15))), W(lIdx - 16))
                        #End If
                    End If
                    #If HasOperators Then
                        lSigma1 = (lE >> 6 Or lE << 26) Xor (lE >> 11 Or lE << 21) Xor (lE >> 25 Or lE << 7)
                        lSigma0 = (lA >> 2 Or lA << 30) Xor (lA >> 13 Or lA << 19) Xor (lA >> 22 Or lA << 10)
                        lCh = (lE And lF) Xor ((Not lE) And lG)
                        lMaj = (lA And lB) Xor (lA And lC) Xor (lB And lC)
                        lT1 = lH + lSigma1 + lCh + LNG_K(lIdx) + W(lIdx)
                        lT2 = lSigma0 + lMaj
                    #Else
                        lT1 = UAdd32(UAdd32(UAdd32(UAdd32(lH, BigSigma1(lE)), Ch(lE, lF, lG)), LNG_K(lIdx)), W(lIdx))
                        lT2 = UAdd32(BigSigma0(lA), Maj(lA, lB, lC))
                    #End If
                    lH = lG
                    lG = lF
                    lF = lE
                    #If HasOperators Then
                        lE = lD + lT1
                    #Else
                        lE = UAdd32(lD, lT1)
                    #End If
                    lD = lC
                    lC = lB
                    lB = lA
                    #If HasOperators Then
                        lA = lT1 + lT2
                    #Else
                        lA = UAdd32(lT1, lT2)
                    #End If
                Next
                #If HasOperators Then
                    .H0 += lA: .H1 += lB: .H2 += lC: .H3 += lD
                    .H4 += lE: .H5 += lF: .H6 += lG: .H7 += lH
                #Else
                    .H0 = UAdd32(.H0, lA): .H1 = UAdd32(.H1, lB): .H2 = UAdd32(.H2, lC): .H3 = UAdd32(.H3, lD)
                    .H4 = UAdd32(.H4, lE): .H5 = UAdd32(.H5, lF): .H6 = UAdd32(.H6, lG): .H7 = UAdd32(.H7, lH)
                #End If
            Loop
        End With
    End Sub
    
    Public Sub CryptoSha2Finalize(uCtx As CryptoSha2Context, baOutput() As Byte)
        Static B(0 To 7)    As Long
        Dim P(0 To LNG_BLOCKSZ + 9) As Byte
        Dim lSize           As Long
        
        With uCtx
            lSize = LNG_BLOCKSZ - .NPartial
            If lSize < 9 Then
                lSize = lSize + LNG_BLOCKSZ
            End If
            P(0) = &H80
            .NInput = .NInput / 10000@ * 8
            Call CopyMemory(B(0), .NInput, 8)
            Call CopyMemory(P(lSize - 4), BSwap32(B(0)), 4)
            Call CopyMemory(P(lSize - 8), BSwap32(B(1)), 4)
            CryptoSha2Update uCtx, P, Size:=lSize
            Debug.Assert .NPartial = 0
            B(0) = BSwap32(.H0): B(1) = BSwap32(.H1): B(2) = BSwap32(.H2): B(3) = BSwap32(.H3)
            B(4) = BSwap32(.H4): B(5) = BSwap32(.H5): B(6) = BSwap32(.H6): B(7) = BSwap32(.H7)
            ReDim baOutput(0 To (.BitSize + 7) \ 8 - 1) As Byte
            Call CopyMemory(baOutput(0), B(0), UBound(baOutput) + 1)
        End With
    End Sub
    
    Public Function CryptoSha2ByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
        Dim uCtx            As CryptoSha2Context
        
        Select Case lBitSize
    #If HasSha512 Then
        Case 512, 384, 512256, 512224
            CryptoSha2ByteArray = CryptoSha512ByteArray(lBitSize Mod 1000, baInput, Pos, Size)
    #End If
        Case Else
            CryptoSha2Init uCtx, lBitSize
            CryptoSha2Update uCtx, baInput, Pos, Size
            CryptoSha2Finalize uCtx, CryptoSha2ByteArray
        End Select
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
        If lSize > 0 Then
            ReDim baRetVal(0 To lSize - 1) As Byte
            Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            If Len(sByte) = 1 Then
                Mid$(ToHex, lIdx * 2 + 2, 1) = sByte
            Else
                Mid$(ToHex, lIdx * 2 + 1, 2) = sByte
            End If
        Next
    End Function
    
    Public Function CryptoSha2Text(ByVal lBitSize As Long, sText As String) As String
        CryptoSha2Text = ToHex(CryptoSha2ByteArray(lBitSize, ToUtf8Array(sText)))
    End Function
    
    Public Function CryptoHmacSha2ByteArray(ByVal lBitSize As Long, baKey() As Byte, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
        Const INNER_PAD     As Long = &H36
        Const OUTER_PAD     As Long = &H5C
        Dim lPadSize        As Long
        Dim lIdx            As Long
        Dim baPass()        As Byte
        Dim baPad()         As Byte
        Dim baHash()        As Byte
        
        lPadSize = IIf(lBitSize > 256, LNG_BLOCKSZ * 2, LNG_BLOCKSZ)
        If UBound(baKey) < lPadSize Then
            baPass = baKey
        Else
            baPass = CryptoSha2ByteArray(lBitSize, baKey)
        End If
        If Size < 0 Then
            Size = UBound(baInput) + 1 - Pos
        End If
        ReDim baPad(0 To lPadSize + Size - 1) As Byte
        For lIdx = 0 To UBound(baPass)
            baPad(lIdx) = baPass(lIdx) Xor INNER_PAD
        Next
        For lIdx = lIdx To lPadSize - 1
            baPad(lIdx) = INNER_PAD
        Next
        If Size > 0 Then
            Call CopyMemory(baPad(lPadSize), baInput(Pos), Size)
        End If
        baHash = CryptoSha2ByteArray(lBitSize, baPad)
        Size = UBound(baHash) + 1
        ReDim baPad(0 To lPadSize + Size - 1) As Byte
        For lIdx = 0 To UBound(baPass)
            baPad(lIdx) = baPass(lIdx) Xor OUTER_PAD
        Next
        For lIdx = lIdx To lPadSize - 1
            baPad(lIdx) = OUTER_PAD
        Next
        Call CopyMemory(baPad(lPadSize), baHash(0), Size)
        CryptoHmacSha2ByteArray = CryptoSha2ByteArray(lBitSize, baPad)
    End Function
    
    Public Function CryptoHmacSha2Text(ByVal lBitSize As Long, sKey As String, sText As String) As String
        CryptoHmacSha2Text = ToHex(CryptoHmacSha2ByteArray(lBitSize, ToUtf8Array(sKey), ToUtf8Array(sText)))
    End Function
    
    Public Function CryptoPbkdf2HmacSha2ByteArray(ByVal lBitSize As Long, baPass() As Byte, baSalt() As Byte, _
                Optional ByVal OutSize As Long, _
                Optional ByVal NumIter As Long = 10000) As Byte()
        Dim baRetVal()      As Byte
        Dim lIdx            As Long
        Dim lJdx            As Long
        Dim lKdx            As Long
        Dim lHashSize       As Long
        Dim baInit()        As Byte
        Dim baHmac()        As Byte
        Dim baTemp()        As Byte
        Dim lRemaining      As Long
        
        If NumIter <= 0 Then
            baRetVal = vbNullString
        Else
            If OutSize <= 0 Then
                OutSize = (lBitSize + 7) \ 8
            End If
            ReDim baRetVal(0 To OutSize - 1) As Byte
            baInit = baSalt
            ReDim Preserve baInit(0 To LenB(CStr(baInit)) + 3) As Byte
            lHashSize = (lBitSize + 7) \ 8
            For lIdx = 0 To (OutSize + lHashSize - 1) \ lHashSize - 1
                Call CopyMemory(baInit(UBound(baInit) - 3), BSwap32(lIdx + 1), 4)
                baTemp = baInit
                ReDim baHmac(0 To lHashSize - 1) As Byte
                For lJdx = 0 To NumIter - 1
                    baTemp = CryptoHmacSha2ByteArray(lBitSize, baPass, baTemp)
                    For lKdx = 0 To UBound(baTemp)
                        baHmac(lKdx) = baHmac(lKdx) Xor baTemp(lKdx)
                    Next
                Next
                lRemaining = OutSize - lIdx * lHashSize
                If lRemaining > lHashSize Then
                    lRemaining = lHashSize
                End If
                Call CopyMemory(baRetVal(lIdx * lHashSize), baHmac(0), lRemaining)
            Next
        End If
        CryptoPbkdf2HmacSha2ByteArray = baRetVal
    End Function
    
    Public Function CryptoPbkdf2HmacSha2Text(ByVal lBitSize As Long, sPass As String, sSalt As String, _
                Optional ByVal OutSize As Long, _
                Optional ByVal NumIter As Long = 10000) As String
        CryptoPbkdf2HmacSha2Text = ToHex(CryptoPbkdf2HmacSha2ByteArray(lBitSize, ToUtf8Array(sPass), ToUtf8Array(sSalt), NumIter:=NumIter, OutSize:=OutSize))
    End Function
    The included CryptoHmacSha2ByteArray function is tested with hmac_sha224_test.json, hmac_sha256_test.json, hmac_sha384_test.json and hmac_sha512_test.json from Project Wycheproof test vectors.

    There is also CryptoPbkdf2HmacSha2ByteArray function included for of PBKDF2 derived key expansion using SHA-2.

    cheers,
    </wqw>

  2. #2

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6/VBA] Pure VB6 impl of SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/256 incl.

    (continued)

    SHA-384, SHA-512, SHA-512/224 and SHA-512/256 are implemented in a separate mdSha512.bas module which can be integrated directly in original CryptSha2Text, CryptSha2ByteArray and CryptoHmacSha2ByteArray functions by declaring CRYPT_HAS_SHA512 = 1 conditional compilation and passing respectively 384, 512, 512224 and 512256 for BitSize parameters.

    Code:
    '--- mdSha512.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasPtrSafe = (VBA7 <> 0)
    
    #If HasPtrSafe Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
    #End If
    
    Private Const LNG_BLOCKSZ               As Long = 128
    Private Const LNG_ROUNDS                As Long = 80
    
    Public Type CryptoSha512Context
    #If HasPtrSafe Then
        H0                  As LongLong
        H1                  As LongLong
        H2                  As LongLong
        H3                  As LongLong
        H4                  As LongLong
        H5                  As LongLong
        H6                  As LongLong
        H7                  As LongLong
    #Else
        H0                  As Variant
        H1                  As Variant
        H2                  As Variant
        H3                  As Variant
        H4                  As Variant
        H5                  As Variant
        H6                  As Variant
        H7                  As Variant
    #End If
        Partial(0 To LNG_BLOCKSZ - 1) As Byte
        NPartial            As Long
        NInput              As Currency
        BitSize             As Long
    End Type
    
    #If HasPtrSafe Then
        Private LNG_K(0 To LNG_ROUNDS - 1) As LongLong
        Private LNG_POW2(0 To 63)       As LongLong
    #Else
        Private LNG_K(0 To LNG_ROUNDS - 1) As Variant
        Private LNG_POW2(0 To 63)       As Variant
    #End If
    
    #If HasPtrSafe Then
    Private Function RotR64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
    #Else
    Private Function RotR64(lX As Variant, ByVal lN As Long) As Variant
    #End If
        '--- RotR64 = RShift64(X, n) Or LShift64(X, 64 - n)
        Debug.Assert lN <> 0
        RotR64 = ((lX And (-1 Xor LNG_POW2(63))) \ LNG_POW2(lN) Or -(lX < 0) * LNG_POW2(63 - lN)) Or _
            ((lX And (LNG_POW2(lN - 1) - 1)) * LNG_POW2(64 - lN) Or -((lX And LNG_POW2(lN - 1)) <> 0) * LNG_POW2(63))
    End Function
    
    #If HasPtrSafe Then
    Private Function LShift64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
    #Else
    Private Function LShift64(lX As Variant, ByVal lN As Long) As Variant
    #End If
        If lN = 0 Then
            LShift64 = lX
        Else
            LShift64 = (lX And (LNG_POW2(63 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(63 - lN)) <> 0) * LNG_POW2(63)
        End If
    End Function
    
    #If HasPtrSafe Then
    Private Function RShift64(ByVal lX As LongLong, ByVal lN As Long) As LongLong
    #Else
    Private Function RShift64(lX As Variant, ByVal lN As Long) As Variant
    #End If
        If lN = 0 Then
            RShift64 = lX
        Else
            RShift64 = (lX And (-1 Xor LNG_POW2(63))) \ LNG_POW2(lN) Or -(lX < 0) * LNG_POW2(63 - lN)
        End If
    End Function
    
    #If HasPtrSafe Then
    Private Function UAdd64(ByVal lX As LongLong, ByVal lY As LongLong) As LongLong
    #Else
    Private Function UAdd64(lX As Variant, lY As Variant) As Variant
    #End If
        If (lX Xor lY) >= 0 Then
            UAdd64 = ((lX Xor LNG_POW2(63)) + lY) Xor LNG_POW2(63)
        Else
            UAdd64 = lX + lY
        End If
    End Function
    
    #If HasPtrSafe Then
    Private Function Ch(ByVal lX As LongLong, ByVal lY As LongLong, ByVal lZ As LongLong) As LongLong
    #Else
    Private Function Ch(lX As Variant, lY As Variant, ByVal lZ As Variant) As Variant
    #End If
        Ch = (lX And lY) Xor ((Not lX) And lZ)
    End Function
    
    #If HasPtrSafe Then
    Private Function Maj(ByVal lX As LongLong, ByVal lY As LongLong, ByVal lZ As LongLong) As LongLong
    #Else
    Private Function Maj(lX As Variant, lY As Variant, lZ As Variant) As Variant
    #End If
        Maj = (lX And lY) Xor (lX And lZ) Xor (lY And lZ)
    End Function
    
    #If HasPtrSafe Then
    Private Function BigSigma0(ByVal lX As LongLong) As LongLong
    #Else
    Private Function BigSigma0(lX As Variant) As Variant
    #End If
        BigSigma0 = RotR64(lX, 28) Xor RotR64(lX, 34) Xor RotR64(lX, 39)
    End Function
    
    #If HasPtrSafe Then
    Private Function BigSigma1(ByVal lX As LongLong) As LongLong
    #Else
    Private Function BigSigma1(lX As Variant) As Variant
    #End If
        BigSigma1 = RotR64(lX, 14) Xor RotR64(lX, 18) Xor RotR64(lX, 41)
    End Function
    
    #If HasPtrSafe Then
    Private Function SmallSigma0(ByVal lX As LongLong) As LongLong
    #Else
    Private Function SmallSigma0(lX As Variant) As Variant
    #End If
        SmallSigma0 = RotR64(lX, 1) Xor RotR64(lX, 8) Xor RShift64(lX, 7)
    End Function
    
    #If HasPtrSafe Then
    Private Function SmallSigma1(ByVal lX As LongLong) As LongLong
    #Else
    Private Function SmallSigma1(lX As Variant) As Variant
    #End If
        SmallSigma1 = RotR64(lX, 19) Xor RotR64(lX, 61) Xor RShift64(lX, 6)
    End Function
    
    Private Function BSwap32(ByVal lX As Long) As Long
        BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
                     (lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
    End Function
    
    #If HasPtrSafe Then
    Private Function BSwap64(ByVal lX As LongLong) As LongLong
    #Else
    Private Function BSwap64(ByVal lX As Variant) As Variant
    #End If
        Dim lA As Long
        lA = BSwap32(CLng(lX And &H7FFFFFFF))
        BSwap64 = lA And &H7FFFFFFF Or -((lA < 0) <> 0) * LNG_POW2(31) Or -((lX And LNG_POW2(31)) <> 0) * &H80
    End Function
    
    #If Not HasPtrSafe Then
        Private Function CLngLng(vValue As Variant) As Variant
            Const VT_I8 As Long = &H14
            Call VariantChangeType(CLngLng, vValue, 0, VT_I8)
        End Function
    #End If
    
    Public Sub CryptoSha512Init(uCtx As CryptoSha512Context, ByVal lBitSize As Long)
        Dim vElem           As Variant
        Dim lIdx            As Long
        Dim vSplit          As Variant
        
        If LNG_K(0) = 0 Then
            '--- K: first 64 bits of the fractional parts of the cube roots of the first 80 primes
            For Each vElem In Split("428A2F98D728AE22 7137449123EF65CD B5C0FBCFEC4D3B2F E9B5DBA58189DBBC 3956C25BF348B538 59F111F1B605D019 923F82A4AF194F9B AB1C5ED5DA6D8118 D807AA98A3030242 12835B0145706FBE 243185BE4EE4B28C 550C7DC3D5FFB4E2 72BE5D74F27B896F 80DEB1FE3B1696B1 9BDC06A725C71235 C19BF174CF692694 E49B69C19EF14AD2 EFBE4786384F25E3 0FC19DC68B8CD5B5 240CA1CC77AC9C65 2DE92C6F592B0275 4A7484AA6EA6E483 5CB0A9DCBD41FBD4 76F988DA831153B5 983E5152EE66DFAB A831C66D2DB43210 B00327C898FB213F BF597FC7BEEF0EE4 C6E00BF33DA88FC2 D5A79147930AA725 06CA6351E003826F 142929670A0E6E70 27B70A8546D22FFC 2E1B21385C26C926 4D2C6DFC5AC42AED 53380D139D95B3DF 650A73548BAF63DE 766A0ABB3C77B2A8 81C2C92E47EDAEE6 92722C851482353B " & _
                                    "A2BFE8A14CF10364 A81A664BBC423001 C24B8B70D0F89791 C76C51A30654BE30 D192E819D6EF5218 D69906245565A910 F40E35855771202A 106AA07032BBD1B8 19A4C116B8D2D0C8 1E376C085141AB53 2748774CDF8EEB99 34B0BCB5E19B48A8 391C0CB3C5C95A63 4ED8AA4AE3418ACB 5B9CCA4F7763E373 682E6FF3D6B2B8A3 748F82EE5DEFB2FC 78A5636F43172F60 84C87814A1F0AB72 8CC702081A6439EC 90BEFFFA23631E28 A4506CEBDE82BDE9 BEF9A3F7B2C67915 C67178F2E372532B CA273ECEEA26619C D186B8C721C0C207 EADA7DD6CDE0EB1E F57D4F7FEE6ED178 06F067AA72176FBA 0A637DC5A2C898A6 113F9804BEF90DAE 1B710B35131C471B 28DB77F523047D84 32CAAB7B40C72493 3C9EBE0A15C9BEBC 431D67C49C100D4C 4CC5D4BECB3E42B6 597F299CFC657E2A 5FCB6FAB3AD6FAEC 6C44198C4A475817")
                LNG_K(lIdx) = CLngLng(CStr("&H" & vElem))
                lIdx = lIdx + 1
            Next
            LNG_POW2(0) = CLngLng(1)
            For lIdx = 1 To 63
                LNG_POW2(lIdx) = CVar(LNG_POW2(lIdx - 1)) * 2
            Next
        End If
        With uCtx
            Select Case lBitSize Mod 1000
            Case 224
                vSplit = Split("8C3D37C819544DA2 73E1996689DCD4D6 1DFAB7AE32FF9C82 679DD514582F9FCF F6D2B697BD44DA8 77E36F7304C48942 3F9D85A86A1D36C8 1112E6AD91D692A1")
            Case 256
                vSplit = Split("22312194FC2BF72C 9F555FA3C84C64C2 2393B86B6F53B151 963877195940EABD 96283EE2A88EFFE3 BE5E1E2553863992 2B0199FC2C85B8AA EB72DDC81C52CA2")
            Case 384
                vSplit = Split("CBBB9D5DC1059ED8 629A292A367CD507 9159015A3070DD17 152FECD8F70E5939 67332667FFC00B31 8EB44A8768581511 DB0C2E0D64F98FA7 47B5481DBEFA4FA4")
            Case 512
                vSplit = Split("6A09E667F3BCC908 BB67AE8584CAA73B 3C6EF372FE94F82B A54FF53A5F1D36F1 510E527FADE682D1 9B05688C2B3E6C1F 1F83D9ABFB41BD6B 5BE0CD19137E2179")
            Case Else
                Err.Raise vbObjectError, , "Invalid bit-size for SHA-512 (" & lBitSize & ")"
            End Select
            .H0 = CLngLng(CStr("&H" & vSplit(0))): .H1 = CLngLng(CStr("&H" & vSplit(1))): .H2 = CLngLng(CStr("&H" & vSplit(2))): .H3 = CLngLng(CStr("&H" & vSplit(3)))
            .H4 = CLngLng(CStr("&H" & vSplit(4))): .H5 = CLngLng(CStr("&H" & vSplit(5))): .H6 = CLngLng(CStr("&H" & vSplit(6))): .H7 = CLngLng(CStr("&H" & vSplit(7)))
            .NPartial = 0
            .NInput = 0
            .BitSize = lBitSize
        End With
    End Sub
    
    #If HasOperators Then
    [ IntegerOverflowChecks (False) ]
    #End If
    Public Sub CryptoSha512Update(uCtx As CryptoSha512Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Static B(0 To 31)   As Long
    #If HasPtrSafe Then
        Static W(0 To LNG_ROUNDS - 1) As LongLong
        Dim lA              As LongLong
        Dim lB              As LongLong
        Dim lC              As LongLong
        Dim lD              As LongLong
        Dim lE              As LongLong
        Dim lF              As LongLong
        Dim lG              As LongLong
        Dim lH              As LongLong
        Dim lT1             As LongLong
        Dim lT2             As LongLong
    #Else
        Static W(0 To LNG_ROUNDS - 1) As Variant
        Dim lA              As Variant
        Dim lB              As Variant
        Dim lC              As Variant
        Dim lD              As Variant
        Dim lE              As Variant
        Dim lF              As Variant
        Dim lG              As Variant
        Dim lH              As Variant
        Dim lT1             As Variant
        Dim lT2             As Variant
    #End If
        Dim lIdx            As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            .NInput = .NInput + Size
            If .NPartial > 0 Then
                lIdx = LNG_BLOCKSZ - .NPartial
                If lIdx > Size Then
                    lIdx = Size
                End If
                Call CopyMemory(.Partial(.NPartial), baInput(Pos), lIdx)
                .NPartial = .NPartial + lIdx
                Pos = Pos + lIdx
                Size = Size - lIdx
            End If
            Do While Size > 0 Or .NPartial = LNG_BLOCKSZ
                If .NPartial <> 0 Then
                    Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
                    .NPartial = 0
                ElseIf Size >= LNG_BLOCKSZ Then
                    Call CopyMemory(B(0), baInput(Pos), LNG_BLOCKSZ)
                    Pos = Pos + LNG_BLOCKSZ
                    Size = Size - LNG_BLOCKSZ
                Else
                    Call CopyMemory(.Partial(0), baInput(Pos), Size)
                    .NPartial = Size
                    Exit Do
                End If
                '--- sha512 step
                lA = .H0: lB = .H1: lC = .H2: lD = .H3
                lE = .H4: lF = .H5: lG = .H6: lH = .H7
                For lIdx = 0 To LNG_ROUNDS - 1
                    If lIdx < 16 Then
                        W(lIdx) = BSwap64(CLngLng(B(lIdx * 2 + 1))) Or LShift64(BSwap64(CLngLng(B(lIdx * 2))), 32)
                    Else
                        W(lIdx) = UAdd64(UAdd64(UAdd64(SmallSigma1(W(lIdx - 2)), W(lIdx - 7)), SmallSigma0(W(lIdx - 15))), W(lIdx - 16))
                    End If
                    lT1 = UAdd64(UAdd64(UAdd64(UAdd64(lH, BigSigma1(lE)), Ch(lE, lF, lG)), LNG_K(lIdx)), W(lIdx))
                    lT2 = UAdd64(BigSigma0(lA), Maj(lA, lB, lC))
                    lH = lG
                    lG = lF
                    lF = lE
                    lE = UAdd64(lD, lT1)
                    lD = lC
                    lC = lB
                    lB = lA
                    lA = UAdd64(lT1, lT2)
                Next
                .H0 = UAdd64(.H0, lA): .H1 = UAdd64(.H1, lB): .H2 = UAdd64(.H2, lC): .H3 = UAdd64(.H3, lD)
                .H4 = UAdd64(.H4, lE): .H5 = UAdd64(.H5, lF): .H6 = UAdd64(.H6, lG): .H7 = UAdd64(.H7, lH)
            Loop
        End With
    End Sub
    
    #If HasPtrSafe Then
    Private Function pvToLong(ByVal lX As LongLong, lHi As Long, lLo As Long) As Long
        Dim lA              As LongLong
    #Else
    Private Function pvToLong(ByVal lX As Variant, lHi As Long, lLo As Long) As Long
        Dim lA              As Variant
    #End If
        lA = BSwap64(RShift64(lX, 32))
        lHi = CLng(lA And &H7FFFFFFF) Or -((lA And LNG_POW2(31)) <> 0) * &H80000000
        lA = BSwap64(lX)
        lLo = CLng(lA And &H7FFFFFFF) Or -((lA And LNG_POW2(31)) <> 0) * &H80000000
    End Function
    
    Public Sub CryptoSha512Finalize(uCtx As CryptoSha512Context, baOutput() As Byte)
        Static B(0 To 15)   As Long
        Dim P(0 To LNG_BLOCKSZ + 17) As Byte
        Dim lSize           As Long
        
        With uCtx
            lSize = LNG_BLOCKSZ - .NPartial
            If lSize < 17 Then
                lSize = lSize + LNG_BLOCKSZ
            End If
            P(0) = &H80
            .NInput = .NInput / 10000@ * 8
            Call CopyMemory(B(0), .NInput, 8)
            Call CopyMemory(P(lSize - 4), BSwap32(B(0)), 4)
            Call CopyMemory(P(lSize - 8), BSwap32(B(1)), 4)
            CryptoSha512Update uCtx, P, Size:=lSize
            Debug.Assert .NPartial = 0
            pvToLong .H0, B(0), B(1)
            pvToLong .H1, B(2), B(3)
            pvToLong .H2, B(4), B(5)
            pvToLong .H3, B(6), B(7)
            pvToLong .H4, B(8), B(9)
            pvToLong .H5, B(10), B(11)
            pvToLong .H6, B(12), B(13)
            pvToLong .H7, B(14), B(15)
            ReDim baOutput(0 To (.BitSize + 7) \ 8 - 1) As Byte
            Call CopyMemory(baOutput(0), B(0), UBound(baOutput) + 1)
        End With
    End Sub
    
    Public Function CryptoSha512ByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
        Dim uCtx            As CryptoSha512Context
        
        CryptoSha512Init uCtx, lBitSize
        CryptoSha512Update uCtx, baInput, Pos, Size
        CryptoSha512Finalize uCtx, CryptoSha512ByteArray
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
        If lSize > 0 Then
            ReDim baRetVal(0 To lSize - 1) As Byte
            Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            If Len(sByte) = 1 Then
                Mid$(ToHex, lIdx * 2 + 2, 1) = sByte
            Else
                Mid$(ToHex, lIdx * 2 + 1, 2) = sByte
            End If
        Next
    End Function
    
    Public Function CryptoSha512Text(ByVal lBitSize As Long, sText As String) As String
        CryptoSha512Text = ToHex(CryptoSha512ByteArray(lBitSize, ToUtf8Array(sText)))
    End Function
    Procedures CryptSha512Text and CryptSha512ByteArray support 384, 512, 224 and 256 for BitSize parameters for SHA-384, SHA-512, SHA-512/224 and SHA-512/256 hashes respectively.

    cheers,
    </wqw>

  3. #3

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6/VBA] Pure VB6 impl of SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/256 incl.

    This mdSha512Sliced.bas alternative module uses 32-bit operations only for the SHA-512 hash rounds and w/ performance of ~18MB/s compiled with full optimizations is up to 30x faster than original mdSha512.bas implementation above.

    Code:
    '--- mdSha512Sliced.bas
    Option Explicit
    DefObj A-Z
    
    #Const HasPtrSafe = (VBA7 <> 0)
    #Const HasOperators = (TWINBASIC <> 0)
    
    #If HasPtrSafe Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function ArrPtr Lib "vbe7" Alias "VarPtr" (Ptr() As Any) As LongPtr
    Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As LongPtr
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    #End If
    
    Private Const LNG_BLOCKSZ               As Long = 128
    Private Const LNG_ROUNDS                As Long = 80
    Private Const LNG_POW2_1                As Long = 2 ^ 1
    Private Const LNG_POW2_2                As Long = 2 ^ 2
    Private Const LNG_POW2_3                As Long = 2 ^ 3
    Private Const LNG_POW2_4                As Long = 2 ^ 4
    Private Const LNG_POW2_5                As Long = 2 ^ 5
    Private Const LNG_POW2_6                As Long = 2 ^ 6
    Private Const LNG_POW2_7                As Long = 2 ^ 7
    Private Const LNG_POW2_8                As Long = 2 ^ 8
    Private Const LNG_POW2_9                As Long = 2 ^ 9
    Private Const LNG_POW2_12               As Long = 2 ^ 12
    Private Const LNG_POW2_13               As Long = 2 ^ 13
    Private Const LNG_POW2_14               As Long = 2 ^ 14
    Private Const LNG_POW2_17               As Long = 2 ^ 17
    Private Const LNG_POW2_18               As Long = 2 ^ 18
    Private Const LNG_POW2_19               As Long = 2 ^ 19
    Private Const LNG_POW2_22               As Long = 2 ^ 22
    Private Const LNG_POW2_23               As Long = 2 ^ 23
    Private Const LNG_POW2_24               As Long = 2 ^ 24
    Private Const LNG_POW2_25               As Long = 2 ^ 25
    Private Const LNG_POW2_26               As Long = 2 ^ 26
    Private Const LNG_POW2_27               As Long = 2 ^ 27
    Private Const LNG_POW2_28               As Long = 2 ^ 28
    Private Const LNG_POW2_29               As Long = 2 ^ 29
    Private Const LNG_POW2_30               As Long = 2 ^ 30
    Private Const LNG_POW2_31               As Long = &H80000000
    
    Private Type SAFEARRAY1D
        cDims               As Integer
        fFeatures           As Integer
        cbElements          As Long
        cLocks              As Long
        pvData              As LongPtr
        cElements           As Long
        lLbound             As Long
    End Type
    
    Private Type ArrayLong16
        Item(0 To 15)       As Long
    End Type
    
    Private Type ArrayLong32
        Item(0 To 31)       As Long
    End Type
    
    Public Type CryptoSha512Context
        State               As ArrayLong16
        Block               As ArrayLong32
        Bytes()             As Byte                 '--- overlaying Block or State arrays above
        ArrayBytes          As SAFEARRAY1D
        NPartial            As Long
        NInput              As Currency
        BitSize             As Long
    End Type
    
    Private LNG_K(0 To 2 * LNG_ROUNDS - 1) As Long
    Private m_bNoIntegerOverflowChecks As Boolean
    
    Private Function BSwap32(ByVal lX As Long) As Long
        #If Not HasOperators Then
            BSwap32 = (lX And &H7F) * &H1000000 Or (lX And &HFF00&) * &H100 Or (lX And &HFF0000) \ &H100 Or _
                      (lX And &HFF000000) \ &H1000000 And &HFF Or -((lX And &H80) <> 0) * &H80000000
        #Else
            Return ((lX And &H000000FF&) << 24) Or _
                   ((lX And &H0000FF00&) << 8) Or _
                   ((lX And &H00FF0000&) >> 8) Or _
                   ((lX And &HFF000000&) >> 24)
        #End If
    End Function
    
    #If HasOperators Then
    [ IntegerOverflowChecks (False) ]
    #End If
    Private Sub pvAdd64(lAL As Long, lAH As Long, ByVal lBL As Long, ByVal lBH As Long)
        Dim lSign           As Long
        
        #If Not HasOperators Then
            If m_bNoIntegerOverflowChecks Then
                lAL = lAL + lBL
                lAH = lAH + lBH
                If (lAL And &H80000000) <> 0 Then
                    lSign = 1
                Else
                    lSign = 0
                End If
                If (lBL And &H80000000) <> 0 Then
                    lSign = lSign - 1
                End If
                Select Case True
                Case lSign < 0, lSign = 0 And (lAL And &H7FFFFFFF) < (lBL And &H7FFFFFFF)
                    lAH = lAH + 1
                End Select
            Else
                If (lAL Xor lBL) >= 0 Then
                    lAL = ((lAL Xor &H80000000) + lBL) Xor &H80000000
                Else
                    lAL = lAL + lBL
                End If
                If (lAH Xor lBH) >= 0 Then
                    lAH = ((lAH Xor &H80000000) + lBH) Xor &H80000000
                Else
                    lAH = lAH + lBH
                End If
                If (lAL And &H80000000) <> 0 Then
                    lSign = 1
                End If
                If (lBL And &H80000000) <> 0 Then
                    lSign = lSign - 1
                End If
                Select Case True
                Case lSign < 0, lSign = 0 And (lAL And &H7FFFFFFF) < (lBL And &H7FFFFFFF)
                    If lAH >= 0 Then
                        lAH = ((lAH Xor &H80000000) + 1) Xor &H80000000
                    Else
                        lAH = lAH + 1
                    End If
                End Select
            End If
        #Else
            lAL += lBL
            lAH += lBH
            lSign = (lAL >> 31) - (lBL >> 31)
            If lSign < 0 Or lSign = 0 And (lAL And &H7FFFFFFF) < (lBL And &H7FFFFFFF) Then
                lAH += 1
            End If
        #End If
    End Sub
    
    Private Function pvSum0L(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSum0L = ((lX And (LNG_POW2_6 - 1)) * LNG_POW2_25 Or -((lX And LNG_POW2_6) <> 0) * &H80000000) _
                Xor ((lX And (LNG_POW2_1 - 1)) * LNG_POW2_30 Or -((lX And LNG_POW2_1) <> 0) * &H80000000) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_28 Or -(lX < 0) * LNG_POW2_3) _
                Xor ((lY And &H7FFFFFFF) \ LNG_POW2_7 Or -(lY < 0) * LNG_POW2_24) _
                Xor ((lY And &H7FFFFFFF) \ LNG_POW2_2 Or -(lY < 0) * LNG_POW2_29) _
                Xor ((lY And (LNG_POW2_27 - 1)) * LNG_POW2_4 Or -((lY And LNG_POW2_27) <> 0) * &H80000000)
        #Else
            Return (lX << 25) Xor (lX << 30) Xor (lX >> 28) Xor (lY >> 7) Xor (lY >> 2) Xor (lY << 4)
        #End If
    End Function
    
    Private Function pvSum1L(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSum1L = ((lX And (LNG_POW2_8 - 1)) * LNG_POW2_23 Or -((lX And LNG_POW2_8) <> 0) * &H80000000) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_14 Or -(lX < 0) * LNG_POW2_17) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_18 Or -(lX < 0) * LNG_POW2_13) _
                Xor ((lY And &H7FFFFFFF) \ LNG_POW2_9 Or -(lY < 0) * LNG_POW2_22) _
                Xor ((lY And (LNG_POW2_13 - 1)) * LNG_POW2_18 Or -((lY And LNG_POW2_13) <> 0) * &H80000000) _
                Xor ((lY And (LNG_POW2_17 - 1)) * LNG_POW2_14 Or -((lY And LNG_POW2_17) <> 0) * &H80000000)
        #Else
            Return (lX << 23) Xor (lX >> 14) Xor (lX >> 18) Xor (lY >> 9) Xor (lY << 18) Xor (lY << 14)
        #End If
    End Function
    
    Private Function pvSig0L(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSig0L = ((lX And &H7FFFFFFF) \ LNG_POW2_1 Or -(lX < 0) * LNG_POW2_30) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_7 Or -(lX < 0) * LNG_POW2_24) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_8 Or -(lX < 0) * LNG_POW2_23) _
                Xor ((lY And 0) * LNG_POW2_31 Or -((lY And 1) <> 0) * &H80000000) _
                Xor ((lY And (LNG_POW2_6 - 1)) * LNG_POW2_25 Or -((lY And LNG_POW2_6) <> 0) * &H80000000) _
                Xor ((lY And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lY And LNG_POW2_7) <> 0) * &H80000000)
        #Else
            Return (lX >> 1) Xor (lX >> 7) Xor (lX >> 8) Xor (lY << 31) Xor (lY << 25) Xor (lY << 24)
        #End If
    End Function
      
    Private Function pvSig0H(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSig0H = ((lX And &H7FFFFFFF) \ LNG_POW2_1 Or -(lX < 0) * LNG_POW2_30) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_7 Or -(lX < 0) * LNG_POW2_24) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_8 Or -(lX < 0) * LNG_POW2_23) _
                Xor ((lY And 0) * LNG_POW2_31 Or -((lY And 1) <> 0) * &H80000000) _
                Xor ((lY And (LNG_POW2_7 - 1)) * LNG_POW2_24 Or -((lY And LNG_POW2_7) <> 0) * &H80000000)
        #Else
            Return (lX >> 1) Xor (lX >> 7) Xor (lX >> 8) Xor (lY << 31) Xor (lY << 24)
        #End If
    End Function
    
    Private Function pvSig1L(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSig1L = ((lX And (LNG_POW2_28 - 1)) * LNG_POW2_3 Or -((lX And LNG_POW2_28) <> 0) * &H80000000) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_6 Or -(lX < 0) * LNG_POW2_25) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_19 Or -(lX < 0) * LNG_POW2_12) _
                Xor ((lY And &H7FFFFFFF) \ LNG_POW2_29 Or -(lY < 0) * LNG_POW2_2) _
                Xor ((lY And (LNG_POW2_5 - 1)) * LNG_POW2_26 Or -((lY And LNG_POW2_5) <> 0) * &H80000000) _
                Xor ((lY And (LNG_POW2_18 - 1)) * LNG_POW2_13 Or -((lY And LNG_POW2_18) <> 0) * &H80000000)
        #Else
            Return (lX << 3) Xor (lX >> 6) Xor (lX >> 19) Xor (lY >> 29) Xor (lY << 26) Xor (lY << 13)
        #End If
    End Function
    
    Private Function pvSig1H(ByVal lX As Long, ByVal lY As Long) As Long
        #If Not HasOperators Then
            pvSig1H = ((lX And (LNG_POW2_28 - 1)) * LNG_POW2_3 Or -((lX And LNG_POW2_28) <> 0) * &H80000000) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_6 Or -(lX < 0) * LNG_POW2_25) _
                Xor ((lX And &H7FFFFFFF) \ LNG_POW2_19 Or -(lX < 0) * LNG_POW2_12) _
                Xor ((lY And &H7FFFFFFF) \ LNG_POW2_29 Or -(lY < 0) * LNG_POW2_2) _
                Xor ((lY And (LNG_POW2_18 - 1)) * LNG_POW2_13 Or -((lY And LNG_POW2_18) <> 0) * &H80000000)
        #Else
            Return (lX << 3) Xor (lX >> 6) Xor (lX >> 19) Xor (lY >> 29) Xor (lY << 13)
        #End If
    End Function
    
    Private Sub pvRound( _
                ByVal lX00 As Long, ByVal lX01 As Long, ByVal lX02 As Long, ByVal lX03 As Long, ByVal lX04 As Long, ByVal lX05 As Long, lX06 As Long, lX07 As Long, _
                ByVal lX08 As Long, ByVal lX09 As Long, ByVal lX10 As Long, ByVal lX11 As Long, ByVal lX12 As Long, ByVal lX13 As Long, lX14 As Long, lX15 As Long, _
                uArray As ArrayLong32, ByVal lIdx As Long, ByVal lJdx As Long)
        pvAdd64 lX14, lX15, uArray.Item(lIdx), uArray.Item(lIdx + 1)
        pvAdd64 lX14, lX15, LNG_K(lJdx + lIdx), LNG_K(lJdx + lIdx + 1)
        pvAdd64 lX14, lX15, lX12 Xor (lX08 And (lX10 Xor lX12)), lX13 Xor (lX09 And (lX11 Xor lX13))
        pvAdd64 lX14, lX15, pvSum1L(lX08, lX09), pvSum1L(lX09, lX08)
        pvAdd64 lX06, lX07, lX14, lX15
        pvAdd64 lX14, lX15, pvSum0L(lX00, lX01), pvSum0L(lX01, lX00)
        pvAdd64 lX14, lX15, ((lX00 Or lX04) And lX02) Or (lX04 And lX00), ((lX01 Or lX05) And lX03) Or (lX05 And lX01)
    End Sub
    
    Private Sub pvStore(uArray As ArrayLong32, ByVal lIdx As Long)
        Dim lTL             As Long
        Dim lTH             As Long
        Dim lUL             As Long
        Dim lUH             As Long
        
        With uArray
            lTL = .Item(lIdx)
            lTH = .Item(lIdx + 1)
            pvAdd64 lTL, lTH, .Item((lIdx + 18) And &H1F), .Item((lIdx + 19) And &H1F)
            lUL = pvSig0L(.Item((lIdx + 2) And &H1F), .Item((lIdx + 3) And &H1F))
            lUH = pvSig0H(.Item((lIdx + 3) And &H1F), .Item((lIdx + 2) And &H1F))
            pvAdd64 lTL, lTH, lUL, lUH
            lUL = pvSig1L(.Item((lIdx + 28) And &H1F), .Item((lIdx + 29) And &H1F))
            lUH = pvSig1H(.Item((lIdx + 29) And &H1F), .Item((lIdx + 28) And &H1F))
            pvAdd64 lTL, lTH, lUL, lUH
            .Item(lIdx) = lTL
            .Item(lIdx + 1) = lTH
        End With
    End Sub
    
    Private Function pvGetOverflowIgnored() As Boolean
        On Error GoTo EH
        If &H8000 - 1 <> 0 Then
            pvGetOverflowIgnored = True
        End If
    EH:
    End Function
    
    Public Sub CryptoSha512Init(uCtx As CryptoSha512Context, ByVal lBitSize As Long)
        Const FADF_AUTO     As Long = 1
        Dim vElem           As Variant
        Dim lIdx            As Long
        Dim vSplit          As Variant
        Dim pDummy          As LongPtr
        
        If LNG_K(0) = 0 Then
            '--- K: first 64 bits of the fractional parts of the cube roots of the first 80 primes
            For Each vElem In Split("D728AE22 428A2F98 23EF65CD 71374491 EC4D3B2F B5C0FBCF 8189DBBC E9B5DBA5 F348B538 3956C25B B605D019 59F111F1 AF194F9B 923F82A4 DA6D8118 AB1C5ED5 A3030242 D807AA98 45706FBE 12835B01 4EE4B28C 243185BE D5FFB4E2 550C7DC3 F27B896F 72BE5D74 3B1696B1 80DEB1FE 25C71235 9BDC06A7 CF692694 C19BF174 9EF14AD2 E49B69C1 384F25E3 EFBE4786 8B8CD5B5 0FC19DC6 77AC9C65 240CA1CC 592B0275 2DE92C6F 6EA6E483 4A7484AA BD41FBD4 5CB0A9DC 831153B5 76F988DA EE66DFAB 983E5152 2DB43210 A831C66D 98FB213F B00327C8 BEEF0EE4 BF597FC7 3DA88FC2 C6E00BF3 930AA725 D5A79147 E003826F 06CA6351 0A0E6E70 14292967 46D22FFC 27B70A85 5C26C926 2E1B2138 5AC42AED 4D2C6DFC 9D95B3DF 53380D13 8BAF63DE 650A7354 3C77B2A8 766A0ABB 47EDAEE6 81C2C92E 1482353B 92722C85 " & _
                                    "4CF10364 A2BFE8A1 BC423001 A81A664B D0F89791 C24B8B70 0654BE30 C76C51A3 D6EF5218 D192E819 5565A910 D6990624 5771202A F40E3585 32BBD1B8 106AA070 B8D2D0C8 19A4C116 5141AB53 1E376C08 DF8EEB99 2748774C E19B48A8 34B0BCB5 C5C95A63 391C0CB3 E3418ACB 4ED8AA4A 7763E373 5B9CCA4F D6B2B8A3 682E6FF3 5DEFB2FC 748F82EE 43172F60 78A5636F A1F0AB72 84C87814 1A6439EC 8CC70208 23631E28 90BEFFFA DE82BDE9 A4506CEB B2C67915 BEF9A3F7 E372532B C67178F2 EA26619C CA273ECE 21C0C207 D186B8C7 CDE0EB1E EADA7DD6 EE6ED178 F57D4F7F 72176FBA 06F067AA A2C898A6 0A637DC5 BEF90DAE 113F9804 131C471B 1B710B35 23047D84 28DB77F5 40C72493 32CAAB7B 15C9BEBC 3C9EBE0A 9C100D4C 431D67C4 CB3E42B6 4CC5D4BE FC657E2A 597F299C 3AD6FAEC 5FCB6FAB 4A475817 6C44198C")
                LNG_K(lIdx) = "&H" & vElem
                lIdx = lIdx + 1
            Next
            m_bNoIntegerOverflowChecks = pvGetOverflowIgnored
        End If
        With uCtx
            Select Case lBitSize Mod 1000
            Case 224
                vSplit = Split("19544DA2 8C3D37C8 89DCD4D6 73E19966 32FF9C82 1DFAB7AE 582F9FCF 679DD514 7BD44DA8 F6D2B69 04C48942 77E36F73 6A1D36C8 3F9D85A8 91D692A1 1112E6AD")
            Case 256
                vSplit = Split("FC2BF72C 22312194 C84C64C2 9F555FA3 6F53B151 2393B86B 5940EABD 96387719 A88EFFE3 96283EE2 53863992 BE5E1E25 2C85B8AA 2B0199FC 81C52CA2 EB72DDC")
            Case 384
                vSplit = Split("C1059ED8 CBBB9D5D 367CD507 629A292A 3070DD17 9159015A F70E5939 152FECD8 FFC00B31 67332667 68581511 8EB44A87 64F98FA7 DB0C2E0D BEFA4FA4 47B5481D")
            Case 512
                vSplit = Split("F3BCC908 6A09E667 84CAA73B BB67AE85 FE94F82B 3C6EF372 5F1D36F1 A54FF53A ADE682D1 510E527F 2B3E6C1F 9B05688C FB41BD6B 1F83D9AB 137E2179 5BE0CD19")
            Case Else
                Err.Raise vbObjectError, , "Invalid bit-size for SHA-512 (" & lBitSize & ")"
            End Select
            lIdx = 0
            For Each vElem In vSplit
                .State.Item(lIdx) = "&H" & vElem
                lIdx = lIdx + 1
            Next
            .NPartial = 0
            .NInput = 0
            .BitSize = lBitSize
            With .ArrayBytes
                .cDims = 1
                .fFeatures = FADF_AUTO
                .cbElements = 1
                .cLocks = 1
                .pvData = VarPtr(uCtx.Block.Item(0))
                .cElements = LNG_BLOCKSZ \ .cbElements
            End With
            Call CopyMemory(ByVal ArrPtr(.Bytes), VarPtr(.ArrayBytes), LenB(pDummy))
        End With
    End Sub
    
    Public Sub CryptoSha512Update(uCtx As CryptoSha512Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
        Dim lAL             As Long
        Dim lAH             As Long
        Dim lBL             As Long
        Dim lBH             As Long
        Dim lCL             As Long
        Dim lCh             As Long
        Dim lDL             As Long
        Dim lDH             As Long
        Dim lEL             As Long
        Dim lEH             As Long
        Dim lFL             As Long
        Dim lFH             As Long
        Dim lGL             As Long
        Dim lGH             As Long
        Dim lHL             As Long
        Dim lHH             As Long
        Dim lIdx            As Long
        Dim lJdx            As Long
        
        With uCtx
            If Size < 0 Then
                Size = UBound(baInput) + 1 - Pos
            End If
            .NInput = .NInput + Size
            If .NPartial > 0 And Size > 0 Then
                lIdx = LNG_BLOCKSZ - .NPartial
                If lIdx > Size Then
                    lIdx = Size
                End If
                Call CopyMemory(.Bytes(.NPartial), baInput(Pos), lIdx)
                .NPartial = .NPartial + lIdx
                Pos = Pos + lIdx
                Size = Size - lIdx
            End If
            Do While Size > 0 Or .NPartial = LNG_BLOCKSZ
                If .NPartial <> 0 Then
                    .NPartial = 0
                ElseIf Size >= LNG_BLOCKSZ Then
                    Call CopyMemory(.Bytes(0), baInput(Pos), LNG_BLOCKSZ)
                    Pos = Pos + LNG_BLOCKSZ
                    Size = Size - LNG_BLOCKSZ
                Else
                    Call CopyMemory(.Bytes(0), baInput(Pos), Size)
                    .NPartial = Size
                    Exit Do
                End If
                '--- sha512 step
                For lIdx = 0 To UBound(.Block.Item) Step 2
                    lAL = BSwap32(.Block.Item(lIdx))
                    .Block.Item(lIdx) = BSwap32(.Block.Item(lIdx + 1))
                    .Block.Item(lIdx + 1) = lAL
                Next
                lAL = .State.Item(0): lAH = .State.Item(1)
                lBL = .State.Item(2): lBH = .State.Item(3)
                lCL = .State.Item(4): lCh = .State.Item(5)
                lDL = .State.Item(6): lDH = .State.Item(7)
                lEL = .State.Item(8): lEH = .State.Item(9)
                lFL = .State.Item(10): lFH = .State.Item(11)
                lGL = .State.Item(12): lGH = .State.Item(13)
                lHL = .State.Item(14): lHH = .State.Item(15)
                lIdx = 0
                Do While lIdx < 2 * LNG_ROUNDS
                    lJdx = 0
                    Do While lJdx < LNG_BLOCKSZ \ 4
                        pvRound lAL, lAH, lBL, lBH, lCL, lCh, lDL, lDH, lEL, lEH, lFL, lFH, lGL, lGH, lHL, lHH, .Block, lJdx + 0, lIdx
                        pvRound lHL, lHH, lAL, lAH, lBL, lBH, lCL, lCh, lDL, lDH, lEL, lEH, lFL, lFH, lGL, lGH, .Block, lJdx + 2, lIdx
                        pvRound lGL, lGH, lHL, lHH, lAL, lAH, lBL, lBH, lCL, lCh, lDL, lDH, lEL, lEH, lFL, lFH, .Block, lJdx + 4, lIdx
                        pvRound lFL, lFH, lGL, lGH, lHL, lHH, lAL, lAH, lBL, lBH, lCL, lCh, lDL, lDH, lEL, lEH, .Block, lJdx + 6, lIdx
                        pvRound lEL, lEH, lFL, lFH, lGL, lGH, lHL, lHH, lAL, lAH, lBL, lBH, lCL, lCh, lDL, lDH, .Block, lJdx + 8, lIdx
                        pvRound lDL, lDH, lEL, lEH, lFL, lFH, lGL, lGH, lHL, lHH, lAL, lAH, lBL, lBH, lCL, lCh, .Block, lJdx + 10, lIdx
                        pvRound lCL, lCh, lDL, lDH, lEL, lEH, lFL, lFH, lGL, lGH, lHL, lHH, lAL, lAH, lBL, lBH, .Block, lJdx + 12, lIdx
                        pvRound lBL, lBH, lCL, lCh, lDL, lDH, lEL, lEH, lFL, lFH, lGL, lGH, lHL, lHH, lAL, lAH, .Block, lJdx + 14, lIdx
                        lJdx = lJdx + 16
                    Loop
                    lIdx = lIdx + 32
                    If lIdx >= 2 * LNG_ROUNDS Then
                        Exit Do
                    End If
                    For lJdx = 0 To 30 Step 2
                        pvStore .Block, lJdx
                    Next
                Loop
                pvAdd64 .State.Item(0), .State.Item(1), lAL, lAH
                pvAdd64 .State.Item(2), .State.Item(3), lBL, lBH
                pvAdd64 .State.Item(4), .State.Item(5), lCL, lCh
                pvAdd64 .State.Item(6), .State.Item(7), lDL, lDH
                pvAdd64 .State.Item(8), .State.Item(9), lEL, lEH
                pvAdd64 .State.Item(10), .State.Item(11), lFL, lFH
                pvAdd64 .State.Item(12), .State.Item(13), lGL, lGH
                pvAdd64 .State.Item(14), .State.Item(15), lHL, lHH
            Loop
        End With
    End Sub
    
    Public Sub CryptoSha512Finalize(uCtx As CryptoSha512Context, baOutput() As Byte)
        Static B(0 To 1)    As Long
        Dim baPad()         As Byte
        Dim lIdx            As Long
        Dim pDummy          As LongPtr
        
        With uCtx
            lIdx = LNG_BLOCKSZ - .NPartial
            If lIdx < 17 Then
                lIdx = lIdx + LNG_BLOCKSZ
            End If
            ReDim baPad(0 To lIdx - 1) As Byte
            baPad(0) = &H80
            .NInput = .NInput / 10000@ * 8
            Call CopyMemory(B(0), .NInput, 8)
            Call CopyMemory(baPad(lIdx - 4), BSwap32(B(0)), 4)
            Call CopyMemory(baPad(lIdx - 8), BSwap32(B(1)), 4)
            CryptoSha512Update uCtx, baPad
            Debug.Assert .NPartial = 0
            ReDim baOutput(0 To (.BitSize + 7) \ 8 - 1) As Byte
            .ArrayBytes.pvData = VarPtr(.State.Item(0))
            For lIdx = 0 To UBound(baOutput)
                baOutput(lIdx) = .Bytes(lIdx + 7 - 2 * (lIdx And 7))
            Next
            Call CopyMemory(ByVal ArrPtr(.Bytes), pDummy, LenB(pDummy))
        End With
    End Sub
    
    Public Function CryptoSha512ByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As Byte()
        Dim uCtx            As CryptoSha512Context
        
        CryptoSha512Init uCtx, lBitSize
        CryptoSha512Update uCtx, baInput, Pos, Size
        CryptoSha512Finalize uCtx, CryptoSha512ByteArray
    End Function
    
    Private Function ToUtf8Array(sText As String) As Byte()
        Const CP_UTF8       As Long = 65001
        Dim baRetVal()      As Byte
        Dim lSize           As Long
        
        ReDim baRetVal(0 To 4 * Len(sText)) As Byte
        lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), UBound(baRetVal) + 1, 0, 0)
        If lSize > 0 Then
            ReDim Preserve baRetVal(0 To lSize - 1) As Byte
        Else
            baRetVal = vbNullString
        End If
        ToUtf8Array = baRetVal
    End Function
    
    Private Function ToHex(baData() As Byte) As String
        Dim lIdx            As Long
        Dim sByte           As String
        
        ToHex = String$(UBound(baData) * 2 + 2, 48)
        For lIdx = 0 To UBound(baData)
            sByte = LCase$(Hex$(baData(lIdx)))
            Mid$(ToHex, lIdx * 2 + 3 - Len(sByte)) = sByte
        Next
    End Function
    
    Public Function CryptoSha512Text(ByVal lBitSize As Long, sText As String) As String
        CryptoSha512Text = ToHex(CryptoSha512ByteArray(lBitSize, ToUtf8Array(sText)))
    End Function
    cheers,
    </wqw>

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width