File Coverage

lib/SMB/Crypt.pm
Criterion Covered Total %
statement 188 277 67.8
branch 21 34 61.7
condition 3 6 50.0
subroutine 27 34 79.4
pod 4 30 13.3
total 243 381 63.7


line stmt bran cond sub pod time code
1             # SMB-Perl library, Copyright (C) 2014 Mikhael Goikhman, migo@cpan.org
2             #
3             # This program is free software: you can redistribute it and/or modify
4             # it under the terms of the GNU General Public License as published by
5             # the Free Software Foundation, either version 3 of the License, or
6             # (at your option) any later version.
7             #
8             # This program is distributed in the hope that it will be useful,
9             # but WITHOUT ANY WARRANTY; without even the implied warranty of
10             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11             # GNU General Public License for more details.
12             #
13             # You should have received a copy of the GNU General Public License
14             # along with this program. If not, see .
15              
16             package SMB::Crypt;
17              
18 3     3   702 use strict;
  3         5  
  3         93  
19 3     3   15 use warnings;
  3         4  
  3         79  
20              
21 3     3   17 use bytes;
  3         5  
  3         21  
22              
23 3     3   70 use Exporter 'import';
  3         5  
  3         14426  
24             our @EXPORT = qw(des_crypt56 md4 md5 hmac_md5);
25              
26             # lazy probing
27             our $has_Crypt_DES = undef;
28             our $has_Digest_MD4 = undef;
29             our $has_Digest_MD5 = undef;
30              
31             sub has_Crypt_DES () {
32 3 50   3 0 12 return 1 if $has_Crypt_DES;
33 3 50       10 return 0 if defined $has_Crypt_DES;
34              
35 3         839 return $has_Crypt_DES = eval "require 'Crypt/DES.pm'";
36             }
37              
38             sub has_Digest_MD4 () {
39 4 50   4 0 17 return 1 if $has_Digest_MD4;
40 4 50       12 return 0 if defined $has_Digest_MD4;
41              
42 4         361 return $has_Digest_MD4 = eval "require 'Digest/MD4.pm'";
43             }
44              
45             sub has_Digest_MD5 () {
46 15 100   15 0 52 return 1 if $has_Digest_MD5;
47 2 50       8 return 0 if defined $has_Digest_MD5;
48              
49 2         127 return $has_Digest_MD5 = eval "require 'Digest/MD5.pm'";
50             }
51              
52             # DES parts for SMB authentication, ported from samba auth/smbdes.c
53             # perm1[56], perm2[48], perm3[64], perm4[48], perm5[32], perm6[64],
54             # sc[16], sbox[8][4][16]
55              
56             my $des_perm1 = [
57             57, 49, 41, 33, 25, 17, 9, 1, 58, 50, 42, 34, 26, 18,
58             10, 2, 59, 51, 43, 35, 27, 19, 11, 3, 60, 52, 44, 36,
59             63, 55, 47, 39, 31, 23, 15, 7, 62, 54, 46, 38, 30, 22,
60             14, 6, 61, 53, 45, 37, 29, 21, 13, 5, 28, 20, 12, 4,
61             ];
62             my $des_perm2 = [
63             14, 17, 11, 24, 1, 5, 3, 28, 15, 6, 21, 10,
64             23, 19, 12, 4, 26, 8, 16, 7, 27, 20, 13, 2,
65             41, 52, 31, 37, 47, 55, 30, 40, 51, 45, 33, 48,
66             44, 49, 39, 56, 34, 53, 46, 42, 50, 36, 29, 32,
67             ];
68             my $des_perm3 = [
69             58, 50, 42, 34, 26, 18, 10, 2, 60, 52, 44, 36, 28, 20, 12, 4,
70             62, 54, 46, 38, 30, 22, 14, 6, 64, 56, 48, 40, 32, 24, 16, 8,
71             57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3,
72             61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7,
73             ];
74             my $des_perm4 = [
75             32, 1, 2, 3, 4, 5, 4, 5, 6, 7, 8, 9,
76             8, 9, 10, 11, 12, 13, 12, 13, 14, 15, 16, 17,
77             16, 17, 18, 19, 20, 21, 20, 21, 22, 23, 24, 25,
78             24, 25, 26, 27, 28, 29, 28, 29, 30, 31, 32, 1,
79             ];
80             my $des_perm5 = [
81             16, 7, 20, 21, 29, 12, 28, 17,
82             1, 15, 23, 26, 5, 18, 31, 10,
83             2, 8, 24, 14, 32, 27, 3, 9,
84             19, 13, 30, 6, 22, 11, 4, 25,
85             ];
86             my $des_perm6 = [
87             40, 8, 48, 16, 56, 24, 64, 32, 39, 7, 47, 15, 55, 23, 63, 31,
88             38, 6, 46, 14, 54, 22, 62, 30, 37, 5, 45, 13, 53, 21, 61, 29,
89             36, 4, 44, 12, 52, 20, 60, 28, 35, 3, 43, 11, 51, 19, 59, 27,
90             34, 2, 42, 10, 50, 18, 58, 26, 33, 1, 41, 9, 49, 17, 57, 25,
91             ];
92             my @des_sc = ( 1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2, 1 );
93             my @des_sbox = (
94             [
95             [ 14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7 ],
96             [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8 ],
97             [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0 ],
98             [ 15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13 ],
99             ],
100             [
101             [ 15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10 ],
102             [ 3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5 ],
103             [ 0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15 ],
104             [ 13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9 ],
105             ],
106             [
107             [ 10, 0, 9, 14, 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8 ],
108             [ 13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1 ],
109             [ 13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7 ],
110             [ 1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12 ],
111             ],
112             [
113             [ 7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15 ],
114             [ 13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9 ],
115             [ 10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4 ],
116             [ 3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14 ],
117             ],
118             [
119             [ 2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9 ],
120             [ 14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6 ],
121             [ 4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14 ],
122             [ 11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3 ],
123             ],
124             [
125             [ 12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11 ],
126             [ 10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8 ],
127             [ 9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6 ],
128             [ 4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13 ],
129             ],
130             [
131             [ 4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1 ],
132             [ 13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6 ],
133             [ 1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2 ],
134             [ 6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12 ],
135             ],
136             [
137             [ 13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7 ],
138             [ 1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2 ],
139             [ 7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8 ],
140             [ 2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11 ],
141             ]
142             );
143              
144             sub xor_inplace ($$) {
145 96     96 0 111 my $a1 = shift;
146 96         111 my $a2 = shift;
147              
148 96         176 for my $i (0 .. @$a1 - 1) {
149 3840         4288 $a1->[$i] ^= $a2->[$i];
150             }
151             }
152              
153             sub des_str_to_key {
154 3     3 0 13 my @str = map { ord($_) } split('', $_[0]);
  21         29  
155              
156 3         24 my @key = (
157             0 | ($str[0] >> 1),
158             (($str[0] & 0x01) << 6) | ($str[1] >> 2),
159             (($str[1] & 0x03) << 5) | ($str[2] >> 3),
160             (($str[2] & 0x07) << 4) | ($str[3] >> 4),
161             (($str[3] & 0x0F) << 3) | ($str[4] >> 5),
162             (($str[4] & 0x1F) << 2) | ($str[5] >> 6),
163             (($str[5] & 0x3F) << 1) | ($str[6] >> 7),
164             (($str[6] & 0x7F) << 0) | 0,
165             );
166 3         15 $_ <<= 1 for @key;
167              
168 3         9 return join('', map { chr($_) } @key);
  24         44  
169             }
170              
171             sub permute ($$) {
172 153     153 0 170 my $a = shift;
173 153         158 my $p = shift;
174              
175 153         231 return [ map { $a->[$_ - 1] } @$p ];
  6696         8901  
176             }
177              
178             sub lshift ($$) {
179 96     96 0 103 my $a = shift;
180 96         108 my $count = shift() % @$a;
181              
182 96         196 @$a = ( @{$a}[$count .. @$a - 1], @{$a}[0 .. $count - 1] );
  96         176  
  96         456  
183             }
184              
185             sub des_dohash ($$$) {
186 3     3 0 4 my $arr = shift;
187 3         7 my $key = shift;
188 3         7 my $forw = shift;
189              
190 3         8 my $c = permute($key, $des_perm1);
191 3         20 my $d = [ splice(@$c, 28) ];
192              
193 3         7 my @ki;
194 3         8 for my $i (0 .. 15) {
195 48         87 lshift($c, $des_sc[$i]);
196 48         131 lshift($d, $des_sc[$i]);
197              
198 48         300 $ki[$i] = permute([ @$c, @$d ], $des_perm2);
199             }
200              
201 3         11 my $l = permute($arr, $des_perm3);
202 3         17 my $r = [ splice(@$l, 32) ];
203              
204 3         10 for my $i (0 .. 15) {
205 48         87 my $er = permute($r, $des_perm4);
206              
207 48 50       185 xor_inplace($er, $ki[$forw ? $i : 15 - $i]);
208              
209 48         62 my @b;
210 48         73 for my $j (0 .. 7) {
211 384         479 $b[$j] = [];
212 384         486 for my $k (0 .. 5) {
213 2304         3714 $b[$j][$k] = $er->[$j * 6 + $k];
214             }
215             }
216              
217 48         79 for my $j (0 .. 7) {
218 384         607 my $m = ($b[$j][0] << 1) | ($b[$j][5] << 0);
219 384         675 my $n = ($b[$j][1] << 3) | ($b[$j][2] << 2) | ($b[$j][3] << 1) | ($b[$j][4] << 0);
220              
221 384         447 for my $k (0 .. 3) {
222 1536 100       3384 $b[$j][$k] = $des_sbox[$j][$m][$n] & (1 << (3 - $k)) ? 1 : 0;
223             }
224             }
225              
226 48         54 my @cb;
227 48         63 for my $j (0 .. 7) {
228 384         439 for my $k (0 .. 3) {
229 1536         2374 $cb[$j * 4 + $k] = $b[$j][$k];
230             }
231             }
232              
233 48         129 my $pcb = permute(\@cb, $des_perm5);
234              
235 48         125 xor_inplace($l, $pcb);
236              
237 48         366 ($l, $r) = ($r, $l);
238             }
239              
240 3         26 return permute([ @$r, @$l ], $des_perm6 );
241             }
242              
243             sub des_crypt56 ($$;$) {
244 3   50 3 1 796 my $data = shift // die "No 8-byte data to crypt";
245 3   50     12 my $str = shift // die "No 7-byte key to crypt";
246 3   50     22 my $forw = shift // 1;
247              
248 3 50       10 if (has_Crypt_DES()) {
249 0         0 return Crypt::DES->new(des_str_to_key($str))->encrypt($data);
250             }
251              
252 3         34 my $arr = [ map { ord($_) } split '', $data ];
  24         36  
253 3         15 my $key = [ map { ord($_) } split '', des_str_to_key($str) ];
  24         31  
254              
255 3         10 my $arrb = [];
256 3         6 my $keyb = [];
257 3         10 for my $i (0 .. 63) {
258 192 100       483 $arrb->[$i] = $arr->[$i / 8] & (1 << (7 - $i % 8)) ? 1 : 0;
259 192 100       411 $keyb->[$i] = $key->[$i / 8] & (1 << (7 - $i % 8)) ? 1 : 0;
260             }
261              
262 3         16 my $outb = des_dohash($arrb, $keyb, $forw);
263              
264 3         24 my $out = [ (0) x 8 ];
265 3         9 for my $i (0 .. 63) {
266 192 100       368 $out->[$i / 8] |= 1 << (7 - $i % 8)
267             if $outb->[$i];
268             }
269              
270 3         9 return join('', map { chr($_) } @$out);
  24         106  
271             }
272              
273             # MD4 parts for SMB authentication, ported from samba crypto/md4.c
274              
275             our @md4_state;
276              
277 64     64 0 71 sub md4_F { my ($x, $y, $z) = @_; return ($x & $y) | ((~$x) & $z); }
  64         150  
278 64     64 0 76 sub md4_G { my ($x, $y, $z) = @_; return ($x & $y) | ($x & $z) | ($y & $z); }
  64         141  
279 64     64 0 104 sub md4_H { my ($x, $y, $z) = @_; return $x ^ $y ^ $z; }
  64         115  
280              
281             # uint32 arithmetic in perl, hopefully works on all platforms
282             sub add32 (@) {
283 208     208 0 297 my @sum = (0, 0);
284 208         282 for (@_) {
285 800         731 $sum[0] += $_ & 0xFFFF;
286 800         1034 $sum[1] += ($_ >> 16) & 0xFFFF;
287             }
288 208         272 $sum[1] += $sum[0] >> 16;
289 208         190 $sum[0] &= 0xFFFF;
290 208         180 $sum[1] &= 0xFFFF;
291              
292 208         440 return ($sum[1] << 16) + $sum[0];
293             }
294              
295             sub lshift32 ($$) {
296 192     192 0 209 my ($num, $count) = @_;
297              
298 192         407 return (($num << $count) & 0xFFFFFFFF) | ($num >> (32 - $count));
299             }
300              
301             sub md4_ROUND1 {
302 64     64 0 88 my ($a, $b, $c, $d, $X, $s) = @_;
303              
304 64         132 $md4_state[$a] = lshift32(add32($md4_state[$a], md4_F(@md4_state[$b, $c, $d]), $X, 0x00000000), $s);
305             }
306              
307             sub md4_ROUND2 {
308 64     64 0 86 my ($a, $b, $c, $d, $X, $s) = @_;
309              
310 64         170 $md4_state[$a] = lshift32(add32($md4_state[$a], md4_G(@md4_state[$b, $c, $d]), $X, 0x5A827999), $s);
311             }
312              
313             sub md4_ROUND3 {
314 64     64 0 76 my ($a, $b, $c, $d, $X, $s) = @_;
315              
316 64         124 $md4_state[$a] = lshift32(add32($md4_state[$a], md4_H(@md4_state[$b, $c, $d]), $X, 0x6ED9EBA1), $s);
317             }
318              
319             sub md4_64 (@) {
320 4     4 0 13 my @old_state = @md4_state;
321              
322 4         21 md4_ROUND1(0, 1, 2, 3, $_[ 0], 3); md4_ROUND1(3, 0, 1, 2, $_[ 1], 7);
  4         27  
323 4         13 md4_ROUND1(2, 3, 0, 1, $_[ 2], 11); md4_ROUND1(1, 2, 3, 0, $_[ 3], 19);
  4         11  
324 4         10 md4_ROUND1(0, 1, 2, 3, $_[ 4], 3); md4_ROUND1(3, 0, 1, 2, $_[ 5], 7);
  4         13  
325 4         12 md4_ROUND1(2, 3, 0, 1, $_[ 6], 11); md4_ROUND1(1, 2, 3, 0, $_[ 7], 19);
  4         10  
326 4         10 md4_ROUND1(0, 1, 2, 3, $_[ 8], 3); md4_ROUND1(3, 0, 1, 2, $_[ 9], 7);
  4         13  
327 4         12 md4_ROUND1(2, 3, 0, 1, $_[10], 11); md4_ROUND1(1, 2, 3, 0, $_[11], 19);
  4         12  
328 4         11 md4_ROUND1(0, 1, 2, 3, $_[12], 3); md4_ROUND1(3, 0, 1, 2, $_[13], 7);
  4         11  
329 4         12 md4_ROUND1(2, 3, 0, 1, $_[14], 11); md4_ROUND1(1, 2, 3, 0, $_[15], 19);
  4         12  
330              
331 4         15 md4_ROUND2(0, 1, 2, 3, $_[ 0], 3); md4_ROUND2(3, 0, 1, 2, $_[ 4], 5);
  4         12  
332 4         12 md4_ROUND2(2, 3, 0, 1, $_[ 8], 9); md4_ROUND2(1, 2, 3, 0, $_[12], 13);
  4         17  
333 4         40 md4_ROUND2(0, 1, 2, 3, $_[ 1], 3); md4_ROUND2(3, 0, 1, 2, $_[ 5], 5);
  4         11  
334 4         17 md4_ROUND2(2, 3, 0, 1, $_[ 9], 9); md4_ROUND2(1, 2, 3, 0, $_[13], 13);
  4         12  
335 4         17 md4_ROUND2(0, 1, 2, 3, $_[ 2], 3); md4_ROUND2(3, 0, 1, 2, $_[ 6], 5);
  4         13  
336 4         13 md4_ROUND2(2, 3, 0, 1, $_[10], 9); md4_ROUND2(1, 2, 3, 0, $_[14], 13);
  4         13  
337 4         13 md4_ROUND2(0, 1, 2, 3, $_[ 3], 3); md4_ROUND2(3, 0, 1, 2, $_[ 7], 5);
  4         88  
338 4         13 md4_ROUND2(2, 3, 0, 1, $_[11], 9); md4_ROUND2(1, 2, 3, 0, $_[15], 13);
  4         10  
339              
340 4         16 md4_ROUND3(0, 1, 2, 3, $_[ 0], 3); md4_ROUND3(3, 0, 1, 2, $_[ 8], 9);
  4         12  
341 4         11 md4_ROUND3(2, 3, 0, 1, $_[ 4], 11); md4_ROUND3(1, 2, 3, 0, $_[12], 15);
  4         11  
342 4         10 md4_ROUND3(0, 1, 2, 3, $_[ 2], 3); md4_ROUND3(3, 0, 1, 2, $_[10], 9);
  4         11  
343 4         11 md4_ROUND3(2, 3, 0, 1, $_[ 6], 11); md4_ROUND3(1, 2, 3, 0, $_[14], 15);
  4         13  
344 4         12 md4_ROUND3(0, 1, 2, 3, $_[ 1], 3); md4_ROUND3(3, 0, 1, 2, $_[ 9], 9);
  4         13  
345 4         11 md4_ROUND3(2, 3, 0, 1, $_[ 5], 11); md4_ROUND3(1, 2, 3, 0, $_[13], 15);
  4         70  
346 4         12 md4_ROUND3(0, 1, 2, 3, $_[ 3], 3); md4_ROUND3(3, 0, 1, 2, $_[11], 9);
  4         12  
347 4         12 md4_ROUND3(2, 3, 0, 1, $_[ 7], 11); md4_ROUND3(1, 2, 3, 0, $_[15], 15);
  4         11  
348              
349 4         23 $md4_state[$_] = add32($md4_state[$_], $old_state[$_]) for 0 .. 3;
350             }
351              
352             sub md4_copy64 (@) {
353 64         183 return map {
354 4     4 0 20 ($_[$_ * 4 + 3] << 24) |
355             ($_[$_ * 4 + 2] << 16) |
356             ($_[$_ * 4 + 1] << 8) |
357             ($_[$_ * 4 + 0] << 0)
358             } 0 .. 15;
359             }
360              
361             sub md4_copy4 ($) {
362 20     20 0 26 my ($x) = @_;
363              
364             return (
365 20         68 ($x >> 0) & 0xFF,
366             ($x >> 8) & 0xFF,
367             ($x >> 16) & 0xFF,
368             ($x >> 24) & 0xFF,
369             );
370             }
371              
372             sub md4 ($) {
373 4 50   4 1 1029 if (has_Digest_MD4()) {
374 0         0 return Digest::MD4::md4($_[0]);
375             }
376              
377 4         39 my @in = map { ord($_) } split('', $_[0]);
  33         55  
378 4         16 my $b = (@in * 8) & 0xFFFFFFFF;
379              
380 4         14 @md4_state = ( 0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476 );
381              
382 4         18 while (@in > 64) {
383 0         0 md4_64(md4_copy64(splice(@in, 0, 64)));
384             }
385              
386 4         65 my @buf = (@in, 0x80, (0) x (126 - @in));
387              
388 4 50       20 if (@in <= 55) {
389 4         17 @buf[56 .. 59] = md4_copy4($b);
390 4         22 md4_64(md4_copy64(@buf));
391             } else {
392 0         0 @buf[120 .. 123] = md4_copy4($b);
393 0         0 md4_64(md4_copy64(splice(@buf, 0, 64)));
394 0         0 md4_64(md4_copy64(@buf));
395             }
396              
397 4         16 return join('', map { chr($_) } map { md4_copy4($_) } @md4_state)
  64         136  
  16         27  
398             }
399              
400             # MD5 parts for SMB authentication, ported from samba crypto/md5.c
401              
402             our @md5_state;
403              
404 0     0 0 0 sub md5_F1 { $_[2] ^ ($_[0] & ($_[1] ^ $_[2])) }
405 0     0 0 0 sub md5_F2 { $_[1] ^ ($_[2] & ($_[0] ^ $_[1])) }
406 0     0 0 0 sub md5_F3 { $_[0] ^ $_[1] ^ $_[2] }
407 0     0 0 0 sub md5_F4 { $_[1] ^ ($_[0] | ~$_[2]) }
408              
409             sub md5_pad64 {
410 0     0 0 0 my $data = shift() . "\x80";
411              
412 0         0 my $len = length $data;
413 0 0       0 $data .= "\0" x (($len % 64 <= 56 ? 56 : 120) - $len % 64);
414 0         0 my $num_bits = ($len - 1) * 8;
415              
416 0         0 return $data . pack 'VV', $num_bits & 0xFFFFFFFF, $num_bits >> 32;
417             }
418              
419             sub md5_STEP ($$$$$$$$) {
420 0     0 0 0 my ($func, $a, $b, $c, $d, $X, $Y, $s) = @_;
421              
422 0         0 $md5_state[$a] = lshift32(add32($md5_state[$a], $func->($md5_state[$b], $md5_state[$c], $md5_state[$d]), $X, $Y), $s);
423 0         0 $md5_state[$a] = add32($md5_state[$a], $md5_state[$b]);
424             }
425              
426             sub md5_ROUND (@) {
427 0     0 0 0 my @old_state = @md5_state;
428              
429 0         0 md5_STEP(\&md5_F1, 0, 1, 2, 3, $_[ 0], 0xd76aa478, 7);
430 0         0 md5_STEP(\&md5_F1, 3, 0, 1, 2, $_[ 1], 0xe8c7b756, 12);
431 0         0 md5_STEP(\&md5_F1, 2, 3, 0, 1, $_[ 2], 0x242070db, 17);
432 0         0 md5_STEP(\&md5_F1, 1, 2, 3, 0, $_[ 3], 0xc1bdceee, 22);
433 0         0 md5_STEP(\&md5_F1, 0, 1, 2, 3, $_[ 4], 0xf57c0faf, 7);
434 0         0 md5_STEP(\&md5_F1, 3, 0, 1, 2, $_[ 5], 0x4787c62a, 12);
435 0         0 md5_STEP(\&md5_F1, 2, 3, 0, 1, $_[ 6], 0xa8304613, 17);
436 0         0 md5_STEP(\&md5_F1, 1, 2, 3, 0, $_[ 7], 0xfd469501, 22);
437 0         0 md5_STEP(\&md5_F1, 0, 1, 2, 3, $_[ 8], 0x698098d8, 7);
438 0         0 md5_STEP(\&md5_F1, 3, 0, 1, 2, $_[ 9], 0x8b44f7af, 12);
439 0         0 md5_STEP(\&md5_F1, 2, 3, 0, 1, $_[10], 0xffff5bb1, 17);
440 0         0 md5_STEP(\&md5_F1, 1, 2, 3, 0, $_[11], 0x895cd7be, 22);
441 0         0 md5_STEP(\&md5_F1, 0, 1, 2, 3, $_[12], 0x6b901122, 7);
442 0         0 md5_STEP(\&md5_F1, 3, 0, 1, 2, $_[13], 0xfd987193, 12);
443 0         0 md5_STEP(\&md5_F1, 2, 3, 0, 1, $_[14], 0xa679438e, 17);
444 0         0 md5_STEP(\&md5_F1, 1, 2, 3, 0, $_[15], 0x49b40821, 22);
445              
446 0         0 md5_STEP(\&md5_F2, 0, 1, 2, 3, $_[ 1], 0xf61e2562, 5);
447 0         0 md5_STEP(\&md5_F2, 3, 0, 1, 2, $_[ 6], 0xc040b340, 9);
448 0         0 md5_STEP(\&md5_F2, 2, 3, 0, 1, $_[11], 0x265e5a51, 14);
449 0         0 md5_STEP(\&md5_F2, 1, 2, 3, 0, $_[ 0], 0xe9b6c7aa, 20);
450 0         0 md5_STEP(\&md5_F2, 0, 1, 2, 3, $_[ 5], 0xd62f105d, 5);
451 0         0 md5_STEP(\&md5_F2, 3, 0, 1, 2, $_[10], 0x02441453, 9);
452 0         0 md5_STEP(\&md5_F2, 2, 3, 0, 1, $_[15], 0xd8a1e681, 14);
453 0         0 md5_STEP(\&md5_F2, 1, 2, 3, 0, $_[ 4], 0xe7d3fbc8, 20);
454 0         0 md5_STEP(\&md5_F2, 0, 1, 2, 3, $_[ 9], 0x21e1cde6, 5);
455 0         0 md5_STEP(\&md5_F2, 3, 0, 1, 2, $_[14], 0xc33707d6, 9);
456 0         0 md5_STEP(\&md5_F2, 2, 3, 0, 1, $_[ 3], 0xf4d50d87, 14);
457 0         0 md5_STEP(\&md5_F2, 1, 2, 3, 0, $_[ 8], 0x455a14ed, 20);
458 0         0 md5_STEP(\&md5_F2, 0, 1, 2, 3, $_[13], 0xa9e3e905, 5);
459 0         0 md5_STEP(\&md5_F2, 3, 0, 1, 2, $_[ 2], 0xfcefa3f8, 9);
460 0         0 md5_STEP(\&md5_F2, 2, 3, 0, 1, $_[ 7], 0x676f02d9, 14);
461 0         0 md5_STEP(\&md5_F2, 1, 2, 3, 0, $_[12], 0x8d2a4c8a, 20);
462              
463 0         0 md5_STEP(\&md5_F3, 0, 1, 2, 3, $_[ 5], 0xfffa3942, 4);
464 0         0 md5_STEP(\&md5_F3, 3, 0, 1, 2, $_[ 8], 0x8771f681, 11);
465 0         0 md5_STEP(\&md5_F3, 2, 3, 0, 1, $_[11], 0x6d9d6122, 16);
466 0         0 md5_STEP(\&md5_F3, 1, 2, 3, 0, $_[14], 0xfde5380c, 23);
467 0         0 md5_STEP(\&md5_F3, 0, 1, 2, 3, $_[ 1], 0xa4beea44, 4);
468 0         0 md5_STEP(\&md5_F3, 3, 0, 1, 2, $_[ 4], 0x4bdecfa9, 11);
469 0         0 md5_STEP(\&md5_F3, 2, 3, 0, 1, $_[ 7], 0xf6bb4b60, 16);
470 0         0 md5_STEP(\&md5_F3, 1, 2, 3, 0, $_[10], 0xbebfbc70, 23);
471 0         0 md5_STEP(\&md5_F3, 0, 1, 2, 3, $_[13], 0x289b7ec6, 4);
472 0         0 md5_STEP(\&md5_F3, 3, 0, 1, 2, $_[ 0], 0xeaa127fa, 11);
473 0         0 md5_STEP(\&md5_F3, 2, 3, 0, 1, $_[ 3], 0xd4ef3085, 16);
474 0         0 md5_STEP(\&md5_F3, 1, 2, 3, 0, $_[ 6], 0x04881d05, 23);
475 0         0 md5_STEP(\&md5_F3, 0, 1, 2, 3, $_[ 9], 0xd9d4d039, 4);
476 0         0 md5_STEP(\&md5_F3, 3, 0, 1, 2, $_[12], 0xe6db99e5, 11);
477 0         0 md5_STEP(\&md5_F3, 2, 3, 0, 1, $_[15], 0x1fa27cf8, 16);
478 0         0 md5_STEP(\&md5_F3, 1, 2, 3, 0, $_[ 2], 0xc4ac5665, 23);
479              
480 0         0 md5_STEP(\&md5_F4, 0, 1, 2, 3, $_[ 0], 0xf4292244, 6);
481 0         0 md5_STEP(\&md5_F4, 3, 0, 1, 2, $_[ 7], 0x432aff97, 10);
482 0         0 md5_STEP(\&md5_F4, 2, 3, 0, 1, $_[14], 0xab9423a7, 15);
483 0         0 md5_STEP(\&md5_F4, 1, 2, 3, 0, $_[ 5], 0xfc93a039, 21);
484 0         0 md5_STEP(\&md5_F4, 0, 1, 2, 3, $_[12], 0x655b59c3, 6);
485 0         0 md5_STEP(\&md5_F4, 3, 0, 1, 2, $_[ 3], 0x8f0ccc92, 10);
486 0         0 md5_STEP(\&md5_F4, 2, 3, 0, 1, $_[10], 0xffeff47d, 15);
487 0         0 md5_STEP(\&md5_F4, 1, 2, 3, 0, $_[ 1], 0x85845dd1, 21);
488 0         0 md5_STEP(\&md5_F4, 0, 1, 2, 3, $_[ 8], 0x6fa87e4f, 6);
489 0         0 md5_STEP(\&md5_F4, 3, 0, 1, 2, $_[15], 0xfe2ce6e0, 10);
490 0         0 md5_STEP(\&md5_F4, 2, 3, 0, 1, $_[ 6], 0xa3014314, 15);
491 0         0 md5_STEP(\&md5_F4, 1, 2, 3, 0, $_[13], 0x4e0811a1, 21);
492 0         0 md5_STEP(\&md5_F4, 0, 1, 2, 3, $_[ 4], 0xf7537e82, 6);
493 0         0 md5_STEP(\&md5_F4, 3, 0, 1, 2, $_[11], 0xbd3af235, 10);
494 0         0 md5_STEP(\&md5_F4, 2, 3, 0, 1, $_[ 2], 0x2ad7d2bb, 15);
495 0         0 md5_STEP(\&md5_F4, 1, 2, 3, 0, $_[ 9], 0xeb86d391, 21);
496              
497 0         0 $md5_state[$_] = add32($md5_state[$_], $old_state[$_]) for 0 .. 3;
498             }
499              
500             sub md5 ($;$) {
501 15 50   15 1 830 if (has_Digest_MD5()) {
502 15         116 return Digest::MD5::md5(join '', @_);
503             }
504              
505 0         0 my $data = md5_pad64(join '', @_);
506              
507 0         0 @md5_state = ( 0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476 );
508              
509 0         0 for my $i (0 .. length($data) / 64 - 1) {
510 0         0 md5_ROUND(unpack 'V16', substr $data, $i * 64, 64);
511             }
512              
513 0         0 pack 'V4', @md5_state;
514             }
515              
516             sub hmac_md5 ($$) {
517 7     7 1 670 my ($data, $key) = @_;
518              
519 7 50       22 $key = md5($key) if length($key) > 64;
520              
521 7         21 my $ipad = $key ^ ("\x36" x 64);
522 7         13 my $opad = $key ^ ("\x5c" x 64);
523              
524 7         17 return md5($opad, md5($ipad, $data));
525             }
526              
527             1;
528              
529             __END__