1package Parse::PMFile; 2 3sub __clean_eval { eval $_[0] } # needs to be here (RT#101273) 4 5use strict; 6use warnings; 7use Safe; 8use JSON::PP (); 9use Dumpvalue; 10use version (); 11use File::Spec (); 12 13our $VERSION = '0.36'; 14our $VERBOSE = 0; 15our $ALLOW_DEV_VERSION = 0; 16our $FORK = 0; 17our $UNSAFE = $] < 5.010000 ? 1 : 0; 18 19sub new { 20 my ($class, $meta, $opts) = @_; 21 bless {%{ $opts || {} }, META_CONTENT => $meta}, $class; 22} 23 24# from PAUSE::pmfile::examine_fio 25sub parse { 26 my ($self, $pmfile) = @_; 27 28 $pmfile =~ s|\\|/|g; 29 30 my($filemtime) = (stat $pmfile)[9]; 31 $self->{MTIME} = $filemtime; 32 $self->{PMFILE} = $pmfile; 33 34 unless ($self->_version_from_meta_ok) { 35 my $version; 36 unless (eval { $version = $self->_parse_version; 1 }) { 37 $self->_verbose(1, "error with version in $pmfile: $@"); 38 return; 39 } 40 41 $self->{VERSION} = $version; 42 if ($self->{VERSION} =~ /^\{.*\}$/) { 43 # JSON error message 44 } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" 45 return; 46 } 47 } 48 49 my($ppp) = $self->_packages_per_pmfile; 50 my @keys_ppp = $self->_filter_ppps(sort keys %$ppp); 51 $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n"); 52 53 # 54 # Immediately after each package (pmfile) examined contact 55 # the database 56 # 57 58 my ($package, %errors); 59 my %checked_in; 60 DBPACK: foreach $package (@keys_ppp) { 61 # this part is taken from PAUSE::package::examine_pkg 62 # and PAUSE::package::_pkg_name_insane 63 if ($package !~ /^\w[\w\:\']*\w?\z/ 64 || $package !~ /\w\z/ 65 || $package =~ /:/ && $package !~ /::/ 66 || $package =~ /\w:\w/ 67 || $package =~ /:::/ 68 ){ 69 $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check"); 70 delete $ppp->{$package}; 71 next; 72 } 73 74 if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) { 75 delete $ppp->{$package}; 76 next; 77 } 78 79 # Check that package name matches case of file name 80 { 81 my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2; 82 if ($module) { 83 $module =~ s{\.pm\z}{}; 84 $module =~ s{/}{::}g; 85 86 if (lc $module eq lc $package && $module ne $package) { 87 # warn "/// $self->{PMFILE} vs. $module vs. $package\n"; 88 $errors{$package} = { 89 indexing_warning => "Capitalization of package ($package) does not match filename!", 90 infile => $self->{PMFILE}, 91 }; 92 } 93 } 94 } 95 96 my $pp = $ppp->{$package}; 97 if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error 98 my $err = JSON::PP::decode_json($pp->{version}); 99 if ($err->{x_normalize}) { 100 $errors{$package} = { 101 normalize => $err->{version}, 102 infile => $pp->{infile}, 103 }; 104 $pp->{version} = "undef"; 105 } elsif ($err->{openerr}) { 106 $pp->{version} = "undef"; 107 $self->_verbose(1, 108 qq{Parse::PMFile was not able to 109 read the file. It issued the following error: C< $err->{r} >}, 110 ); 111 $errors{$package} = { 112 open => $err->{r}, 113 infile => $pp->{infile}, 114 }; 115 } else { 116 $pp->{version} = "undef"; 117 $self->_verbose(1, 118 qq{Parse::PMFile was not able to 119 parse the following line in that file: C< $err->{line} > 120 121 Note: the indexer is running in a Safe compartement and cannot 122 provide the full functionality of perl in the VERSION line. It 123 is trying hard, but sometime it fails. As a workaround, please 124 consider writing a META.yml that contains a 'provides' 125 attribute or contact the CPAN admins to investigate (yet 126 another) workaround against "Safe" limitations.)}, 127 128 ); 129 $errors{$package} = { 130 parse_version => $err->{line}, 131 infile => $err->{file}, 132 }; 133 } 134 } 135 136 # Sanity checks 137 138 for ( 139 $package, 140 $pp->{version}, 141 ) { 142 if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here 143 delete $ppp->{$package}; 144 next; # don't screw up 02packages 145 } 146 } 147 $checked_in{$package} = $ppp->{$package}; 148 } # end foreach package 149 150 return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in; 151} 152 153sub _perm_check { 154 my ($self, $package) = @_; 155 my $userid = $self->{USERID}; 156 my $module = $self->{PERMISSIONS}->module_permissions($package); 157 return 1 if !$module; # not listed yet 158 return 1 if defined $module->m && $module->m eq $userid; 159 return 1 if defined $module->f && $module->f eq $userid; 160 return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c}; 161 return; 162} 163 164# from PAUSE::pmfile; 165sub _parse_version { 166 my $self = shift; 167 168 use strict; 169 170 my $pmfile = $self->{PMFILE}; 171 my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000)); 172 173 my $pmcp = $pmfile; 174 for ($pmcp) { 175 s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the 176 # solution to escape @s and \ 177 } 178 my($v); 179 { 180 181 package main; # seems necessary 182 183 # XXX: do we need to fork as PAUSE does? 184 # or, is alarm() just fine? 185 my $pid; 186 if ($self->{FORK} || $FORK) { 187 $pid = fork(); 188 die "Can't fork: $!" unless defined $pid; 189 } 190 if ($pid) { 191 waitpid($pid, 0); 192 if (open my $fh, '<', $tmpfile) { 193 $v = <$fh>; 194 } 195 } else { 196 # XXX Limit Resources too 197 198 my($comp) = Safe->new; 199 my $eval = qq{ 200 local(\$^W) = 0; 201 Parse::PMFile::_parse_version_safely("$pmcp"); 202 }; 203 $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz 204 $comp->share("*Parse::PMFile::_parse_version_safely"); 205 $comp->share("*version::new"); 206 $comp->share("*version::numify"); 207 $comp->share_from('main', ['*version::', 208 '*charstar::', 209 '*Exporter::', 210 '*DynaLoader::']); 211 $comp->share_from('version', ['&qv']); 212 $comp->permit(":base_math"); # atan2 (Acme-Pi) 213 # $comp->permit("require"); # no strict! 214 $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample 215 216 version->import('qv') if $self->{UNSAFE} || $UNSAFE; 217 { 218 no strict; 219 $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval); 220 } 221 if ($@){ # still in the child process, out of Safe::reval 222 my $err = $@; 223 # warn ">>>>>>>err[$err]<<<<<<<<"; 224 if (ref $err) { 225 if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) { 226 local($^W) = 0; 227 my ($sigil, $vstr) = ($1, $3); 228 $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/; 229 $v = ($self->{UNSAFE} || $UNSAFE) ? eval $vstr : $comp->reval($vstr); 230 $v = $$v if $sigil eq '*' && ref $v; 231 } 232 if ($@ or !$v) { 233 $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]", 234 JSON::PP::encode_json($err), 235 $eval, 236 )); 237 $v = JSON::PP::encode_json($err); 238 } 239 } else { 240 $v = JSON::PP::encode_json({ openerr => $err }); 241 } 242 } 243 if (defined $v) { 244 $v = $v->numify if ref($v) =~ /^version(::vpp)?$/; 245 } else { 246 $v = ""; 247 } 248 if ($self->{FORK} || $FORK) { 249 open my $fh, '>:utf8', $tmpfile; 250 print $fh $v; 251 exit 0; 252 } else { 253 utf8::encode($v); 254 # undefine empty $v as if read from the tmpfile 255 $v = undef if defined $v && !length $v; 256 $comp->erase; 257 $self->_restore_overloaded_stuff; 258 } 259 } 260 } 261 unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile; 262 263 return $self->_normalize_version($v); 264} 265 266sub _restore_overloaded_stuff { 267 my ($self, $used_version_in_safe) = @_; 268 return if $self->{UNSAFE} || $UNSAFE; 269 270 no strict 'refs'; 271 no warnings 'redefine'; 272 273 # version XS in CPAN 274 my $restored; 275 if ($INC{'version/vxs.pm'}) { 276 *{'version::(""'} = \&version::vxs::stringify; 277 *{'version::(0+'} = \&version::vxs::numify; 278 *{'version::(cmp'} = \&version::vxs::VCMP; 279 *{'version::(<=>'} = \&version::vxs::VCMP; 280 *{'version::(bool'} = \&version::vxs::boolean; 281 $restored = 1; 282 } 283 # version PP in CPAN 284 if ($INC{'version/vpp.pm'}) { 285 { 286 package # hide from PAUSE 287 charstar; 288 overload->import; 289 } 290 if (!$used_version_in_safe) { 291 package # hide from PAUSE 292 version::vpp; 293 overload->import; 294 } 295 unless ($restored) { 296 *{'version::(""'} = \&version::vpp::stringify; 297 *{'version::(0+'} = \&version::vpp::numify; 298 *{'version::(cmp'} = \&version::vpp::vcmp; 299 *{'version::(<=>'} = \&version::vpp::vcmp; 300 *{'version::(bool'} = \&version::vpp::vbool; 301 } 302 *{'version::vpp::(""'} = \&version::vpp::stringify; 303 *{'version::vpp::(0+'} = \&version::vpp::numify; 304 *{'version::vpp::(cmp'} = \&version::vpp::vcmp; 305 *{'version::vpp::(<=>'} = \&version::vpp::vcmp; 306 *{'version::vpp::(bool'} = \&version::vpp::vbool; 307 *{'charstar::(""'} = \&charstar::thischar; 308 *{'charstar::(0+'} = \&charstar::thischar; 309 *{'charstar::(++'} = \&charstar::increment; 310 *{'charstar::(--'} = \&charstar::decrement; 311 *{'charstar::(+'} = \&charstar::plus; 312 *{'charstar::(-'} = \&charstar::minus; 313 *{'charstar::(*'} = \&charstar::multiply; 314 *{'charstar::(cmp'} = \&charstar::cmp; 315 *{'charstar::(<=>'} = \&charstar::spaceship; 316 *{'charstar::(bool'} = \&charstar::thischar; 317 *{'charstar::(='} = \&charstar::clone; 318 $restored = 1; 319 } 320 # version in core 321 if (!$restored) { 322 *{'version::(""'} = \&version::stringify; 323 *{'version::(0+'} = \&version::numify; 324 *{'version::(cmp'} = \&version::vcmp; 325 *{'version::(<=>'} = \&version::vcmp; 326 *{'version::(bool'} = \&version::boolean; 327 } 328} 329 330# from PAUSE::pmfile; 331sub _packages_per_pmfile { 332 my $self = shift; 333 334 my $ppp = {}; 335 my $pmfile = $self->{PMFILE}; 336 my $filemtime = $self->{MTIME}; 337 my $version = $self->{VERSION}; 338 339 open my $fh, "<", "$pmfile" or return $ppp; 340 341 local $/ = "\n"; 342 my $inpod = 0; 343 344 PLINE: while (<$fh>) { 345 chomp; 346 my($pline) = $_; 347 $inpod = $pline =~ /^=(?!cut)/ ? 1 : 348 $pline =~ /^=cut/ ? 0 : $inpod; 349 next if $inpod; 350 next if substr($pline,0,4) eq "=cut"; 351 352 $pline =~ s/\#.*//; 353 next if $pline =~ /^\s*$/; 354 if ($pline =~ /^__(?:END|DATA)__\b/ 355 and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__ 356 ){ 357 last PLINE; 358 } 359 360 my $pkg; 361 my $strict_version; 362 363 if ( 364 $pline =~ m{ 365 # (.*) # takes too much time if $pline is long 366 (?<![*\$\\@%&]) # no sigils 367 \bpackage\s+ 368 ([\w\:\']+) 369 \s* 370 (?: $ | [\}\;] | \{ | \s+($version::STRICT) ) 371 }x) { 372 $pkg = $1; 373 $strict_version = $2; 374 if ($pkg eq "DB"){ 375 # XXX if pumpkin and perl make him comaintainer! I 376 # think I always made the pumpkins comaint on DB 377 # without further ado (?) 378 next PLINE; 379 } 380 } 381 382 if ($pkg) { 383 # Found something 384 385 # from package 386 $pkg =~ s/\'/::/; 387 next PLINE unless $pkg =~ /^[A-Za-z]/; 388 next PLINE unless $pkg =~ /\w$/; 389 next PLINE if $pkg eq "main"; 390 # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg 391 # database for modid in mods, package in packages, package in perms 392 # alter table mods modify modid varchar(128) binary NOT NULL default ''; 393 # alter table packages modify package varchar(128) binary NOT NULL default ''; 394 next PLINE if length($pkg) > 128; 395 #restriction 396 $ppp->{$pkg}{parsed}++; 397 $ppp->{$pkg}{infile} = $pmfile; 398 if ($self->_simile($pmfile,$pkg)) { 399 $ppp->{$pkg}{simile} = $pmfile; 400 if ($self->_version_from_meta_ok) { 401 my $provides = $self->{META_CONTENT}{provides}; 402 if (exists $provides->{$pkg}) { 403 if (defined $provides->{$pkg}{version}) { 404 my $v = $provides->{$pkg}{version}; 405 if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" 406 next PLINE; 407 } 408 409 unless (eval { $version = $self->_normalize_version($v); 1 }) { 410 $self->_verbose(1, "error with version in $pmfile: $@"); 411 next; 412 413 } 414 $ppp->{$pkg}{version} = $version; 415 } else { 416 $ppp->{$pkg}{version} = "undef"; 417 } 418 } 419 } else { 420 if (defined $strict_version){ 421 $ppp->{$pkg}{version} = $strict_version ; 422 } else { 423 $ppp->{$pkg}{version} = defined $version ? $version : ""; 424 } 425 no warnings; 426 if ($version eq 'undef') { 427 $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version}; 428 } else { 429 $ppp->{$pkg}{version} = 430 $version 431 if $version 432 > $ppp->{$pkg}{version} || 433 $version 434 gt $ppp->{$pkg}{version}; 435 } 436 } 437 } else { # not simile 438 #### it comes later, it would be nonsense 439 #### to set to "undef". MM_Unix gives us 440 #### the best we can reasonably consider 441 $ppp->{$pkg}{version} = 442 $version 443 unless defined $ppp->{$pkg}{version} && 444 length($ppp->{$pkg}{version}); 445 } 446 $ppp->{$pkg}{filemtime} = $filemtime; 447 } else { 448 # $self->_verbose(2,"no pkg found"); 449 } 450 } 451 452 close $fh; 453 $ppp; 454} 455 456# from PAUSE::pmfile; 457{ 458 no strict; 459 sub _parse_version_safely { 460 my($parsefile) = @_; 461 my $result; 462 local *FH; 463 local $/ = "\n"; 464 open(FH,$parsefile) or die "Could not open '$parsefile': $!"; 465 my $inpod = 0; 466 while (<FH>) { 467 $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; 468 next if $inpod || /^\s*#/; 469 last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer 470 chop; 471 472 if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) { 473 # XXX: should handle this better if version is bogus -- rjbs, 474 # 2014-03-16 475 return $ver if version::is_lax($ver); 476 } 477 478 # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; 479 next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/; 480 my $current_parsed_line = $_; 481 my $eval = qq{ 482 package # 483 ExtUtils::MakeMaker::_version; 484 485 local $1$2; 486 \$$2=undef; do { 487 $_ 488 }; \$$2 489 }; 490 local $^W = 0; 491 local $SIG{__WARN__} = sub {}; 492 $result = __clean_eval($eval); 493 # warn "current_parsed_line[$current_parsed_line]\$\@[$@]"; 494 if ($@ or !defined $result){ 495 die +{ 496 eval => $eval, 497 line => $current_parsed_line, 498 file => $parsefile, 499 err => $@, 500 }; 501 } 502 last; 503 } #; 504 close FH; 505 506 $result = "undef" unless defined $result; 507 if ((ref $result) =~ /^version(?:::vpp)?\b/) { 508 $result = $result->numify; 509 } 510 return $result; 511 } 512} 513 514# from PAUSE::pmfile; 515sub _filter_ppps { 516 my($self,@ppps) = @_; 517 my @res; 518 519 # very similar code is in PAUSE::dist::filter_pms 520 MANI: for my $ppp ( @ppps ) { 521 if ($self->{META_CONTENT}){ 522 my $no_index = $self->{META_CONTENT}{no_index} 523 || $self->{META_CONTENT}{private}; # backward compat 524 if (ref($no_index) eq 'HASH') { 525 my %map = ( 526 package => qr{\z}, 527 namespace => qr{::}, 528 ); 529 for my $k (qw(package namespace)) { 530 next unless my $v = $no_index->{$k}; 531 my $rest = $map{$k}; 532 if (ref $v eq "ARRAY") { 533 for my $ve (@$v) { 534 $ve =~ s|::$||; 535 if ($ppp =~ /^$ve$rest/){ 536 $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]"); 537 next MANI; 538 } else { 539 $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]"); 540 } 541 } 542 } else { 543 $v =~ s|::$||; 544 if ($ppp =~ /^$v$rest/){ 545 $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]"); 546 next MANI; 547 } else { 548 $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]"); 549 } 550 } 551 } 552 } else { 553 $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT"); 554 } 555 } else { 556 # $self->_verbose(1,"no META_CONTENT"); # too noisy 557 } 558 push @res, $ppp; 559 } 560 $self->_verbose(1,"Result of filter_ppps: res[@res]"); 561 @res; 562} 563 564# from PAUSE::pmfile; 565sub _simile { 566 my($self,$file,$package) = @_; 567 # MakeMaker gives them the chance to have the file Simple.pm in 568 # this directory but have the package HTML::Simple in it. 569 # Afaik, they wouldn't be able to do so with deeper nested packages 570 $file =~ s|.*/||; 571 $file =~ s|\.pm(?:\.PL)?||; 572 my $ret = $package =~ m/\b\Q$file\E$/; 573 $ret ||= 0; 574 unless ($ret) { 575 # Apache::mod_perl_guide stuffs it into Version.pm 576 $ret = 1 if lc $file eq 'version'; 577 } 578 $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n"); 579 $ret; 580} 581 582# from PAUSE::pmfile 583sub _normalize_version { 584 my($self,$v) = @_; 585 $v = "undef" unless defined $v; 586 my $dv = Dumpvalue->new; 587 my $sdv = $dv->stringify($v,1); # second argument prevents ticks 588 $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n"); 589 590 return $v if $v eq "undef"; 591 return $v if $v =~ /^\{.*\}$/; # JSON object 592 $v =~ s/^\s+//; 593 $v =~ s/\s+\z//; 594 if ($v =~ /_/) { 595 # XXX should pass something like EDEVELOPERRELEASE up e.g. 596 # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one 597 # such modules and the mesage was not helpful that "nothing 598 # was found". 599 return $v ; 600 } 601 if (!version::is_lax($v)) { 602 return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v }); 603 } 604 # may warn "Integer overflow" 605 my $vv = eval { no warnings; version->new($v)->numify }; 606 if ($@) { 607 # warn "$v: $@"; 608 return JSON::PP::encode_json({ x_normalize => $@, version => $v }); 609 # return "undef"; 610 } 611 if ($vv eq $v) { 612 # the boring 3.14 613 } else { 614 my $forced = $self->_force_numeric($v); 615 if ($forced eq $vv) { 616 } elsif ($forced =~ /^v(.+)/) { 617 # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz) 618 $vv = version->new($1)->numify; 619 } else { 620 # warn "Unequal forced[$forced] and vv[$vv]"; 621 if ($forced == $vv) { 622 # the trailing zeroes would cause unnecessary havoc 623 $vv = $forced; 624 } 625 } 626 } 627 return $vv; 628} 629 630# from PAUSE::pmfile; 631sub _force_numeric { 632 my($self,$v) = @_; 633 $v = $self->_readable($v); 634 635 if ( 636 $v =~ 637 /^(\+?)(\d*)(\.(\d*))?/ && 638 # "$2$4" ne '' 639 ( 640 defined $2 && length $2 641 || 642 defined $4 && length $4 643 ) 644 ) { 645 my $two = defined $2 ? $2 : ""; 646 my $three = defined $3 ? $3 : ""; 647 $v = "$two$three"; 648 } 649 # no else branch! We simply say, everything else is a string. 650 $v; 651} 652 653# from PAUSE::dist 654sub _version_from_meta_ok { 655 my($self) = @_; 656 return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK}; 657 my $c = $self->{META_CONTENT}; 658 659 # If there's no provides hash, we can't get our module versions from the 660 # provides hash! -- rjbs, 2012-03-31 661 return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides}; 662 663 # Some versions of Module::Build geneated an empty provides hash. If we're 664 # *not* looking at a Module::Build-generated metafile, then it's okay. 665 my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/; 666 return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v; 667 668 # ??? I don't know why this is here. 669 return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0'; 670 671 if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) { 672 # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron 673 # did not find the reason why this happened, but let's not go 674 # overboard, 0.26 seems a good threshold from the statistics: there 675 # are not many empty provides hashes from 0.26 up. 676 return($self->{VERSION_FROM_META_OK} = 0); 677 } 678 679 # We're not in the suspect range of M::B versions. It's good to go. 680 return($self->{VERSION_FROM_META_OK} = 1); 681} 682 683sub _verbose { 684 my($self,$level,@what) = @_; 685 warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE); 686} 687 688# all of the following methods are stripped from CPAN::Version 689# (as of version 5.5001, bundled in CPAN 2.03), and slightly 690# modified (ie. made private, as well as CPAN->debug(...) are 691# replaced with $self->_verbose(9, ...).) 692 693# CPAN::Version::vcmp courtesy Jost Krieger 694sub _vcmp { 695 my($self,$l,$r) = @_; 696 local($^W) = 0; 697 $self->_verbose(9, "l[$l] r[$r]"); 698 699 return 0 if $l eq $r; # short circuit for quicker success 700 701 for ($l,$r) { 702 s/_//g; 703 } 704 $self->_verbose(9, "l[$l] r[$r]"); 705 for ($l,$r) { 706 next unless tr/.// > 1 || /^v/; 707 s/^v?/v/; 708 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group 709 } 710 $self->_verbose(9, "l[$l] r[$r]"); 711 if ($l=~/^v/ <=> $r=~/^v/) { 712 for ($l,$r) { 713 next if /^v/; 714 $_ = $self->_float2vv($_); 715 } 716 } 717 $self->_verbose(9, "l[$l] r[$r]"); 718 my $lvstring = "v0"; 719 my $rvstring = "v0"; 720 if ($] >= 5.006 721 && $l =~ /^v/ 722 && $r =~ /^v/) { 723 $lvstring = $self->_vstring($l); 724 $rvstring = $self->_vstring($r); 725 $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring); 726 } 727 728 return ( 729 ($l ne "undef") <=> ($r ne "undef") 730 || 731 $lvstring cmp $rvstring 732 || 733 $l <=> $r 734 || 735 $l cmp $r 736 ); 737} 738 739sub _vgt { 740 my($self,$l,$r) = @_; 741 $self->_vcmp($l,$r) > 0; 742} 743 744sub _vlt { 745 my($self,$l,$r) = @_; 746 $self->_vcmp($l,$r) < 0; 747} 748 749sub _vge { 750 my($self,$l,$r) = @_; 751 $self->_vcmp($l,$r) >= 0; 752} 753 754sub _vle { 755 my($self,$l,$r) = @_; 756 $self->_vcmp($l,$r) <= 0; 757} 758 759sub _vstring { 760 my($self,$n) = @_; 761 $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]"; 762 pack "U*", split /\./, $n; 763} 764 765# vv => visible vstring 766sub _float2vv { 767 my($self,$n) = @_; 768 my($rev) = int($n); 769 $rev ||= 0; 770 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit 771 # architecture influence 772 $mantissa ||= 0; 773 $mantissa .= "0" while length($mantissa)%3; 774 my $ret = "v" . $rev; 775 while ($mantissa) { 776 $mantissa =~ s/(\d{1,3})// or 777 die "Panic: length>0 but not a digit? mantissa[$mantissa]"; 778 $ret .= ".".int($1); 779 } 780 # warn "n[$n]ret[$ret]"; 781 $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0 782 $ret; 783} 784 785sub _readable { 786 my($self,$n) = @_; 787 $n =~ /^([\w\-\+\.]+)/; 788 789 return $1 if defined $1 && length($1)>0; 790 # if the first user reaches version v43, he will be treated as "+". 791 # We'll have to decide about a new rule here then, depending on what 792 # will be the prevailing versioning behavior then. 793 794 if ($] < 5.006) { # or whenever v-strings were introduced 795 # we get them wrong anyway, whatever we do, because 5.005 will 796 # have already interpreted 0.2.4 to be "0.24". So even if he 797 # indexer sends us something like "v0.2.4" we compare wrongly. 798 799 # And if they say v1.2, then the old perl takes it as "v12" 800 801 $self->_verbose(9, "Suspicious version string seen [$n]\n"); 802 return $n; 803 } 804 my $better = sprintf "v%vd", $n; 805 $self->_verbose(9, "n[$n] better[$better]"); 806 return $better; 807} 808 8091; 810 811__END__ 812 813=head1 NAME 814 815Parse::PMFile - parses .pm file as PAUSE does 816 817=head1 SYNOPSIS 818 819 use Parse::PMFile; 820 821 my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1}); 822 my $packages_info = $parser->parse($pmfile); 823 824 # if you need info about invalid versions 825 my ($packages_info, $errors) = $parser->parse($pmfile); 826 827 # to check permissions 828 my $parser = Parse::PMFile->new($metadata, { 829 USERID => 'ISHIGAKI', 830 PERMISSIONS => PAUSE::Permissions->new, 831 }); 832 833=head1 DESCRIPTION 834 835The most of the code of this module is taken from the PAUSE code as of April 2013 almost verbatim. Thus, the heart of this module should be quite stable. However, I made it not to use pipe ("-|") as well as I stripped database-related code. If you encounter any issue, that's most probably because of my modification. 836 837This module doesn't provide features to extract a distribution or parse meta files intentionally. 838 839=head1 METHODS 840 841=head2 new 842 843creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are: 844 845=over 4 846 847=item ALLOW_DEV_VERSION 848 849Parse::PMFile usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis. 850 851=item VERBOSE 852 853Set this to true if you need to know some details. 854 855=item FORK 856 857As of version 0.17, Parse::PMFile stops forking while parsing a version for better performance. Parse::PMFile should return the same result no matter how this option is set, but if you do care, set this to true to fork as PAUSE does. 858 859=item USERID, PERMISSIONS 860 861As of version 0.21, Parse::PMFile checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L<PAUSE::Permissions>) are provided. Unauthorized packages are removed. 862 863=item UNSAFE 864 865Parse::PMFile usually parses a module version in a Safe compartment. However, this approach doesn't work smoothly under older perls (prior to 5.10) plus some combinations of recent versions of Safe.pm (2.24 and above) and version.pm (0.9905 and above) for various reasons. As of version 0.27, Parse::PMFile simply uses C<eval> to parse a version under older perls. If you want it to use always C<eval> (even under recent perls), set this to true. 866 867=back 868 869=head2 parse 870 871takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file. 872 873=head1 SEE ALSO 874 875L<Parse::LocalDistribution>, L<PAUSE::Permissions> 876 877Most part of this module is derived from PAUSE and CPAN::Version. 878 879L<https://github.com/andk/pause> 880 881L<https://github.com/andk/cpanpm> 882 883=head1 AUTHOR 884 885Andreas Koenig E<lt>andreas.koenig@anima.deE<gt> 886 887Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt> 888 889=head1 COPYRIGHT AND LICENSE 890 891Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code. 892 893Copyright 2013 by Kenichi Ishigaki for some. 894 895This program is free software; you can redistribute it and/or 896modify it under the same terms as Perl itself. 897 898=cut 899