File Coverage

blib/lib/Module/Signature.pm
Criterion Covered Total %
statement 50 405 12.3
branch 0 222 0.0
condition 0 129 0.0
subroutine 17 40 42.5
pod 0 2 0.0
total 67 798 8.4


line stmt bran cond sub pod time code
1             package Module::Signature;
2             $Module::Signature::VERSION = '0.87';
3              
4 2     2   1279 use 5.005;
  2         10  
5 2     2   10 use strict;
  2         4  
  2         49  
6 2     2   9 use vars qw($VERSION $SIGNATURE @ISA @EXPORT_OK);
  2         4  
  2         159  
7 2     2   14 use vars qw($Preamble $Cipher $Debug $Verbose $Timeout $AUTHOR);
  2         4  
  2         165  
8 2     2   13 use vars qw($KeyServer $KeyServerPort $AutoKeyRetrieve $CanKeyRetrieve);
  2         4  
  2         99  
9 2     2   10 use vars qw($LegacySigFile);
  2         5  
  2         90  
10              
11 2     2   12 use constant CANNOT_VERIFY => '0E0';
  2         3  
  2         192  
12 2     2   13 use constant SIGNATURE_OK => 0;
  2         4  
  2         98  
13 2     2   12 use constant SIGNATURE_MISSING => -1;
  2         9  
  2         141  
14 2     2   20 use constant SIGNATURE_MALFORMED => -2;
  2         5  
  2         103  
15 2     2   13 use constant SIGNATURE_BAD => -3;
  2         3  
  2         93  
16 2     2   14 use constant SIGNATURE_MISMATCH => -4;
  2         4  
  2         138  
17 2     2   12 use constant MANIFEST_MISMATCH => -5;
  2         24  
  2         90  
18 2     2   10 use constant CIPHER_UNKNOWN => -6;
  2         4  
  2         90  
19              
20 2     2   1020 use ExtUtils::Manifest ();
  2         17953  
  2         57  
21 2     2   14 use Exporter;
  2         4  
  2         63  
22 2     2   9 use File::Spec;
  2         4  
  2         10087  
23              
24             @EXPORT_OK = (
25             qw(sign verify),
26             qw($SIGNATURE $AUTHOR $KeyServer $Cipher $Preamble),
27             (grep { /^[A-Z_]+_[A-Z_]+$/ } keys %Module::Signature::),
28             );
29             @ISA = 'Exporter';
30              
31             $AUTHOR = $ENV{MODULE_SIGNATURE_AUTHOR};
32             $SIGNATURE = 'SIGNATURE';
33             $Timeout = $ENV{MODULE_SIGNATURE_TIMEOUT} || 3;
34             $Verbose = $ENV{MODULE_SIGNATURE_VERBOSE} || 0;
35             $KeyServer = $ENV{MODULE_SIGNATURE_KEYSERVER} || 'pool.sks-keyservers.net';
36             $KeyServerPort = $ENV{MODULE_SIGNATURE_KEYSERVERPORT} || '11371';
37             $Cipher = $ENV{MODULE_SIGNATURE_CIPHER} || 'SHA256';
38             $Preamble = << ".";
39             This file contains message digests of all files listed in MANIFEST,
40             signed via the Module::Signature module, version $VERSION.
41              
42             To verify the content in this distribution, first make sure you have
43             Module::Signature installed, then type:
44              
45             % cpansign -v
46              
47             It will check each file's integrity, as well as the signature's
48             validity. If "==> Signature verified OK! <==" is not displayed,
49             the distribution may already have been compromised, and you should
50             not run its Makefile.PL or Build.PL.
51              
52             .
53              
54             $AutoKeyRetrieve = 1;
55             $CanKeyRetrieve = undef;
56             $LegacySigFile = 0;
57              
58             sub _cipher_map {
59 0     0     my($sigtext) = @_;
60 0           my @lines = split /\015?\012/, $sigtext;
61 0           my %map;
62 0           for my $line (@lines) {
63 0 0         last if $line eq '-----BEGIN PGP SIGNATURE-----';
64 0 0         next if $line =~ /^---/ .. $line eq '';
65 0           my($cipher,$digest,$file) = split " ", $line, 3;
66 0 0         return unless defined $file;
67 0           $map{$file} = [$cipher, $digest];
68             }
69 0           return \%map;
70             }
71              
72             sub verify {
73 0     0 0   my %args = ( skip => $ENV{TEST_SIGNATURE}, @_ );
74 0           my $rv;
75              
76 0 0         (-r $SIGNATURE) or do {
77 0           warn "==> MISSING Signature file! <==\n";
78 0           return SIGNATURE_MISSING;
79             };
80              
81 0 0         (my $sigtext = _read_sigfile($SIGNATURE)) or do {
82 0           warn "==> MALFORMED Signature file! <==\n";
83 0           return SIGNATURE_MALFORMED;
84             };
85              
86 0 0         (my ($cipher_map) = _cipher_map($sigtext)) or do {
87 0           warn "==> MALFORMED Signature file! <==\n";
88 0           return SIGNATURE_MALFORMED;
89             };
90              
91 0 0         (defined(my $plaintext = _mkdigest($cipher_map))) or do {
92 0           warn "==> UNKNOWN Cipher format! <==\n";
93 0           return CIPHER_UNKNOWN;
94             };
95              
96 0           $rv = _verify($SIGNATURE, $sigtext, $plaintext);
97              
98 0 0         if ($rv == SIGNATURE_OK) {
    0          
    0          
99 0           my ($mani, $file) = _fullcheck($args{skip});
100              
101 0 0 0       if (@{$mani} or @{$file}) {
  0            
  0            
102 0           warn "==> MISMATCHED content between MANIFEST and distribution files! <==\n";
103 0           return MANIFEST_MISMATCH;
104             }
105             else {
106 0 0         warn "==> Signature verified OK! <==\n" if $Verbose;
107             }
108             }
109             elsif ($rv == SIGNATURE_BAD) {
110 0           warn "==> BAD/TAMPERED signature detected! <==\n";
111             }
112             elsif ($rv == SIGNATURE_MISMATCH) {
113 0           warn "==> MISMATCHED content between SIGNATURE and distribution files! <==\n";
114             }
115              
116 0           return $rv;
117             }
118              
119             sub _verify {
120 0   0 0     my $signature = shift || $SIGNATURE;
121 0   0       my $sigtext = shift || '';
122 0   0       my $plaintext = shift || '';
123              
124             # Avoid loading modules from relative paths in @INC.
125 0           local @INC = grep { File::Spec->file_name_is_absolute($_) } @INC;
  0            
126 0 0         local $SIGNATURE = $signature if $signature ne $SIGNATURE;
127              
128 0 0 0       if ($AutoKeyRetrieve and !$CanKeyRetrieve) {
129 0 0         if (!defined $CanKeyRetrieve) {
130 0           require IO::Socket::INET;
131 0           my $sock = IO::Socket::INET->new(
132             Timeout => $Timeout,
133             PeerAddr => "$KeyServer:$KeyServerPort",
134             );
135 0 0         $CanKeyRetrieve = ($sock ? 1 : 0);
136 0 0         $sock->shutdown(2) if $sock;
137             }
138 0           $AutoKeyRetrieve = $CanKeyRetrieve;
139             }
140              
141 0 0         if (my $version = _has_gpg()) {
    0          
142 0           return _verify_gpg($sigtext, $plaintext, $version);
143             }
144 0           elsif (eval {require Crypt::OpenPGP; 1}) {
  0            
145 0           return _verify_crypt_openpgp($sigtext, $plaintext);
146             }
147             else {
148 0           warn "Cannot use GnuPG or Crypt::OpenPGP, please install either one first!\n";
149 0           return _compare($sigtext, $plaintext, CANNOT_VERIFY);
150             }
151             }
152              
153             sub _has_gpg {
154 0 0   0     my $gpg = _which_gpg() or return;
155 0 0         `$gpg --version` =~ /GnuPG.*?(\S+)\s*$/m or return;
156 0           return $1;
157             }
158              
159             sub _fullcheck {
160 0     0     my $skip = shift;
161 0           my @extra;
162              
163 0           local $^W;
164 0           local $ExtUtils::Manifest::Quiet = 1;
165              
166 0           my($mani, $file);
167 0 0         if( _legacy_extutils() ) {
168 0           my $_maniskip;
169 0 0         if ( _public_maniskip() ) {
170 0           $_maniskip = &ExtUtils::Manifest::maniskip;
171             } else {
172 0           $_maniskip = &ExtUtils::Manifest::_maniskip;
173             }
174              
175             local *ExtUtils::Manifest::_maniskip = sub { sub {
176 0 0         return unless $skip;
177 0           my $ok = $_maniskip->(@_);
178 0 0 0       if ($ok ||= (!-e 'MANIFEST.SKIP' and _default_skip(@_))) {
      0        
179 0           print "Skipping $_\n" for @_;
180 0           push @extra, @_;
181             }
182 0           return $ok;
183 0     0     } };
  0            
184              
185 0           ($mani, $file) = ExtUtils::Manifest::fullcheck();
186             }
187             else {
188 0           my $_maniskip = &ExtUtils::Manifest::maniskip;
189             local *ExtUtils::Manifest::maniskip = sub { sub {
190 0 0         return unless $skip;
191 0           return $_maniskip->(@_);
192 0     0     } };
  0            
193 0           ($mani, $file) = ExtUtils::Manifest::fullcheck();
194             }
195              
196 0           foreach my $makefile ('Makefile', 'Build') {
197             warn "==> SKIPPED CHECKING '$_'!" .
198             (-e "$_.PL" && " (run $_.PL to ensure its integrity)") .
199 0   0       " <===\n" for grep $_ eq $makefile, @extra;
200             }
201              
202 0           @{$mani} = grep {$_ ne 'SIGNATURE'} @{$mani};
  0            
  0            
  0            
203              
204 0           warn "Not in MANIFEST: $_\n" for @{$file};
  0            
205 0           warn "No such file: $_\n" for @{$mani};
  0            
206              
207 0           return ($mani, $file);
208             }
209              
210             sub _legacy_extutils {
211             # ExtUtils::Manifest older than 1.58 does not handle MYMETA.
212 0     0     return (ExtUtils::Manifest->VERSION < 1.58);
213             }
214              
215             sub _public_maniskip {
216             # ExtUtils::Manifest 1.54 onwards have public maniskip
217 0     0     return (ExtUtils::Manifest->VERSION > 1.53);
218             }
219              
220             sub _default_skip {
221 0     0     local $_ = shift;
222 0 0 0       return 1 if /\bRCS\b/ or /\bCVS\b/ or /\B\.svn\b/ or /,v$/
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
223             or /^MANIFEST\.bak/ or /^Makefile$/ or /^blib\//
224             or /^MakeMaker-\d/ or /^pm_to_blib/ or /^blibdirs/
225             or /^_build\// or /^Build$/ or /^pmfiles\.dat/
226             or /^MYMETA\./
227             or /~$/ or /\.old$/ or /\#$/ or /^\.#/;
228             }
229              
230             my $which_gpg;
231             sub _which_gpg {
232             # Cache it so we don't need to keep checking.
233 0 0   0     return $which_gpg if $which_gpg;
234              
235 0           for my $gpg_bin ('gpg', 'gpg2', 'gnupg', 'gnupg2') {
236 0           my $version = `$gpg_bin --version 2>&1`;
237 0 0 0       if( $version && $version =~ /GnuPG/ ) {
238 0           $which_gpg = $gpg_bin;
239 0           return $which_gpg;
240             }
241             }
242             }
243              
244             sub _verify_gpg {
245 0     0     my ($sigtext, $plaintext, $version) = @_;
246              
247 0 0 0       local $SIGNATURE = Win32::GetShortPathName($SIGNATURE)
248             if defined &Win32::GetShortPathName and $SIGNATURE =~ /[^-\w.:~\\\/]/;
249              
250 0           my $keyserver = _keyserver($version);
251              
252 0           require File::Temp;
253 0           my $fh = File::Temp->new();
254 0   0       print $fh $sigtext || _read_sigfile($SIGNATURE);
255 0           close $fh;
256              
257 0           my $gpg = _which_gpg();
258 0 0         my @quiet = $Verbose ? () : qw(-q --logger-fd=1);
259 0 0 0       my @cmd = (
    0          
260             $gpg, qw(--verify --batch --no-tty), @quiet, ($KeyServer ? (
261             "--keyserver=$keyserver",
262             ($AutoKeyRetrieve and $version ge '1.0.7')
263             ? '--keyserver-options=auto-key-retrieve'
264             : ()
265             ) : ()), $fh->filename
266             );
267              
268 0           my $output = '';
269 0 0         if( $Verbose ) {
270 0           warn "Executing @cmd\n";
271 0           system @cmd;
272             }
273             else {
274 0           my $cmd = join ' ', @cmd;
275 0           $output = `$cmd`;
276             }
277 0           unlink $fh->filename;
278              
279 0 0         if( $? ) {
    0          
280 0           print STDERR $output;
281             }
282             elsif ($output =~ /((?: +[\dA-F]{4}){10,})/) {
283 0           warn "WARNING: This key is not certified with a trusted signature!\n";
284 0           warn "Primary key fingerprint:$1\n";
285             }
286              
287 0 0 0       return SIGNATURE_BAD if ($? and $AutoKeyRetrieve);
288 0 0         return _compare($sigtext, $plaintext, (!$?) ? SIGNATURE_OK : CANNOT_VERIFY);
289             }
290              
291             sub _keyserver {
292 0     0     my $version = shift;
293 0           my $scheme = 'x-hkp';
294 0 0         $scheme = 'hkp' if $version ge '1.2.0';
295              
296 0           return "$scheme://$KeyServer:$KeyServerPort";
297             }
298              
299             sub _verify_crypt_openpgp {
300 0     0     my ($sigtext, $plaintext) = @_;
301              
302 0           require Crypt::OpenPGP;
303 0 0         my $pgp = Crypt::OpenPGP->new(
304             ($KeyServer) ? ( KeyServer => $KeyServer, AutoKeyRetrieve => $AutoKeyRetrieve ) : (),
305             );
306 0 0         my $rv = $pgp->handle( Data => $sigtext )
307             or die $pgp->errstr;
308              
309 0 0 0       return SIGNATURE_BAD if (!$rv->{Validity} and $AutoKeyRetrieve);
310              
311 0 0         if ($rv->{Validity}) {
312             warn 'Signature made ', scalar localtime($rv->{Signature}->timestamp),
313 0 0         ' using key ID ', substr(uc(unpack('H*', $rv->{Signature}->key_id)), -8), "\n",
314             "Good signature from \"$rv->{Validity}\"\n" if $Verbose;
315             }
316             else {
317 0           warn "Cannot verify signature; public key not found\n";
318             }
319              
320 0 0         return _compare($sigtext, $plaintext, $rv->{Validity} ? SIGNATURE_OK : CANNOT_VERIFY);
321             }
322              
323             sub _read_sigfile {
324 0     0     my $sigfile = shift;
325 0           my $signature = '';
326 0           my $well_formed;
327              
328 0           local *D;
329 0 0         open D, "< $sigfile" or die "Could not open $sigfile: $!";
330              
331 0 0 0       if ($] >= 5.006 and =~ /\r/) {
332 0           close D;
333 0 0         open D, '<', $sigfile or die "Could not open $sigfile: $!";
334 0           binmode D, ':crlf';
335             } else {
336 0           close D;
337 0 0         open D, "< $sigfile" or die "Could not open $sigfile: $!";
338             }
339              
340 0           my $begin = "-----BEGIN PGP SIGNED MESSAGE-----\n";
341 0           my $end = "-----END PGP SIGNATURE-----\n";
342 0           my $found = 0;
343 0           while () {
344 0 0         if (1 .. ($_ eq $begin)) {
345 0 0 0       if (!$found and /signed via the Module::Signature module, version ([0-9\.]+)\./) {
346 0           $found = 1;
347 0 0         if (eval { require version; version->parse($1) < version->parse("0.82") }) {
  0            
  0            
348 0           $LegacySigFile = 1;
349 0           warn "Old $SIGNATURE detected. Please inform the module author to regenerate " .
350             "$SIGNATURE using Module::Signature version 0.82 or newer.\n";
351             }
352             }
353 0           next;
354             }
355 0           $signature .= $_;
356 0 0         return "$begin$signature" if $_ eq $end;
357             }
358              
359 0           return;
360             }
361              
362             sub _compare {
363 0     0     my ($str1, $str2, $ok) = @_;
364              
365             # normalize all linebreaks
366 0           $str1 =~ s/^-----BEGIN PGP SIGNED MESSAGE-----\n(?:.+\n)*\n//;
367 0           $str1 =~ s/[^\S ]+/\n/g; $str2 =~ s/[^\S ]+/\n/g;
  0            
368 0           $str1 =~ s/-----BEGIN PGP SIGNATURE-----\n(?:.+\n)*$//;
369              
370 0 0         return $ok if $str1 eq $str2;
371              
372 0 0         if (eval { require Text::Diff; 1 }) {
  0            
  0            
373 0           warn "--- $SIGNATURE ".localtime((stat($SIGNATURE))[9])."\n";
374 0           warn '+++ (current) '.localtime()."\n";
375 0           warn Text::Diff::diff( \$str1, \$str2, { STYLE => 'Unified' } );
376             }
377             else {
378 0           local (*D, *S);
379 0 0         open S, "< $SIGNATURE" or die "Could not open $SIGNATURE: $!";
380 0 0         open D, "| diff -u --strip-trailing-cr $SIGNATURE -"
381             or (warn "Could not call diff: $!", return SIGNATURE_MISMATCH);
382 0           while () {
383 0 0         print D $_ if (1 .. /^-----BEGIN PGP SIGNED MESSAGE-----/);
384 0 0         print D if (/^Hash: / .. /^$/);
385 0 0         next if (1 .. /^-----BEGIN PGP SIGNATURE/);
386 0 0         print D $str2, "-----BEGIN PGP SIGNATURE-----\n", $_ and last;
387             }
388 0           print D ;
389 0           close D;
390             }
391              
392 0           return SIGNATURE_MISMATCH;
393             }
394              
395             sub sign {
396 0     0 0   my %args = ( skip => 1, @_ );
397 0           my $overwrite = $args{overwrite};
398 0           my $plaintext = _mkdigest();
399              
400 0           my ($mani, $file) = _fullcheck($args{skip});
401              
402 0 0 0       if (@{$mani} or @{$file}) {
  0            
  0            
403 0           warn "==> MISMATCHED content between MANIFEST and the distribution! <==\n";
404 0           warn "==> Please correct your MANIFEST file and/or delete extra files. <==\n";
405             }
406              
407 0 0 0       if (!$overwrite and -e $SIGNATURE and -t STDIN) {
      0        
408 0           local $/ = "\n";
409 0           print "$SIGNATURE already exists; overwrite [y/N]? ";
410 0 0         return unless =~ /[Yy]/;
411             }
412              
413 0 0         if (my $version = _has_gpg()) {
    0          
414 0           _sign_gpg($SIGNATURE, $plaintext, $version);
415             }
416 0           elsif (eval {require Crypt::OpenPGP; 1}) {
  0            
417 0           _sign_crypt_openpgp($SIGNATURE, $plaintext);
418             }
419             else {
420 0           die 'Cannot use GnuPG or Crypt::OpenPGP, please install either one first!';
421             }
422              
423 0           warn "==> SIGNATURE file created successfully. <==\n";
424 0           return SIGNATURE_OK;
425             }
426              
427             sub _sign_gpg {
428 0     0     my ($sigfile, $plaintext, $version) = @_;
429              
430 0 0 0       die "Could not write to $sigfile"
      0        
431             if -e $sigfile and (-d $sigfile or not -w $sigfile);
432              
433 0           my $gpg = _which_gpg();
434              
435 0           local *D;
436 0           my $set_key = '';
437 0 0         $set_key = qq{--default-key "$AUTHOR"} if($AUTHOR);
438 0 0         open D, "| $gpg $set_key --clearsign --openpgp --personal-digest-preferences RIPEMD160 >> $sigfile.tmp"
439             or die "Could not call $gpg: $!";
440 0           print D $plaintext;
441 0           close D;
442              
443 0 0 0       (-e "$sigfile.tmp" and -s "$sigfile.tmp") or do {
444 0           unlink "$sigfile.tmp";
445 0           die "Cannot find $sigfile.tmp, signing aborted.\n";
446             };
447              
448 0 0         open D, "< $sigfile.tmp" or die "Cannot open $sigfile.tmp: $!";
449              
450 0 0         open S, "> $sigfile" or do {
451 0           unlink "$sigfile.tmp";
452 0           die "Could not write to $sigfile: $!";
453             };
454              
455 0           print S $Preamble;
456 0           print S ;
457              
458 0           close S;
459 0           close D;
460              
461 0           unlink("$sigfile.tmp");
462              
463 0           my $key_id;
464             my $key_name;
465             # This doesn't work because the output from verify goes to STDERR.
466             # If I try to redirect it using "--logger-fd 1" it just hangs.
467             # WTF?
468 0           my @verify = `$gpg --batch --verify $SIGNATURE`;
469 0           while (@verify) {
470 0 0         if (/key ID ([0-9A-F]+)$/) {
    0          
471 0           $key_id = $1;
472             } elsif (/signature from "(.+)"$/) {
473 0           $key_name = $1;
474             }
475             }
476              
477 0           my $found_name;
478             my $found_key;
479 0 0 0       if (defined $key_id && defined $key_name) {
480 0           my $keyserver = _keyserver($version);
481 0           while (`$gpg --batch --keyserver=$keyserver --search-keys '$key_name'`) {
482 0 0         if (/^\(\d+\)/) {
    0          
483 0           $found_name = 0;
484             } elsif ($found_name) {
485 0 0         if (/key \Q$key_id\E/) {
486 0           $found_key = 1;
487 0           last;
488             }
489             }
490              
491 0 0         if (/\Q$key_name\E/) {
492 0           $found_name = 1;
493 0           next;
494             }
495             }
496              
497 0 0         unless ($found_key) {
498 0           _warn_non_public_signature($key_name);
499             }
500             }
501              
502 0           return 1;
503             }
504              
505             sub _sign_crypt_openpgp {
506 0     0     my ($sigfile, $plaintext) = @_;
507              
508 0           require Crypt::OpenPGP;
509 0           my $pgp = Crypt::OpenPGP->new;
510             my $ring = Crypt::OpenPGP::KeyRing->new(
511 0 0         Filename => $pgp->{cfg}->get('SecRing')
512             ) or die $pgp->error(Crypt::OpenPGP::KeyRing->errstr);
513              
514 0           my $uid = '';
515 0 0         $uid = $AUTHOR if($AUTHOR);
516              
517 0           my $kb;
518 0 0         if ($uid) {
519 0 0         $kb = $ring->find_keyblock_by_uid($uid)
520             or die $pgp->error(qq{Can't find '$uid': } . $ring->errstr);
521             }
522             else {
523 0 0         $kb = $ring->find_keyblock_by_index(-1)
524             or die $pgp->error(q{Can't find last keyblock: } . $ring->errstr);
525             }
526              
527 0           my $cert = $kb->signing_key;
528 0           $uid = $cert->uid($kb->primary_uid);
529 0 0         warn "Debug: acquiring signature from $uid\n" if $Debug;
530              
531 0 0         my $signature = $pgp->sign(
532             Data => $plaintext,
533             Detach => 0,
534             Clearsign => 1,
535             Armour => 1,
536             Key => $cert,
537             PassphraseCallback => \&Crypt::OpenPGP::_default_passphrase_cb,
538             ) or die $pgp->errstr;
539              
540 0           local *D;
541 0 0         open D, "> $sigfile" or die "Could not write to $sigfile: $!";
542 0           print D $Preamble;
543 0           print D $signature;
544 0           close D;
545              
546 0           require Crypt::OpenPGP::KeyServer;
547 0           my $server = Crypt::OpenPGP::KeyServer->new(Server => $KeyServer);
548              
549 0 0         unless ($server->find_keyblock_by_keyid($cert->key_id)) {
550 0           _warn_non_public_signature($uid);
551             }
552              
553 0           return 1;
554             }
555              
556             sub _warn_non_public_signature {
557 0     0     my $uid = shift;
558              
559 0           warn <<"EOF"
560             You have signed this distribution with a key ($uid) that cannot be
561             found on the public key server at $KeyServer.
562              
563             This will probably cause signature verification to fail if your module
564             is distributed on CPAN.
565             EOF
566             }
567              
568             sub _mkdigest {
569 0 0   0     my $digest = _mkdigest_files(@_) or return;
570 0           my $plaintext = '';
571              
572 0           foreach my $file (sort keys %$digest) {
573 0 0         next if $file eq $SIGNATURE;
574 0           $plaintext .= "@{$digest->{$file}} $file\n";
  0            
575             }
576              
577 0           return $plaintext;
578             }
579              
580             sub _digest_object {
581 0     0     my($algorithm) = @_;
582              
583             # Avoid loading Digest::* from relative paths in @INC.
584 0           local @INC = grep { File::Spec->file_name_is_absolute($_) } @INC;
  0            
585              
586             # Constrain algorithm name to be of form ABC123.
587 0 0         my ($base, $variant) = ($algorithm =~ /^([_a-zA-Z]+)([0-9]+)$/g)
588             or die "Malformed algorithm name: $algorithm (should match /\\w+\\d+/)";
589              
590             my $obj = eval { Digest->new($algorithm) } || eval {
591             require "Digest/$base.pm"; "Digest::$base"->new($variant)
592             } || eval {
593             require "Digest/$algorithm.pm"; "Digest::$algorithm"->new
594             } || eval {
595             require "Digest/$base/PurePerl.pm"; "Digest::$base\::PurePerl"->new($variant)
596             } || eval {
597             require "Digest/$algorithm/PurePerl.pm"; "Digest::$algorithm\::PurePerl"->new
598 0 0         } or do { eval {
599 0           warn "Unknown cipher: $algorithm, please install Digest::$base, Digest::$base$variant, or Digest::$base\::PurePerl\n";
600 0 0 0       } and return } or do {
      0        
601 0           warn "Unknown cipher: $algorithm, please install Digest::$algorithm\n"; return;
  0            
602             };
603 0           $obj;
604             }
605              
606             sub _mkdigest_files {
607 0     0     my $verify_map = shift;
608 0   0       my $dosnames = (defined(&Dos::UseLFN) && Dos::UseLFN()==0);
609 0   0       my $read = ExtUtils::Manifest::maniread() || {};
610 0           my $found = ExtUtils::Manifest::manifind();
611 0           my(%digest) = ();
612 0           my($default_obj) = _digest_object($Cipher);
613 0           FILE: foreach my $file (sort keys %$read){
614 0 0         next FILE if $file eq $SIGNATURE;
615 0           my($obj,$this_cipher,$this_hexdigest,$verify_digest);
616 0 0         if ($verify_map) {
617 0 0         if (my $vmf = $verify_map->{$file}) {
618 0           ($this_cipher,$verify_digest) = @$vmf;
619 0 0         if ($this_cipher eq $Cipher) {
620 0           $obj = $default_obj;
621             } else {
622 0           $obj = _digest_object($this_cipher);
623             }
624             } else {
625 0           $this_cipher = $Cipher;
626 0           $obj = $default_obj;
627             }
628             } else {
629 0           $this_cipher = $Cipher;
630 0           $obj = $default_obj;
631             }
632 0 0         warn "Debug: collecting digest from $file\n" if $Debug;
633 0 0         if ($dosnames){
634 0           $file = lc $file;
635 0           $file =~ s!(\.(\w|-)+)!substr ($1,0,4)!ge;
  0            
636 0           $file =~ s!((\w|-)+)!substr ($1,0,8)!ge;
  0            
637             }
638 0 0         unless ( exists $found->{$file} ) {
639 0 0         warn "No such file: $file\n" if $Verbose;
640             }
641             else {
642 0           local *F;
643 0 0         open F, "< $file" or die "Cannot open $file for reading: $!";
644 0 0         if ($LegacySigFile) {
645 0 0         if (-B $file) {
646 0           binmode(F);
647 0           $obj->addfile(*F);
648 0           $this_hexdigest = $obj->hexdigest;
649             }
650             else {
651             # Normalize by hand...
652 0           local $/;
653 0           binmode(F);
654 0           my $input = ;
655 0           VERIFYLOOP: for my $eol ("","\015\012","\012") {
656 0           my $lax_input = $input;
657 0 0         if (! length $eol) {
658             # first try is binary
659             } else {
660 0           my @lines = split /$eol/, $input, -1;
661 0 0         if (grep /[\015\012]/, @lines) {
662             # oops, apparently not a text file, treat as binary, forget @lines
663             } else {
664 0 0         my $other_eol = $eol eq "\012" ? "\015\012" : "\012";
665 0           $lax_input = join $other_eol, @lines;
666             }
667             }
668 0           $obj->add($lax_input);
669 0           $this_hexdigest = $obj->hexdigest;
670 0 0         if ($verify_digest) {
671 0 0         if ($this_hexdigest eq $verify_digest) {
672 0           last VERIFYLOOP;
673             }
674 0           $obj->reset;
675             } else {
676 0           last VERIFYLOOP;
677             }
678             }
679             }
680             } else {
681 0 0         binmode(F, ((-B $file) ? ':raw' : ':crlf'));
682 0           $obj->addfile(*F);
683 0           $this_hexdigest = $obj->hexdigest;
684             }
685 0           $digest{$file} = [$this_cipher, $this_hexdigest];
686 0           $obj->reset;
687             }
688             }
689              
690 0           return \%digest;
691             }
692              
693             1;
694              
695             __END__