Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/mdSha2.bas

Last active April 17, 2023 07:22
Show Gist options
  • Save wqweto/0cc01c2380926e3cc0eaa5a0a3042f43 to your computer and use it in GitHub Desktop.
Save wqweto/0cc01c2380926e3cc0eaa5a0a3042f43 to your computer and use it in GitHub Desktop.
Download ZIP
[VB6/VBA] Pure VB6 implementation of SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/256 and SHA-512/224 incl. HMAC
Raw
mdSha2.bas
'--- 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 lZ)) Xor lZ
End Function
Private Function Maj(ByVal lX As Long, ByVal lY As Long, ByVal lZ As Long) As Long
Maj = (lX And (lY Or lZ)) Or (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 And Size > 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 lG)) Xor lG
lMaj = (lA And (lB Or lC)) Or (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
Public Function CryptoHkdfSha2ByteArray(ByVal lBitSize As Long, baIKM() As Byte, baSalt() As Byte, baInfo() As Byte, Optional ByVal OutSize As Long) As Byte()
Dim lHashSize As Long
Dim baRetVal() As Byte
Dim baKey() As Byte
Dim baPad() As Byte
Dim baHash() As Byte
Dim lIdx As Long
Dim lRemaining As Long
lHashSize = (lBitSize + 7) \ 8
If OutSize <= 0 Then
OutSize = lHashSize
End If
ReDim baRetVal(0 To OutSize - 1) As Byte
baKey = CryptoHmacSha2ByteArray(lBitSize, baSalt, baIKM)
ReDim baPad(0 To lHashSize + UBound(baInfo) + 1) As Byte
If UBound(baInfo) >= 0 Then
Call CopyMemory(baPad(lHashSize), baInfo(0), UBound(baInfo) + 1)
End If
For lIdx = 0 To (OutSize + lHashSize - 1) \ lHashSize - 1
baPad(UBound(baPad)) = (lIdx + 1) And &HFF
baHash = CryptoHmacSha2ByteArray(lBitSize, baKey, baPad, Pos:=-(lIdx = 0) * lHashSize)
Call CopyMemory(baPad(0), baHash(0), lHashSize)
lRemaining = OutSize - lIdx * lHashSize
If lRemaining > lHashSize Then
lRemaining = lHashSize
End If
Call CopyMemory(baRetVal(lIdx * lHashSize), baHash(0), lRemaining)
Next
CryptoHkdfSha2ByteArray = baRetVal
End Function
Public Function CryptoHkdfSha2Text(ByVal lBitSize As Long, sIKM As String, sSalt As String, sInfo As String, Optional ByVal OutSize As Long) As String
CryptoHkdfSha2Text = ToHex(CryptoHkdfSha2ByteArray(lBitSize, ToUtf8Array(sIKM), ToUtf8Array(sSalt), ToUtf8Array(sInfo), OutSize:=OutSize))
End Function
Raw
mdSha512.bas
'--- mdSha512.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 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
#If Not HasOperators Then
Private LNG_POW2(0 To 63) As LongLong
Private LNG_SIGN_BIT As LongLong ' 2 ^ 63
#End If
Private LNG_K(0 To LNG_ROUNDS - 1) As LongLong
#Else
Private LNG_POW2(0 To 63) As Variant
Private LNG_SIGN_BIT As Variant
Private LNG_K(0 To LNG_ROUNDS - 1) As Variant
#End If
#If Not HasOperators Then
#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_SIGN_BIT)) \ 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_SIGN_BIT)
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_SIGN_BIT
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_SIGN_BIT)) \ 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_SIGN_BIT) + lY) Xor LNG_SIGN_BIT
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 lZ)) Xor 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 Or lZ)) Or (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
#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
#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))
#If HasOperators Then
Const LNG_POW2_31 As LongLong = 2 ^ 31
BSwap64 = lA And &H7FFFFFFF Or -((lA < 0) <> 0) * LNG_POW2_31 Or -((lX And LNG_POW2_31) <> 0) * &H80
#Else
BSwap64 = lA And &H7FFFFFFF Or -((lA < 0) <> 0) * LNG_POW2(31) Or -((lX And LNG_POW2(31)) <> 0) * &H80
#End If
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
#If Not HasOperators Then
LNG_POW2(0) = CLngLng(1)
For lIdx = 1 To 63
LNG_POW2(lIdx) = CVar(LNG_POW2(lIdx - 1)) * 2
Next
LNG_SIGN_BIT = LNG_POW2(63)
#End If
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
Dim lX As LongLong
Dim lSigma1 As LongLong
Dim lSigma0 As LongLong
Dim lCh As LongLong
Dim lMaj 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 And Size > 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
#If HasOperators Then
W(lIdx) = BSwap64(CLngLng(B(lIdx * 2 + 1))) Or (BSwap64(CLngLng(B(lIdx * 2))) << 32)
#Else
W(lIdx) = BSwap64(CLngLng(B(lIdx * 2 + 1))) Or LShift64(BSwap64(CLngLng(B(lIdx * 2))), 32)
#End If
Else
#If HasOperators Then
lX = W(lIdx - 2): lSigma1 = (lX >> 19 Or lX << 45) Xor (lX >> 61 Or lX << 3) Xor (lX >> 6)
lX = W(lIdx - 15): lSigma0 = (lX >> 1 Or lX << 63) Xor (lX >> 8 Or lX << 56) Xor (lX >> 7)
W(lIdx) = lSigma1 + W(lIdx - 7) + lSigma0 + W(lIdx - 16)
#Else
W(lIdx) = UAdd64(UAdd64(UAdd64(SmallSigma1(W(lIdx - 2)), W(lIdx - 7)), SmallSigma0(W(lIdx - 15))), W(lIdx - 16))
#End If
End If
#If HasOperators Then
lSigma1 = (lE >> 14 Or lE << 50) Xor (lE >> 18 Or lE << 46) Xor (lE >> 41 Or lE << 23)
lSigma0 = (lA >> 28 Or lA << 36) Xor (lA >> 34 Or lA << 30) Xor (lA >> 39 Or lA << 25)
lCh = (lE And (lF Xor lG)) Xor lG
lMaj = (lA And (lB Or lC)) Or (lB And lC)
lT1 = lH + lSigma1 + lCh + LNG_K(lIdx) + W(lIdx)
lT2 = lSigma0 + lMaj
#Else
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))
#End If
lH = lG
lG = lF
lF = lE
#If HasOperators Then
lE = lD + lT1
#Else
lE = UAdd64(lD, lT1)
#End If
lD = lC
lC = lB
lB = lA
#If HasOperators Then
lA = lT1 + lT2
#Else
lA = UAdd64(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 = 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)
#End If
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
#If HasOperators Then
Const LNG_POW2_31 As LongLong = 2 ^ 31
lA = BSwap64(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
#Else
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 If
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
Raw
mdSha512Sliced.bas
'--- 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment