1
2print "1..3\n";
3
4use strict;
5use Digest::MD5 qw(md5 md5_hex md5_base64);
6
7# To update the EBCDIC section even on a Latin 1 platform,
8# run this script with $ENV{EBCDIC_MD5SUM} set to a true value.
9# (You'll need to have Perl 5.7.3 or later, to have the Encode installed.)
10# (And remember that under the Perl core distribution you should
11#  also have the $ENV{PERL_CORE} set to a true value.)
12
13my $EXPECT;
14if (ord "A" == 193) { # EBCDIC
15    $EXPECT = <<EOT;
160956ffb4f6416082b27d6680b4cf73fc  README
1760a80f534f0017745eb755f36a946fe7  MD5.xs
18276da0aa4e9a08b7fe09430c9c5690aa  rfc1321.txt
19EOT
20} else {
21    # This is the output of: 'md5sum README MD5.xs rfc1321.txt'
22    $EXPECT = <<EOT;
232f93400875dbb56f36691d5f69f3eba5  README
249572832f3628e3bebcdd54f47c43dc5a  MD5.xs
25754b9db19f79dbc4992f7166eb0f37ce  rfc1321.txt
26EOT
27}
28
29if (!(-f "README") && -f "../README") {
30   chdir("..") or die "Can't chdir: $!";
31}
32
33my $testno = 0;
34
35my $B64 = 1;
36eval { require MIME::Base64; };
37if ($@) {
38    print "# $@: Will not test base64 methods\n";
39    $B64 = 0;
40}
41
42for (split /^/, $EXPECT) {
43     my($md5hex, $file) = split ' ';
44     my $base = $file;
45#     print "# $base\n";
46     if ($ENV{PERL_CORE}) {
47         # Don't have these in core.
48         if ($file eq 'rfc1321.txt' or $file eq 'README') {
49	     print "ok ", ++$testno, " # Skip: PERL_CORE\n";
50	     next;
51	 }
52     }
53#     print "# file = $file\n";
54     unless (-f $file) {
55	warn "No such file: $file\n";
56	next;
57     }
58     if ($ENV{EBCDIC_MD5SUM}) {
59         require Encode;
60	 my $data = cat_file($file);
61	 Encode::from_to($data, 'latin1', 'cp1047');
62	 print md5_hex($data), "  $base\n";
63	 next;
64     }
65     my $md5bin = pack("H*", $md5hex);
66     my $md5b64;
67     if ($B64) {
68	 $md5b64 = MIME::Base64::encode($md5bin, "");
69	 chop($md5b64); chop($md5b64);   # remove padding
70     }
71     my $failed;
72     my $got;
73
74     if (digest_file($file, 'digest') ne $md5bin) {
75	 print "$file: Bad digest\n";
76	 $failed++;
77     }
78
79     if (($got = digest_file($file, 'hexdigest')) ne $md5hex) {
80	 print "$file: Bad hexdigest: got $got expected $md5hex\n";
81	 $failed++;
82     }
83
84     if ($B64 && digest_file($file, 'b64digest') ne $md5b64) {
85	 print "$file: Bad b64digest\n";
86	 $failed++;
87     }
88
89     my $data = cat_file($file);
90     if (md5($data) ne $md5bin) {
91	 print "$file: md5() failed\n";
92	 $failed++;
93     }
94     if (md5_hex($data) ne $md5hex) {
95	 print "$file: md5_hex() failed\n";
96	 $failed++;
97     }
98     if ($B64 && md5_base64($data) ne $md5b64) {
99	 print "$file: md5_base64() failed\n";
100	 $failed++;
101     }
102
103     if (Digest::MD5->new->add($data)->digest ne $md5bin) {
104	 print "$file: MD5->new->add(...)->digest failed\n";
105	 $failed++;
106     }
107     if (Digest::MD5->new->add($data)->hexdigest ne $md5hex) {
108	 print "$file: MD5->new->add(...)->hexdigest failed\n";
109	 $failed++;
110     }
111     if ($B64 && Digest::MD5->new->add($data)->b64digest ne $md5b64) {
112	 print "$file: MD5->new->add(...)->b64digest failed\n";
113	 $failed++;
114     }
115
116     my @data = split //, $data;
117     if (md5(@data) ne $md5bin) {
118	 print "$file: md5(\@data) failed\n";
119	 $failed++;
120     }
121     if (Digest::MD5->new->add(@data)->digest ne $md5bin) {
122	 print "$file: MD5->new->add(\@data)->digest failed\n";
123	 $failed++;
124     }
125     my $md5 = Digest::MD5->new;
126     for (@data) {
127	 $md5->add($_);
128     }
129     if ($md5->digest ne $md5bin) {
130	 print "$file: $md5->add()-loop failed\n";
131	 $failed++;
132     }
133
134     print "not " if $failed;
135     print "ok ", ++$testno, "\n";
136}
137
138
139sub digest_file
140{
141    my($file, $method) = @_;
142    $method ||= "digest";
143    #print "$file $method\n";
144
145    open(FILE, $file) or die "Can't open $file: $!";
146    my $digest = Digest::MD5->new->addfile(*FILE)->$method();
147    close(FILE);
148
149    $digest;
150}
151
152sub cat_file
153{
154    my($file) = @_;
155    local $/;  # slurp
156    open(FILE, $file) or die "Can't open $file: $!";
157
158    # For PerlIO in case of UTF-8 locales.
159    eval 'binmode(FILE, ":bytes")' if $] >= 5.008;
160
161    my $tmp = <FILE>;
162    close(FILE);
163    $tmp;
164}
165
166