Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/mdBlake2b.bas

Last active November 18, 2022 08:57
Star
Embed
What would you like to do?
Learn more about clone URLs
Download ZIP
[VB6/VBA] BLAKE2 and BLAKE3 hash functions and MAC
Raw
mdBlake2b.bas
'--- mdBlake2b.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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
Private Declare PtrSafe Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, Src As Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) 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 = 128
Private Const LNG_ROUNDS As Long = 12
Public Type CryptoBlake2bContext
#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
OutSize As Long
End Type
#If HasPtrSafe Then
Private LNG_ZERO As LongLong
Private LNG_IV(0 To 7) As LongLong
#Else
Private LNG_ZERO As Variant
Private LNG_IV(0 To 7) As Variant
#End If
Private LNG_SIGMA(0 To 15, 0 To LNG_ROUNDS - 1) As Long
#If Not HasOperators Then
#If HasPtrSafe Then
Private LNG_POW2(0 To 63) As LongLong
Private LNG_SIGN_BIT As LongLong ' 2 ^ 63
#Else
Private LNG_POW2(0 To 63) As Variant
Private LNG_SIGN_BIT 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_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 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 Sub pvQuarter64(lA As LongLong, lB As LongLong, lC As LongLong, lD As LongLong, ByVal lX As LongLong, ByVal lY As LongLong)
#Else
Private Sub pvQuarter64(lA As Variant, lB As Variant, lC As Variant, lD As Variant, ByVal lX As Variant, ByVal lY As Variant)
#End If
lA = UAdd64(UAdd64(lA, lB), lX)
lD = RotR64(lD Xor lA, 32)
lC = UAdd64(lC, lD)
lB = RotR64(lB Xor lC, 24)
lA = UAdd64(UAdd64(lA, lB), lY)
lD = RotR64(lD Xor lA, 16)
lC = UAdd64(lC, lD)
lB = RotR64(lB Xor lC, 63)
End Sub
#Else
[ IntegerOverflowChecks (False) ]
Private Sub pvQuarter64(lA As LongLong, lB As LongLong, lC As LongLong, lD As LongLong, ByVal lX As LongLong, ByVal lY As LongLong)
lA = lA + lB + lX
lD = (lD Xor lA) >> 32 Or (lD Xor lA) << 32
lC = lC + lD
lB = (lB Xor lC) >> 24 or (lB Xor lC) << 40
lA = lA + lB + lY
lD = (lD Xor lA) >> 16 or (lD Xor lA) << 48
lC = lC + lD
lB = (lB Xor lC) >> 63 or (lB Xor lC) << 1
End Sub
#End If
#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
Private Sub pvCompress(uCtx As CryptoBlake2bContext, Optional ByVal IsLast As Boolean)
#If HasPtrSafe Then
Static B(0 To 15) As LongLong
Dim V0 As LongLong
Dim V1 As LongLong
Dim V2 As LongLong
Dim V3 As LongLong
Dim V4 As LongLong
Dim V5 As LongLong
Dim V6 As LongLong
Dim V7 As LongLong
Dim V8 As LongLong
Dim V9 As LongLong
Dim V10 As LongLong
Dim V11 As LongLong
Dim V12 As LongLong
Dim V13 As LongLong
Dim V14 As LongLong
Dim V15 As LongLong
Dim S0 As LongLong
#Else
Static B(0 To 15) As Variant
Dim V0 As Variant
Dim V1 As Variant
Dim V2 As Variant
Dim V3 As Variant
Dim V4 As Variant
Dim V5 As Variant
Dim V6 As Variant
Dim V7 As Variant
Dim V8 As Variant
Dim V9 As Variant
Dim V10 As Variant
Dim V11 As Variant
Dim V12 As Variant
Dim V13 As Variant
Dim V14 As Variant
Dim V15 As Variant
Dim S0 As Variant
#End If
Dim cTemp As Currency
Dim lIdx As Long
With uCtx
If .NPartial < LNG_BLOCKSZ Then
Call FillMemory(.Partial(.NPartial), LNG_BLOCKSZ - .NPartial, 0)
End If
#If HasPtrSafe Then
Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
#Else
For lIdx = 0 To UBound(B)
B(lIdx) = LNG_ZERO
Call CopyMemory(ByVal VarPtr(B(lIdx)) + 8, .Partial(8 * lIdx), 8)
Next
#End If
V0 = .H0: V1 = .H1
V2 = .H2: V3 = .H3
V4 = .H4: V5 = .H5
V6 = .H6: V7 = .H7
V8 = LNG_IV(0): V9 = LNG_IV(1)
V10 = LNG_IV(2): V11 = LNG_IV(3)
V12 = LNG_IV(4): V13 = LNG_IV(5)
V14 = LNG_IV(6): V15 = LNG_IV(7)
.NInput = .NInput + .NPartial
.NPartial = 0
cTemp = .NInput / 10000@
#If HasPtrSafe Then
Call CopyMemory(S0, cTemp, 8)
#Else
S0 = LNG_ZERO
Call CopyMemory(ByVal VarPtr(S0) + 8, cTemp, 8)
#End If
V12 = V12 Xor S0
If IsLast Then
V14 = Not V14
End If
For lIdx = 0 To LNG_ROUNDS - 1
pvQuarter64 V0, V4, V8, V12, B(LNG_SIGMA(0, lIdx)), B(LNG_SIGMA(1, lIdx))
pvQuarter64 V1, V5, V9, V13, B(LNG_SIGMA(2, lIdx)), B(LNG_SIGMA(3, lIdx))
pvQuarter64 V2, V6, V10, V14, B(LNG_SIGMA(4, lIdx)), B(LNG_SIGMA(5, lIdx))
pvQuarter64 V3, V7, V11, V15, B(LNG_SIGMA(6, lIdx)), B(LNG_SIGMA(7, lIdx))
pvQuarter64 V0, V5, V10, V15, B(LNG_SIGMA(8, lIdx)), B(LNG_SIGMA(9, lIdx))
pvQuarter64 V1, V6, V11, V12, B(LNG_SIGMA(10, lIdx)), B(LNG_SIGMA(11, lIdx))
pvQuarter64 V2, V7, V8, V13, B(LNG_SIGMA(12, lIdx)), B(LNG_SIGMA(13, lIdx))
pvQuarter64 V3, V4, V9, V14, B(LNG_SIGMA(14, lIdx)), B(LNG_SIGMA(15, lIdx))
Next
.H0 = .H0 Xor V0 Xor V8
.H1 = .H1 Xor V1 Xor V9
.H2 = .H2 Xor V2 Xor V10
.H3 = .H3 Xor V3 Xor V11
.H4 = .H4 Xor V4 Xor V12
.H5 = .H5 Xor V5 Xor V13
.H6 = .H6 Xor V6 Xor V14
.H7 = .H7 Xor V7 Xor V15
End With
End Sub
Public Sub CryptoBlake2bInit(uCtx As CryptoBlake2bContext, ByVal lBitSize As Long, Optional Key As Variant)
Dim vElem As Variant
Dim lIdx As Long
Dim baKey() As Byte
Dim lKeySize As Long
If LNG_IV(0) = 0 Then
LNG_ZERO = CLngLng(0)
For Each vElem In Split("6A09E667F3BCC908 BB67AE8584CAA73B 3C6EF372FE94F82B A54FF53A5F1D36F1 510E527FADE682D1 9B05688C2B3E6C1F 1F83D9ABFB41BD6B 5BE0CD19137E2179")
LNG_IV(lIdx) = CLngLng(CStr("&H" & vElem))
lIdx = lIdx + 1
Next
lIdx = 0
For Each vElem In Split("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 " & _
"14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 " & _
"11 8 12 0 5 2 15 13 10 14 3 6 7 1 9 4 " & _
"7 9 3 1 13 12 11 14 2 6 5 10 4 0 15 8 " & _
"9 0 5 7 2 4 10 15 14 1 11 12 6 8 3 13 " & _
"2 12 6 10 0 11 8 3 4 13 7 5 15 14 1 9 " & _
"12 5 1 15 14 13 4 10 0 7 6 3 9 2 8 11 " & _
"13 11 7 14 12 1 3 9 5 0 15 4 8 6 2 10 " & _
"6 15 14 9 11 3 0 8 12 2 13 7 1 4 10 5 " & _
"10 2 8 4 7 6 1 5 15 11 9 14 3 12 13 0")
LNG_SIGMA(lIdx And 15, lIdx \ 16) = vElem
lIdx = lIdx + 1
Next
'--- copy rows 10 & 11 from rows 0 & 1
Call CopyMemory(LNG_SIGMA(0, 10), LNG_SIGMA(0, 0), 2 * 64)
#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
If lBitSize <= 0 Or lBitSize > 512 Or (lBitSize And 7) <> 0 Then
Err.Raise vbObjectError, , "Invalid bit-size for BLAKE2b (" & lBitSize & ")"
End If
If Not IsMissing(Key) Then
If IsArray(Key) Then
baKey = Key
Else
baKey = ToUtf8Array(CStr(Key))
End If
lKeySize = UBound(baKey) + 1
End If
If lKeySize > 64 Then
Err.Raise vbObjectError, , "Key for BLAKE2b-MAC must be up to 64 bytes (" & lKeySize & ")"
End If
With uCtx
#If HasPtrSafe Then
Call CopyMemory(.H0, LNG_IV(0), 8 * 8)
#Else
Call CopyMemory(.H0, LNG_IV(0), 8 * 16)
#End If
.OutSize = lBitSize \ 8
.H0 = .H0 Xor &H1010000 Xor (lKeySize * &H100) Xor .OutSize
.NPartial = 0
.NInput = 0
If lKeySize > 0 Then
Call CopyMemory(.Partial(0), baKey(0), lKeySize)
Call FillMemory(.Partial(lKeySize), LNG_BLOCKSZ - lKeySize, 0)
.NPartial = LNG_BLOCKSZ
End If
End With
End Sub
Public Sub CryptoBlake2bUpdate(uCtx As CryptoBlake2bContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim lIdx As Long
With uCtx
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
If .NPartial > 0 And .NPartial < LNG_BLOCKSZ 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
If .NPartial <> 0 Then
'--- do nothing
ElseIf Size >= LNG_BLOCKSZ Then
Call CopyMemory(.Partial(0), baInput(Pos), LNG_BLOCKSZ)
.NPartial = LNG_BLOCKSZ
Pos = Pos + LNG_BLOCKSZ
Size = Size - LNG_BLOCKSZ
Else
Call CopyMemory(.Partial(0), baInput(Pos), Size)
.NPartial = Size
Exit Do
End If
pvCompress uCtx
Loop
End With
End Sub
Public Sub CryptoBlake2bFinalize(uCtx As CryptoBlake2bContext, baOutput() As Byte)
With uCtx
pvCompress uCtx, IsLast:=True
ReDim baOutput(0 To .OutSize - 1) As Byte
#If HasPtrSafe Then
Call CopyMemory(baOutput(0), .H0, .OutSize)
#Else
Call CopyMemory(.Partial(0), ByVal VarPtr(.H0) + 8, 8)
Call CopyMemory(.Partial(8), ByVal VarPtr(.H1) + 8, 8)
Call CopyMemory(.Partial(16), ByVal VarPtr(.H2) + 8, 8)
Call CopyMemory(.Partial(24), ByVal VarPtr(.H3) + 8, 8)
If .OutSize > 32 Then
Call CopyMemory(.Partial(32), ByVal VarPtr(.H4) + 8, 8)
Call CopyMemory(.Partial(40), ByVal VarPtr(.H5) + 8, 8)
Call CopyMemory(.Partial(48), ByVal VarPtr(.H6) + 8, 8)
Call CopyMemory(.Partial(56), ByVal VarPtr(.H7) + 8, 8)
End If
Call CopyMemory(baOutput(0), .Partial(0), .OutSize)
#End If
End With
Call FillMemory(uCtx, LenB(uCtx), 0)
End Sub
Public Function CryptoBlake2bByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant) As Byte()
Dim uCtx As CryptoBlake2bContext
CryptoBlake2bInit uCtx, lBitSize, Key:=Key
CryptoBlake2bUpdate uCtx, baInput, Pos, Size
CryptoBlake2bFinalize uCtx, CryptoBlake2bByteArray
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 CryptoBlake2bText(ByVal lBitSize As Long, sText As String, Optional Key As Variant) As String
CryptoBlake2bText = ToHex(CryptoBlake2bByteArray(lBitSize, ToUtf8Array(sText), Key:=Key))
End Function
Raw
mdBlake2s.bas
'--- mdBlake2s.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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
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 = 10
Public Type CryptoBlake2sContext
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
OutSize As Long
End Type
Private LNG_IV(0 To 7) As Long
Private LNG_SIGMA(0 To 15, 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 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 Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
lA = UAdd32(UAdd32(lA, lB), lX)
lD = RotR32(lD Xor lA, 16)
lC = UAdd32(lC, lD)
lB = RotR32(lB Xor lC, 12)
lA = UAdd32(UAdd32(lA, lB), lY)
lD = RotR32(lD Xor lA, 8)
lC = UAdd32(lC, lD)
lB = RotR32(lB Xor lC, 7)
End Sub
#Else
[ IntegerOverflowChecks (False) ]
Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
lA = lA + lB + lX
lD = (lD Xor lA) >> 16 Or (lD Xor lA) << 16
lC = lC + lD
lB = (lB Xor lC) >> 12 or (lB Xor lC) << 20
lA = lA + lB + lY
lD = (lD Xor lA) >> 8 or (lD Xor lA) << 24
lC = lC + lD
lB = (lB Xor lC) >> 7 or (lB Xor lC) << 25
End Sub
#End If
Private Sub pvCompress(uCtx As CryptoBlake2sContext, Optional ByVal IsLast As Boolean)
Static B(0 To 15) As Long
Static S(0 To 1) As Long
Dim V0 As Long
Dim V1 As Long
Dim V2 As Long
Dim V3 As Long
Dim V4 As Long
Dim V5 As Long
Dim V6 As Long
Dim V7 As Long
Dim V8 As Long
Dim V9 As Long
Dim V10 As Long
Dim V11 As Long
Dim V12 As Long
Dim V13 As Long
Dim V14 As Long
Dim V15 As Long
Dim cTemp As Currency
Dim lIdx As Long
With uCtx
If .NPartial < LNG_BLOCKSZ Then
Call FillMemory(.Partial(.NPartial), LNG_BLOCKSZ - .NPartial, 0)
End If
Call CopyMemory(B(0), .Partial(0), LNG_BLOCKSZ)
V0 = .H0: V1 = .H1
V2 = .H2: V3 = .H3
V4 = .H4: V5 = .H5
V6 = .H6: V7 = .H7
V8 = LNG_IV(0): V9 = LNG_IV(1)
V10 = LNG_IV(2): V11 = LNG_IV(3)
V12 = LNG_IV(4): V13 = LNG_IV(5)
V14 = LNG_IV(6): V15 = LNG_IV(7)
.NInput = .NInput + .NPartial
.NPartial = 0
cTemp = .NInput / 10000@
Call CopyMemory(S(0), cTemp, 8)
V12 = V12 Xor S(0)
V13 = V13 Xor S(1)
If IsLast Then
V14 = Not V14
End If
For lIdx = 0 To LNG_ROUNDS - 1
pvQuarter32 V0, V4, V8, V12, B(LNG_SIGMA(0, lIdx)), B(LNG_SIGMA(1, lIdx))
pvQuarter32 V1, V5, V9, V13, B(LNG_SIGMA(2, lIdx)), B(LNG_SIGMA(3, lIdx))
pvQuarter32 V2, V6, V10, V14, B(LNG_SIGMA(4, lIdx)), B(LNG_SIGMA(5, lIdx))
pvQuarter32 V3, V7, V11, V15, B(LNG_SIGMA(6, lIdx)), B(LNG_SIGMA(7, lIdx))
pvQuarter32 V0, V5, V10, V15, B(LNG_SIGMA(8, lIdx)), B(LNG_SIGMA(9, lIdx))
pvQuarter32 V1, V6, V11, V12, B(LNG_SIGMA(10, lIdx)), B(LNG_SIGMA(11, lIdx))
pvQuarter32 V2, V7, V8, V13, B(LNG_SIGMA(12, lIdx)), B(LNG_SIGMA(13, lIdx))
pvQuarter32 V3, V4, V9, V14, B(LNG_SIGMA(14, lIdx)), B(LNG_SIGMA(15, lIdx))
Next
.H0 = .H0 Xor V0 Xor V8
.H1 = .H1 Xor V1 Xor V9
.H2 = .H2 Xor V2 Xor V10
.H3 = .H3 Xor V3 Xor V11
.H4 = .H4 Xor V4 Xor V12
.H5 = .H5 Xor V5 Xor V13
.H6 = .H6 Xor V6 Xor V14
.H7 = .H7 Xor V7 Xor V15
End With
End Sub
Public Sub CryptoBlake2sInit(uCtx As CryptoBlake2sContext, ByVal lBitSize As Long, Optional Key As Variant)
Dim vElem As Variant
Dim lIdx As Long
Dim baKey() As Byte
Dim lKeySize As Long
If LNG_IV(0) = 0 Then
For Each vElem In Split("6A09E667 BB67AE85 3C6EF372 A54FF53A 510E527F 9B05688C 1F83D9AB 5BE0CD19")
LNG_IV(lIdx) = "&H" & vElem
lIdx = lIdx + 1
Next
lIdx = 0
For Each vElem In Split("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 " & _
"14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 " & _
"11 8 12 0 5 2 15 13 10 14 3 6 7 1 9 4 " & _
"7 9 3 1 13 12 11 14 2 6 5 10 4 0 15 8 " & _
"9 0 5 7 2 4 10 15 14 1 11 12 6 8 3 13 " & _
"2 12 6 10 0 11 8 3 4 13 7 5 15 14 1 9 " & _
"12 5 1 15 14 13 4 10 0 7 6 3 9 2 8 11 " & _
"13 11 7 14 12 1 3 9 5 0 15 4 8 6 2 10 " & _
"6 15 14 9 11 3 0 8 12 2 13 7 1 4 10 5 " & _
"10 2 8 4 7 6 1 5 15 11 9 14 3 12 13 0")
LNG_SIGMA(lIdx And 15, lIdx \ 16) = 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
If lBitSize <= 0 Or lBitSize > 256 Or (lBitSize And 7) <> 0 Then
Err.Raise vbObjectError, , "Invalid bit-size for BLAKE2s (" & lBitSize & ")"
End If
If Not IsMissing(Key) Then
If IsArray(Key) Then
baKey = Key
Else
baKey = ToUtf8Array(CStr(Key))
End If
lKeySize = UBound(baKey) + 1
End If
If lKeySize > 32 Then
Err.Raise vbObjectError, , "Key for BLAKE2s-MAC must be up to 32 bytes (" & lKeySize & ")"
End If
With uCtx
Call CopyMemory(.H0, LNG_IV(0), 8 * 4)
.OutSize = lBitSize \ 8
.H0 = .H0 Xor &H1010000 Xor (lKeySize * &H100) Xor .OutSize
.NPartial = 0
.NInput = 0
If lKeySize > 0 Then
Call CopyMemory(.Partial(0), baKey(0), lKeySize)
Call FillMemory(.Partial(lKeySize), LNG_BLOCKSZ - lKeySize, 0)
.NPartial = LNG_BLOCKSZ
End If
End With
End Sub
Public Sub CryptoBlake2sUpdate(uCtx As CryptoBlake2sContext, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim lIdx As Long
With uCtx
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
If .NPartial > 0 And .NPartial < LNG_BLOCKSZ 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
If .NPartial <> 0 Then
'--- do nothng
ElseIf Size >= LNG_BLOCKSZ Then
Call CopyMemory(.Partial(0), baInput(Pos), LNG_BLOCKSZ)
.NPartial = LNG_BLOCKSZ
Pos = Pos + LNG_BLOCKSZ
Size = Size - LNG_BLOCKSZ
Else
Call CopyMemory(.Partial(0), baInput(Pos), Size)
.NPartial = Size
Exit Do
End If
pvCompress uCtx
Loop
End With
End Sub
Public Sub CryptoBlake2sFinalize(uCtx As CryptoBlake2sContext, baOutput() As Byte)
With uCtx
pvCompress uCtx, IsLast:=True
ReDim baOutput(0 To .OutSize - 1) As Byte
Call CopyMemory(baOutput(0), .H0, .OutSize)
End With
Call FillMemory(uCtx, LenB(uCtx), 0)
End Sub
Public Function CryptoBlake2sByteArray(ByVal lBitSize As Long, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant) As Byte()
Dim uCtx As CryptoBlake2sContext
CryptoBlake2sInit uCtx, lBitSize, Key:=Key
CryptoBlake2sUpdate uCtx, baInput, Pos, Size
CryptoBlake2sFinalize uCtx, CryptoBlake2sByteArray
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 CryptoBlake2sText(ByVal lBitSize As Long, sText As String, Optional Key As Variant) As String
CryptoBlake2sText = ToHex(CryptoBlake2sByteArray(lBitSize, ToUtf8Array(sText), Key:=Key))
End Function
Raw
mdBlake3.bas
'--- mdBlake3.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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte)
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 Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
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_OUT_LEN As Long = 32
Private Const LNG_KEY_LEN As Long = 32
Private Const LNG_BLOCK_LEN As Long = 64
Private Const LNG_CHUNK_LEN As Long = 1024
Private Type ArrayLong8
Item(0 To 7) As Long
End Type
Private Type ArrayLong16
Item(0 To 15) As Long
End Type
Private Enum Blake3Flags
LNG_CHUNK_START = 2 ^ 0
LNG_CHUNK_END = 2 ^ 1
LNG_PARENT = 2 ^ 2
LNG_ROOT = 2 ^ 3
LNG_KEYED_HASH = 2 ^ 4
LNG_DERIVE_KEY_CONTEXT = 2 ^ 5
LNG_DERIVE_KEY_MATERIAL = 2 ^ 6
End Enum
Private Type Blake3ChunkState
ChainingValue As ArrayLong8
ChunkCounter As Long
Block(0 To LNG_BLOCK_LEN - 1) As Byte
BlockLen As Byte
BlocksCompressed As Byte
Flags As Blake3Flags
End Type
Private Type Blake3Output
InputChainingValue As ArrayLong8
BlockWords As ArrayLong16
Counter As Currency
BlockLen As Byte
Flags As Blake3Flags
End Type
Public Type CryptoBlake3Context
ChunkState As Blake3ChunkState
KeyWords As ArrayLong8
CvStack(0 To 53) As ArrayLong8
CvStackLen As Byte
Flags As Blake3Flags
End Type
Private LNG_IV As ArrayLong8
#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 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 Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
lA = UAdd32(UAdd32(lA, lB), lX)
lD = RotR32(lD Xor lA, 16)
lC = UAdd32(lC, lD)
lB = RotR32(lB Xor lC, 12)
lA = UAdd32(UAdd32(lA, lB), lY)
lD = RotR32(lD Xor lA, 8)
lC = UAdd32(lC, lD)
lB = RotR32(lB Xor lC, 7)
End Sub
#Else
[ IntegerOverflowChecks (False) ]
Private Sub pvQuarter32(lA As Long, lB As Long, lC As Long, lD As Long, ByVal lX As Long, ByVal lY As Long)
lA = lA + lB + lX
lD = (lD Xor lA) >> 16 Or (lD Xor lA) << 16
lC = lC + lD
lB = (lB Xor lC) >> 12 Or (lB Xor lC) << 20
lA = lA + lB + lY
lD = (lD Xor lA) >> 8 Or (lD Xor lA) << 24
lC = lC + lD
lB = (lB Xor lC) >> 7 Or (lB Xor lC) << 25
End Sub
#End If
Private Sub pvCompress(uState As ArrayLong8, uBlock As ArrayLong16, ByVal cCounter As Currency, ByVal lBlockLen As Long, ByVal eFlags As Blake3Flags, uRetVal As ArrayLong16, Optional ByVal HalfOnly As Boolean)
Static S(0 To 1) As Long
Dim V0 As Long
Dim V1 As Long
Dim V2 As Long
Dim V3 As Long
Dim V4 As Long
Dim V5 As Long
Dim V6 As Long
Dim V7 As Long
Dim V8 As Long
Dim V9 As Long
Dim V10 As Long
Dim V11 As Long
Dim V12 As Long
Dim V13 As Long
Dim V14 As Long
Dim V15 As Long
With uState
V0 = .Item(0): V1 = .Item(1)
V2 = .Item(2): V3 = .Item(3)
V4 = .Item(4): V5 = .Item(5)
V6 = .Item(6): V7 = .Item(7)
End With
With LNG_IV
V8 = .Item(0): V9 = .Item(1)
V10 = .Item(2): V11 = .Item(3)
End With
cCounter = cCounter / 10000@
Call CopyMemory(S(0), cCounter, 8)
V12 = S(0)
V13 = S(1)
V14 = lBlockLen
V15 = eFlags
With uBlock
'--- Round 1
pvQuarter32 V0, V4, V8, V12, .Item(0), .Item(1)
pvQuarter32 V1, V5, V9, V13, .Item(2), .Item(3)
pvQuarter32 V2, V6, V10, V14, .Item(4), .Item(5)
pvQuarter32 V3, V7, V11, V15, .Item(6), .Item(7)
pvQuarter32 V0, V5, V10, V15, .Item(8), .Item(9)
pvQuarter32 V1, V6, V11, V12, .Item(10), .Item(11)
pvQuarter32 V2, V7, V8, V13, .Item(12), .Item(13)
pvQuarter32 V3, V4, V9, V14, .Item(14), .Item(15)
'--- Round 2
pvQuarter32 V0, V4, V8, V12, .Item(2), .Item(6)
pvQuarter32 V1, V5, V9, V13, .Item(3), .Item(10)
pvQuarter32 V2, V6, V10, V14, .Item(7), .Item(0)
pvQuarter32 V3, V7, V11, V15, .Item(4), .Item(13)
pvQuarter32 V0, V5, V10, V15, .Item(1), .Item(11)
pvQuarter32 V1, V6, V11, V12, .Item(12), .Item(5)
pvQuarter32 V2, V7, V8, V13, .Item(9), .Item(14)
pvQuarter32 V3, V4, V9, V14, .Item(15), .Item(8)
'--- Round 3
pvQuarter32 V0, V4, V8, V12, .Item(3), .Item(4)
pvQuarter32 V1, V5, V9, V13, .Item(10), .Item(12)
pvQuarter32 V2, V6, V10, V14, .Item(13), .Item(2)
pvQuarter32 V3, V7, V11, V15, .Item(7), .Item(14)
pvQuarter32 V0, V5, V10, V15, .Item(6), .Item(5)
pvQuarter32 V1, V6, V11, V12, .Item(9), .Item(0)
pvQuarter32 V2, V7, V8, V13, .Item(11), .Item(15)
pvQuarter32 V3, V4, V9, V14, .Item(8), .Item(1)
'--- Round 4
pvQuarter32 V0, V4, V8, V12, .Item(10), .Item(7)
pvQuarter32 V1, V5, V9, V13, .Item(12), .Item(9)
pvQuarter32 V2, V6, V10, V14, .Item(14), .Item(3)
pvQuarter32 V3, V7, V11, V15, .Item(13), .Item(15)
pvQuarter32 V0, V5, V10, V15, .Item(4), .Item(0)
pvQuarter32 V1, V6, V11, V12, .Item(11), .Item(2)
pvQuarter32 V2, V7, V8, V13, .Item(5), .Item(8)
pvQuarter32 V3, V4, V9, V14, .Item(1), .Item(6)
'--- Round 5
pvQuarter32 V0, V4, V8, V12, .Item(12), .Item(13)
pvQuarter32 V1, V5, V9, V13, .Item(9), .Item(11)
pvQuarter32 V2, V6, V10, V14, .Item(15), .Item(10)
pvQuarter32 V3, V7, V11, V15, .Item(14), .Item(8)
pvQuarter32 V0, V5, V10, V15, .Item(7), .Item(2)
pvQuarter32 V1, V6, V11, V12, .Item(5), .Item(3)
pvQuarter32 V2, V7, V8, V13, .Item(0), .Item(1)
pvQuarter32 V3, V4, V9, V14, .Item(6), .Item(4)
'--- Round 6
pvQuarter32 V0, V4, V8, V12, .Item(9), .Item(14)
pvQuarter32 V1, V5, V9, V13, .Item(11), .Item(5)
pvQuarter32 V2, V6, V10, V14, .Item(8), .Item(12)
pvQuarter32 V3, V7, V11, V15, .Item(15), .Item(1)
pvQuarter32 V0, V5, V10, V15, .Item(13), .Item(3)
pvQuarter32 V1, V6, V11, V12, .Item(0), .Item(10)
pvQuarter32 V2, V7, V8, V13, .Item(2), .Item(6)
pvQuarter32 V3, V4, V9, V14, .Item(4), .Item(7)
'--- Round 7
pvQuarter32 V0, V4, V8, V12, .Item(11), .Item(15)
pvQuarter32 V1, V5, V9, V13, .Item(5), .Item(0)
pvQuarter32 V2, V6, V10, V14, .Item(1), .Item(9)
pvQuarter32 V3, V7, V11, V15, .Item(8), .Item(6)
pvQuarter32 V0, V5, V10, V15, .Item(14), .Item(10)
pvQuarter32 V1, V6, V11, V12, .Item(2), .Item(12)
pvQuarter32 V2, V7, V8, V13, .Item(3), .Item(4)
pvQuarter32 V3, V4, V9, V14, .Item(7), .Item(13)
End With
With uRetVal
.Item(0) = V0 Xor V8: .Item(1) = V1 Xor V9
.Item(2) = V2 Xor V10: .Item(3) = V3 Xor V11
.Item(4) = V4 Xor V12: .Item(5) = V5 Xor V13
.Item(6) = V6 Xor V14: .Item(7) = V7 Xor V15
If Not HalfOnly Then
.Item(8) = V8 Xor uState.Item(0)
.Item(9) = V9 Xor uState.Item(1)
.Item(10) = V10 Xor uState.Item(2)
.Item(11) = V11 Xor uState.Item(3)
.Item(12) = V12 Xor uState.Item(4)
.Item(13) = V13 Xor uState.Item(5)
.Item(14) = V14 Xor uState.Item(6)
.Item(15) = V15 Xor uState.Item(7)
End If
End With
End Sub
Private Sub pvUpdateChunk(uChunk As Blake3ChunkState, baInput() As Byte, ByVal lPos As Long, ByVal lSize As Long)
Dim eStartFlag As Blake3Flags
Dim lRemaining As Long
With uChunk
Do While lSize > 0
If .BlockLen = LNG_BLOCK_LEN Then
eStartFlag = -(.BlocksCompressed = 0) * LNG_CHUNK_START
#If HasOperators Then
pvCompress .ChainingValue, VarPtr(.Block(0)), .ChunkCounter, .BlockLen, .Flags Or eStartFlag, VarPtr(.ChainingValue), HalfOnly:=True
#Else
Static uTemp As ArrayLong16
Call CopyMemory(uTemp, .Block(0), LNG_BLOCK_LEN)
pvCompress .ChainingValue, uTemp, .ChunkCounter, .BlockLen, .Flags Or eStartFlag, uTemp
Call CopyMemory(.ChainingValue, uTemp, LNG_BLOCK_LEN \ 2)
#End If
.BlocksCompressed = .BlocksCompressed + 1
.BlockLen = 0
End If
lRemaining = LNG_BLOCK_LEN - .BlockLen
If lRemaining > lSize Then
lRemaining = lSize
End If
Call CopyMemory(.Block(.BlockLen), baInput(lPos), lRemaining)
.BlockLen = .BlockLen + lRemaining
lPos = lPos + lRemaining
lSize = lSize - lRemaining
Loop
End With
End Sub
Private Sub pvGetChunkOutput(uChunk As Blake3ChunkState, uOutput As Blake3Output)
Dim eStartFlag As Blake3Flags
With uChunk
uOutput.InputChainingValue = .ChainingValue
If .BlockLen > 0 Then
Call CopyMemory(uOutput.BlockWords, .Block(0), .BlockLen)
End If
uOutput.Counter = .ChunkCounter
uOutput.BlockLen = .BlockLen
eStartFlag = -(.BlocksCompressed = 0) * LNG_CHUNK_START
uOutput.Flags = .Flags Or eStartFlag Or LNG_CHUNK_END
End With
End Sub
Private Function pvGetChunkLen(uChunk As Blake3ChunkState) As Long
With uChunk
pvGetChunkLen = .BlocksCompressed * LNG_BLOCK_LEN + .BlockLen
End With
End Function
Private Sub pvMakeParentOutput(uLeft As ArrayLong8, uRight As ArrayLong8, uKeyWords As ArrayLong8, ByVal eFlags As Blake3Flags, uOutput As Blake3Output)
With uOutput
.InputChainingValue = uKeyWords
Call CopyMemory(.BlockWords.Item(0), uLeft, LNG_BLOCK_LEN \ 2)
Call CopyMemory(.BlockWords.Item(8), uRight, LNG_BLOCK_LEN \ 2)
.Counter = 0
.BlockLen = LNG_BLOCK_LEN
.Flags = eFlags Or LNG_PARENT
End With
End Sub
Private Sub pvGetChainingValue(uOutput As Blake3Output, uRetVal As ArrayLong8)
With uOutput
#If HasOperators Then
pvCompress .InputChainingValue, .BlockWords, .Counter, .BlockLen, .Flags, VarPtr(uRetVal), HalfOnly:=True
#Else
Static uTemp As ArrayLong16
pvCompress .InputChainingValue, .BlockWords, .Counter, .BlockLen, .Flags, uTemp
Call CopyMemory(uRetVal, uTemp, LNG_BLOCK_LEN \ 2)
#End If
End With
End Sub
Private Sub pvGetRootBytes(uOutput As Blake3Output, baOutput() As Byte, ByVal lOutSize As Long)
Dim uTemp As ArrayLong16
Dim cCounter As Currency
Dim lPos As Long
Dim lRemaining As Long
With uOutput
ReDim baOutput(0 To lOutSize - 1) As Byte
Do While lPos < lOutSize
pvCompress .InputChainingValue, .BlockWords, cCounter, .BlockLen, .Flags Or LNG_ROOT, uTemp
lRemaining = lOutSize - lPos
If lRemaining > LNG_BLOCK_LEN Then
lRemaining = LNG_BLOCK_LEN
End If
Call CopyMemory(baOutput(lPos), uTemp, lRemaining)
lPos = lPos + lRemaining
cCounter = cCounter + 1
Loop
End With
End Sub
Private Sub pvInitHasher(uCtx As CryptoBlake3Context, ByVal lKeyPtr As LongPtr, Optional ByVal eFlags As Blake3Flags)
Call FillMemory(uCtx, LenB(uCtx), 0)
With uCtx
Call CopyMemory(.KeyWords, ByVal lKeyPtr, LNG_KEY_LEN)
.Flags = eFlags
.ChunkState.ChainingValue = .KeyWords
.ChunkState.Flags = .Flags
End With
End Sub
Public Sub CryptoBlake3Init(uCtx As CryptoBlake3Context, Optional Key As Variant, Optional Context As Variant)
Dim vElem As Variant
Dim lIdx As Long
Dim baKey() As Byte
Dim baContext() As Byte
If LNG_IV.Item(0) = 0 Then
For Each vElem In Split("6A09E667 BB67AE85 3C6EF372 A54FF53A 510E527F 9B05688C 1F83D9AB 5BE0CD19")
LNG_IV.Item(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
If Not IsMissing(Key) Then
If IsArray(Key) Then
baKey = Key
Else
baKey = ToUtf8Array(CStr(Key))
End If
ReDim Preserve baKey(0 To LNG_KEY_LEN - 1) As Byte
pvInitHasher uCtx, VarPtr(baKey(0)), LNG_KEYED_HASH
ElseIf Not IsMissing(Context) Then
If IsArray(Context) Then
baContext = Context
Else
baContext = ToUtf8Array(CStr(Context))
End If
pvInitHasher uCtx, VarPtr(LNG_IV), LNG_DERIVE_KEY_CONTEXT
CryptoBlake3Update uCtx, baContext
CryptoBlake3Finalize uCtx, baKey
pvInitHasher uCtx, VarPtr(baKey(0)), LNG_DERIVE_KEY_MATERIAL
Else
pvInitHasher uCtx, VarPtr(LNG_IV)
End If
End With
End Sub
Public Sub CryptoBlake3Update(uCtx As CryptoBlake3Context, baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1)
Dim uOutput As Blake3Output
Dim uRight As ArrayLong8
Dim lTotalChunks As Long
Dim lRemaining As Long
With uCtx
If Size < 0 Then
Size = UBound(baInput) + 1 - Pos
End If
Do While Size > 0
If pvGetChunkLen(.ChunkState) = LNG_CHUNK_LEN Then
pvGetChunkOutput .ChunkState, uOutput
pvGetChainingValue uOutput, uRight
lTotalChunks = .ChunkState.ChunkCounter + 1
Do While (lTotalChunks And 1) = 0
.CvStackLen = .CvStackLen - 1
pvMakeParentOutput .CvStack(.CvStackLen), uRight, .KeyWords, .Flags, uOutput
pvGetChainingValue uOutput, uRight
lTotalChunks = lTotalChunks \ 2
Loop
.CvStack(.CvStackLen) = uRight
.CvStackLen = .CvStackLen + 1
.ChunkState.ChainingValue = .KeyWords
.ChunkState.ChunkCounter = .ChunkState.ChunkCounter + 1
.ChunkState.BlockLen = 0
.ChunkState.BlocksCompressed = 0
.ChunkState.Flags = .Flags
End If
lRemaining = LNG_CHUNK_LEN - pvGetChunkLen(.ChunkState)
If lRemaining > Size Then
lRemaining = Size
End If
pvUpdateChunk .ChunkState, baInput, Pos, lRemaining
Pos = Pos + lRemaining
Size = Size - lRemaining
Loop
End With
End Sub
Public Sub CryptoBlake3Finalize(uCtx As CryptoBlake3Context, baOutput() As Byte, Optional ByVal OutSize As Long)
Dim uOutput As Blake3Output
Dim uRight As ArrayLong8
With uCtx
pvGetChunkOutput .ChunkState, uOutput
Do While .CvStackLen > 0
pvGetChainingValue uOutput, uRight
.CvStackLen = .CvStackLen - 1
pvMakeParentOutput .CvStack(.CvStackLen), uRight, .KeyWords, .Flags, uOutput
Loop
If OutSize <= 0 Then
OutSize = LNG_OUT_LEN
End If
pvGetRootBytes uOutput, baOutput, OutSize
End With
End Sub
Public Function CryptoBlake3ByteArray(baInput() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1, Optional Key As Variant, Optional Context As Variant, Optional OutSize As Long) As Byte()
Dim uCtx As CryptoBlake3Context
CryptoBlake3Init uCtx, Key:=Key, Context:=Context
CryptoBlake3Update uCtx, baInput, Pos, Size
CryptoBlake3Finalize uCtx, CryptoBlake3ByteArray, OutSize:=OutSize
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 CryptoBlake3Text(sText As String, Optional Key As Variant, Optional Context As Variant, Optional OutSize As Long) As String
CryptoBlake3Text = ToHex(CryptoBlake3ByteArray(ToUtf8Array(sText), Key:=Key, Context:=Context, OutSize:=OutSize))
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment