[原创]VB.NET 写的TEA加密算法和解密算法,可直接使用(注：使用的是VB.NET 2008)
1 '// 最近想了解一下QQ的协议,但第一就是解决TEA加密算法,在网上找了很久,
2 '//发现有很多的版本的,当然也有VB的,但不是VB.NET的.那些VB的已经不能直接用了.
3 '//而且现在VB.NET已经可以移位了.看了以前VB写的.为了移位就写了一个函数。
4 '//只有C#或C++的两行的核心算法VB却要几十行。找遍了网上也没发现有VB.NET做只能靠自己了。
5 '// TEA加密算我上面说过，其实就只有两行核心代码。但是QQ在使用这个算法的时候，
6 '//由于需要加密不定长的数据，所以使用了一些常规的填充办法和交织算法.所以更多是处理填充和交织。
7 '
8 '// 本人E-Mail: liwqbasic[AT]gamail.com ([AT]换成@) QQ: &H12C214E9 [0x12C214E9]
9 '
10 '
11
12 Namespace HashTEA
13 Public Class hashtea
14
15 Private Const delta As UInteger = &H9E3779B9L 'tea算法的delta值
16 Private Plain(7) As Byte '指向当前的明文块
17 Private prePlain(7) As Byte '指向前面一个明文块
18 Private out() As Byte
19 Private Crypt As UInteger
20 Private preCrypt As UInteger '当前加密的密文位置和上一次加密的密文块位置，他们相差8
21 Private Pos As Long '当前处理的加密解密块的位置
22 Private padding As Long '填充数
23 Private Key(15) As Byte '密钥
24 Private Header As Boolean '用于加密时，表示当前是否是第一个8字节块，因为加密算法
25 '是反馈的，但是最开始的8个字节没有反馈可用，所有需要标明这种情况
26 Private contextStart As Long
27
28 Public Function UnHashTEA(ByVal BinFrom As Byte(), ByVal BinTKey As Byte(), _
29 ByVal offset As Integer, ByVal Is16Rounds As Boolean) As Byte()
30
31 Crypt = 0
32 preCrypt = 0
33 Key = BinTKey
34 Dim count As Integer = 0
35 Dim m(offset + 7) As Byte
36 Dim intlen As Integer = BinFrom.Length
37
38 If intlen < 16 Or (intlen Mod 8 <> 0) Then ThrowMsg("Len No Enuf")
39
40 prePlain = Decipher(BinFrom, Key, True)
41 Pos = prePlain(0) And &H7
42 count = intlen - Pos - 10
43
44 If count < 0 Then ThrowMsg("Count No Enuf")
45
46 For i = offset To m.Length - 1
47 m(i) = 0
48 Next
49 ReDim out(count - 1)
50 preCrypt = 0
51 Crypt = 8
52 contextStart = 8
53 Pos += 1
54
55 padding = 1
56 While padding <= 2
57
58 If Pos < 8 Then
59 Pos += 1
60 padding += 1
61
62 End If
63 If Pos = 8 Then
64 m = BinFrom
65 If Not (Decrypt8Bytes(BinFrom, offset, intlen)) Then
66 ThrowMsg("Decrypt8Bytes() failed.")
67 End If
68 End If
69 End While
70
71 Dim i2 = 0
72 While count <> 0
73 If Pos < 8 Then
74 out(i2) = CByte(m(offset + preCrypt + Pos) Xor prePlain(Pos))
75 i2 += 1
76 count -= 1
77 Pos += 1
78 End If
79
80 If Pos = 8 Then
81 m = BinFrom
82 preCrypt = Crypt - 8
83 Decrypt8Bytes(BinFrom, offset, intlen)
84 End If
85
86 End While
87
88 For i = 1 To 7
89 If Pos < 8 Then
90 If (m(offset + preCrypt + Pos) Xor prePlain(Pos)) <> 0 Then
91 ThrowMsg("tail is not filled correct.")
92 End If
93 Pos += 1
94 If Pos = 8 Then
95 m = BinFrom
96 If Not (Decrypt8Bytes(BinFrom, offset, intlen)) Then
97 ThrowMsg("Decrypt8Bytes() failed.")
98 End If
99
100 End If
101 End If
102 Next
103
104 Return out
105
106 End Function
107
108 Private Function Decrypt8Bytes(ByVal input() As Byte, ByVal offset As Integer, _
109 ByVal intlen As Integer) As Boolean
110
111 For i = 0 To 7
112 If contextStart + i >= intlen Then
113 Return True
114 End If
115 prePlain(i) = prePlain(i) Xor input(offset + Crypt + i)
116
117 Next
118
119
120
121 prePlain = Decipher(prePlain, Key, True)
122 If prePlain Is Nothing Then
123 Return False
124
125 End If
126 contextStart += 8
127 Crypt += 8
128 Pos = 0
129
130 Return True
131 End Function
132
133 Private Function Decipher(ByVal BinInput() As Byte, _
134 ByVal Binkey() As Byte, ByVal Is16Rounds As Boolean) As Byte()
135 '标准tea解密过程,参数ltype 为1时表示16轮迭代(qq使用的就是16轮迭代),否则为32轮迭代
136
137 Dim sum As Long = &HE3779B90L
138 Dim rounds As Integer
139
140 Dim y As Long = GetUInt(BinInput, 0, 4)
141 Dim z As Long = GetUInt(BinInput, 4, 4)
142 Dim a As Long = GetUInt(Key, 0, 4)
143 Dim b As Long = GetUInt(Key, 4, 4)
144 Dim c As Long = GetUInt(Key, 8, 4)
145 Dim d As Long = GetUInt(Key, 12, 4)
146
147 If Is16Rounds Then
148 rounds = 16
149 Else
150 rounds = 32
151 End If
152 Dim Test As Long = 0
153 For i = 1 To rounds
154
155 Test = ((y << 4) + c) Xor (y + sum) Xor ((y >> 5) + d)
156 z -= Test
157 z = z And &HFFFFFFFFL
158
159 Test = ((z << 4) + a) Xor (z + sum) Xor ((z >> 5) + b)
160 y -= Test
161 y = y And &HFFFFFFFFL
162
163 sum -= delta
164 sum = sum And &HFFFFFFFFL
165
166 Next
167
168 Return ToBytes(y, z)
169 End Function
170
171 Public Function HashTEA(ByVal BinFrom As Byte(), ByVal BinTKey As Byte(), _
172 ByVal offset As Integer, ByVal Is16Rounds As Boolean) As Byte()
173
174 Header = True
175 Key = BinTKey
176 Pos = 1
177 padding = 0
178 Crypt = 0
179 preCrypt = 0
180 Dim intlen As Integer = BinFrom.Length
181 Dim xRnd As New Random
182 Pos = (intlen + 10) Mod 8
183
184 If Pos <> 0 Then Pos = 8 - Pos
185 ReDim out(intlen + Pos + 9)
186
187
188
189 Plain(0) = CByte((xRnd.Next And &HF8) Or Pos)
190
191 For i = 1 To Pos
192 Plain(i) = CByte(xRnd.Next And &HFF)
193 Next
194
195 For i = 0 To 7
196 prePlain(i) = CByte(&H0)
197 Next
198
199 Pos += 1
200 padding = 1
201 Do While padding < 3
202 If Pos < 8 Then
203 Plain(Pos) = CByte(xRnd.Next And &HFF)
204 Pos += 1
205 padding += 1
206
207 Else
208 Encrypt8Bytes(Is16Rounds)
209 End If
210 Loop
211
212 Dim i2 = offset
213 While intlen > 0
214 If Pos < 8 Then
215
216 Plain(Pos) = BinFrom(i2)
217 Pos += 1
218 intlen -= 1
219
220 i2 += 1
221 Else
222 Encrypt8Bytes(Is16Rounds)
223
224 End If
225 End While
226
227 padding = 1
228 While padding < 8
229 If Pos < 8 Then
230
231 Plain(Pos) = &H0
232 padding += 1
233 Pos += 1
234 End If
235
236 If Pos = 8 Then
237 Encrypt8Bytes(Is16Rounds)
238 End If
239 End While
240
241 Return out
242 End Function
243
244 Private Sub Encrypt8Bytes(ByVal Is16Rounds As Boolean)
245 Dim Crypted() As Byte
246 Pos = 0
247 For i = 0 To 7
248 If Header Then
249 Plain(i) = Plain(i) Xor prePlain(0)
250 Else
251 Plain(i) = Plain(i) Xor out(preCrypt + i)
252 End If
253 Next
254 Crypted = Encipher(Plain, Key, Is16Rounds)
255 Array.Copy(Crypted, 0, out, Crypt, 8)
256 For i = 0 To 7
257 out(Crypt + i) = out(Crypt + i) Xor prePlain(i)
258
259 Next
260 Array.Copy(Plain, 0, prePlain, 0, 8)
261 preCrypt = Crypt
262 Crypt += 8
263 Pos = 0
264 Header = False
265
266 End Sub
267
268 Private Function Encipher(ByVal BinInput() As Byte, ByVal k() As Byte, ByVal Is16Rounds As Boolean)
269 '标准的tea加密过程,参数 Is16Rounds 为True时表示16轮迭代(qq使用的就是16轮迭代),否则为32轮迭代
270
271 Dim sum As ULong
272
273 Dim rounds As Integer
274
275 Dim y As ULong = GetUInt(BinInput, 0, 4)
276 Dim z As ULong = GetUInt(BinInput, 4, 4)
277 Dim a As ULong = GetUInt(Key, 0, 4)
278 Dim b As ULong = GetUInt(Key, 4, 4)
279 Dim c As ULong = GetUInt(Key, 8, 4)
280 Dim d As ULong = GetUInt(Key, 12, 4)
281
282 If Is16Rounds Then
283 rounds = 16
284 Else
285 rounds = 32
286 End If
287
288 For i = 1 To rounds
289 sum = sum And &HFFFFFFFFL
290 sum += delta
291 z = z And &HFFFFFFFFL
292 y += ((z << 4) + a) Xor (z + sum) Xor ((z >> 5) + b)
293 y = y And &HFFFFFFFFL
294 z += ((y << 4) + c) Xor (y + sum) Xor ((y >> 5) + d)
295
296
297 Next
298
299 Return ToBytes(y, z)
300 End Function
301
302 Public Function GetUInt(ByVal input As Byte(), ByVal ioffset As Integer, ByVal intlen As Integer) As UInteger
303
304 Dim ret As UInteger = 0
305 Dim lend As Integer = IIf((intlen > 4), (ioffset + 4), (ioffset + intlen))
306 For i = ioffset To lend - 1
307 ret <<= 8
308 ret = ret Or input(i)
309 Next
310 Return ret
311 End Function
312
313 Public Function ToBytes(ByVal a As ULong, ByVal b As ULong) As Byte()
314
315 Dim bytes(7) As Byte
316
317 bytes(0) = CByte((a >> 24) And &HFF)
318 bytes(1) = CByte((a >> 16) And &HFF)
319 bytes(2) = CByte((a >> 8) And &HFF)
320 bytes(3) = CByte((a) And &HFF)
321 bytes(4) = CByte((b >> 24) And &HFF)
322 bytes(5) = CByte((b >> 16) And &HFF)
323 bytes(6) = CByte((b >> 8) And &HFF)
324 bytes(7) = CByte((b) And &HFF)
325 Return bytes
326
327 End Function
328
329 Private Sub ThrowMsg(ByVal TMsg As String)
330 Dim Trmsg As New MQQException(TMsg)
331 Throw Trmsg
332 End Sub
333
334 End Class
335
336 Public Class MQQException
337 Inherits System.ApplicationException
338
339 Public Sub New(ByVal StrMsg As String)
340 MyBase.New(StrMsg)
341
342 End Sub
343
344 End Class
345
346 End Namespace
347
348
2 '//发现有很多的版本的,当然也有VB的,但不是VB.NET的.那些VB的已经不能直接用了.
3 '//而且现在VB.NET已经可以移位了.看了以前VB写的.为了移位就写了一个函数。
4 '//只有C#或C++的两行的核心算法VB却要几十行。找遍了网上也没发现有VB.NET做只能靠自己了。
5 '// TEA加密算我上面说过，其实就只有两行核心代码。但是QQ在使用这个算法的时候，
6 '//由于需要加密不定长的数据，所以使用了一些常规的填充办法和交织算法.所以更多是处理填充和交织。
7 '
8 '// 本人E-Mail: liwqbasic[AT]gamail.com ([AT]换成@) QQ: &H12C214E9 [0x12C214E9]
9 '
10 '
11
12 Namespace HashTEA
13 Public Class hashtea
14
15 Private Const delta As UInteger = &H9E3779B9L 'tea算法的delta值
16 Private Plain(7) As Byte '指向当前的明文块
17 Private prePlain(7) As Byte '指向前面一个明文块
18 Private out() As Byte
19 Private Crypt As UInteger
20 Private preCrypt As UInteger '当前加密的密文位置和上一次加密的密文块位置，他们相差8
21 Private Pos As Long '当前处理的加密解密块的位置
22 Private padding As Long '填充数
23 Private Key(15) As Byte '密钥
24 Private Header As Boolean '用于加密时，表示当前是否是第一个8字节块，因为加密算法
25 '是反馈的，但是最开始的8个字节没有反馈可用，所有需要标明这种情况
26 Private contextStart As Long
27
28 Public Function UnHashTEA(ByVal BinFrom As Byte(), ByVal BinTKey As Byte(), _
29 ByVal offset As Integer, ByVal Is16Rounds As Boolean) As Byte()
30
31 Crypt = 0
32 preCrypt = 0
33 Key = BinTKey
34 Dim count As Integer = 0
35 Dim m(offset + 7) As Byte
36 Dim intlen As Integer = BinFrom.Length
37
38 If intlen < 16 Or (intlen Mod 8 <> 0) Then ThrowMsg("Len No Enuf")
39
40 prePlain = Decipher(BinFrom, Key, True)
41 Pos = prePlain(0) And &H7
42 count = intlen - Pos - 10
43
44 If count < 0 Then ThrowMsg("Count No Enuf")
45
46 For i = offset To m.Length - 1
47 m(i) = 0
48 Next
49 ReDim out(count - 1)
50 preCrypt = 0
51 Crypt = 8
52 contextStart = 8
53 Pos += 1
54
55 padding = 1
56 While padding <= 2
57
58 If Pos < 8 Then
59 Pos += 1
60 padding += 1
61
62 End If
63 If Pos = 8 Then
64 m = BinFrom
65 If Not (Decrypt8Bytes(BinFrom, offset, intlen)) Then
66 ThrowMsg("Decrypt8Bytes() failed.")
67 End If
68 End If
69 End While
70
71 Dim i2 = 0
72 While count <> 0
73 If Pos < 8 Then
74 out(i2) = CByte(m(offset + preCrypt + Pos) Xor prePlain(Pos))
75 i2 += 1
76 count -= 1
77 Pos += 1
78 End If
79
80 If Pos = 8 Then
81 m = BinFrom
82 preCrypt = Crypt - 8
83 Decrypt8Bytes(BinFrom, offset, intlen)
84 End If
85
86 End While
87
88 For i = 1 To 7
89 If Pos < 8 Then
90 If (m(offset + preCrypt + Pos) Xor prePlain(Pos)) <> 0 Then
91 ThrowMsg("tail is not filled correct.")
92 End If
93 Pos += 1
94 If Pos = 8 Then
95 m = BinFrom
96 If Not (Decrypt8Bytes(BinFrom, offset, intlen)) Then
97 ThrowMsg("Decrypt8Bytes() failed.")
98 End If
99
100 End If
101 End If
102 Next
103
104 Return out
105
106 End Function
107
108 Private Function Decrypt8Bytes(ByVal input() As Byte, ByVal offset As Integer, _
109 ByVal intlen As Integer) As Boolean
110
111 For i = 0 To 7
112 If contextStart + i >= intlen Then
113 Return True
114 End If
115 prePlain(i) = prePlain(i) Xor input(offset + Crypt + i)
116
117 Next
118
119
120
121 prePlain = Decipher(prePlain, Key, True)
122 If prePlain Is Nothing Then
123 Return False
124
125 End If
126 contextStart += 8
127 Crypt += 8
128 Pos = 0
129
130 Return True
131 End Function
132
133 Private Function Decipher(ByVal BinInput() As Byte, _
134 ByVal Binkey() As Byte, ByVal Is16Rounds As Boolean) As Byte()
135 '标准tea解密过程,参数ltype 为1时表示16轮迭代(qq使用的就是16轮迭代),否则为32轮迭代
136
137 Dim sum As Long = &HE3779B90L
138 Dim rounds As Integer
139
140 Dim y As Long = GetUInt(BinInput, 0, 4)
141 Dim z As Long = GetUInt(BinInput, 4, 4)
142 Dim a As Long = GetUInt(Key, 0, 4)
143 Dim b As Long = GetUInt(Key, 4, 4)
144 Dim c As Long = GetUInt(Key, 8, 4)
145 Dim d As Long = GetUInt(Key, 12, 4)
146
147 If Is16Rounds Then
148 rounds = 16
149 Else
150 rounds = 32
151 End If
152 Dim Test As Long = 0
153 For i = 1 To rounds
154
155 Test = ((y << 4) + c) Xor (y + sum) Xor ((y >> 5) + d)
156 z -= Test
157 z = z And &HFFFFFFFFL
158
159 Test = ((z << 4) + a) Xor (z + sum) Xor ((z >> 5) + b)
160 y -= Test
161 y = y And &HFFFFFFFFL
162
163 sum -= delta
164 sum = sum And &HFFFFFFFFL
165
166 Next
167
168 Return ToBytes(y, z)
169 End Function
170
171 Public Function HashTEA(ByVal BinFrom As Byte(), ByVal BinTKey As Byte(), _
172 ByVal offset As Integer, ByVal Is16Rounds As Boolean) As Byte()
173
174 Header = True
175 Key = BinTKey
176 Pos = 1
177 padding = 0
178 Crypt = 0
179 preCrypt = 0
180 Dim intlen As Integer = BinFrom.Length
181 Dim xRnd As New Random
182 Pos = (intlen + 10) Mod 8
183
184 If Pos <> 0 Then Pos = 8 - Pos
185 ReDim out(intlen + Pos + 9)
186
187
188
189 Plain(0) = CByte((xRnd.Next And &HF8) Or Pos)
190
191 For i = 1 To Pos
192 Plain(i) = CByte(xRnd.Next And &HFF)
193 Next
194
195 For i = 0 To 7
196 prePlain(i) = CByte(&H0)
197 Next
198
199 Pos += 1
200 padding = 1
201 Do While padding < 3
202 If Pos < 8 Then
203 Plain(Pos) = CByte(xRnd.Next And &HFF)
204 Pos += 1
205 padding += 1
206
207 Else
208 Encrypt8Bytes(Is16Rounds)
209 End If
210 Loop
211
212 Dim i2 = offset
213 While intlen > 0
214 If Pos < 8 Then
215
216 Plain(Pos) = BinFrom(i2)
217 Pos += 1
218 intlen -= 1
219
220 i2 += 1
221 Else
222 Encrypt8Bytes(Is16Rounds)
223
224 End If
225 End While
226
227 padding = 1
228 While padding < 8
229 If Pos < 8 Then
230
231 Plain(Pos) = &H0
232 padding += 1
233 Pos += 1
234 End If
235
236 If Pos = 8 Then
237 Encrypt8Bytes(Is16Rounds)
238 End If
239 End While
240
241 Return out
242 End Function
243
244 Private Sub Encrypt8Bytes(ByVal Is16Rounds As Boolean)
245 Dim Crypted() As Byte
246 Pos = 0
247 For i = 0 To 7
248 If Header Then
249 Plain(i) = Plain(i) Xor prePlain(0)
250 Else
251 Plain(i) = Plain(i) Xor out(preCrypt + i)
252 End If
253 Next
254 Crypted = Encipher(Plain, Key, Is16Rounds)
255 Array.Copy(Crypted, 0, out, Crypt, 8)
256 For i = 0 To 7
257 out(Crypt + i) = out(Crypt + i) Xor prePlain(i)
258
259 Next
260 Array.Copy(Plain, 0, prePlain, 0, 8)
261 preCrypt = Crypt
262 Crypt += 8
263 Pos = 0
264 Header = False
265
266 End Sub
267
268 Private Function Encipher(ByVal BinInput() As Byte, ByVal k() As Byte, ByVal Is16Rounds As Boolean)
269 '标准的tea加密过程,参数 Is16Rounds 为True时表示16轮迭代(qq使用的就是16轮迭代),否则为32轮迭代
270
271 Dim sum As ULong
272
273 Dim rounds As Integer
274
275 Dim y As ULong = GetUInt(BinInput, 0, 4)
276 Dim z As ULong = GetUInt(BinInput, 4, 4)
277 Dim a As ULong = GetUInt(Key, 0, 4)
278 Dim b As ULong = GetUInt(Key, 4, 4)
279 Dim c As ULong = GetUInt(Key, 8, 4)
280 Dim d As ULong = GetUInt(Key, 12, 4)
281
282 If Is16Rounds Then
283 rounds = 16
284 Else
285 rounds = 32
286 End If
287
288 For i = 1 To rounds
289 sum = sum And &HFFFFFFFFL
290 sum += delta
291 z = z And &HFFFFFFFFL
292 y += ((z << 4) + a) Xor (z + sum) Xor ((z >> 5) + b)
293 y = y And &HFFFFFFFFL
294 z += ((y << 4) + c) Xor (y + sum) Xor ((y >> 5) + d)
295
296
297 Next
298
299 Return ToBytes(y, z)
300 End Function
301
302 Public Function GetUInt(ByVal input As Byte(), ByVal ioffset As Integer, ByVal intlen As Integer) As UInteger
303
304 Dim ret As UInteger = 0
305 Dim lend As Integer = IIf((intlen > 4), (ioffset + 4), (ioffset + intlen))
306 For i = ioffset To lend - 1
307 ret <<= 8
308 ret = ret Or input(i)
309 Next
310 Return ret
311 End Function
312
313 Public Function ToBytes(ByVal a As ULong, ByVal b As ULong) As Byte()
314
315 Dim bytes(7) As Byte
316
317 bytes(0) = CByte((a >> 24) And &HFF)
318 bytes(1) = CByte((a >> 16) And &HFF)
319 bytes(2) = CByte((a >> 8) And &HFF)
320 bytes(3) = CByte((a) And &HFF)
321 bytes(4) = CByte((b >> 24) And &HFF)
322 bytes(5) = CByte((b >> 16) And &HFF)
323 bytes(6) = CByte((b >> 8) And &HFF)
324 bytes(7) = CByte((b) And &HFF)
325 Return bytes
326
327 End Function
328
329 Private Sub ThrowMsg(ByVal TMsg As String)
330 Dim Trmsg As New MQQException(TMsg)
331 Throw Trmsg
332 End Sub
333
334 End Class
335
336 Public Class MQQException
337 Inherits System.ApplicationException
338
339 Public Sub New(ByVal StrMsg As String)
340 MyBase.New(StrMsg)
341
342 End Sub
343
344 End Class
345
346 End Namespace
347
348
