File Coverage

blib/lib/Parse/PMFile.pm
Criterion Covered Total %
statement 314 476 65.9
branch 138 240 57.5
condition 54 143 37.7
subroutine 32 41 78.0
pod 2 2 100.0
total 540 902 59.8


line stmt bran cond sub pod time code
1             package Parse::PMFile;
2              
3 134     134   18454 sub __clean_eval { eval $_[0] } # needs to be here (RT#101273)
4              
5 63     63   4200212 use strict;
  63         644  
  63         1830  
6 63     63   340 use warnings;
  63         112  
  63         1481  
7 63     63   33532 use Safe;
  63         2376417  
  63         3180  
8 63     63   46174 use JSON::PP ();
  63         918224  
  63         1902  
9 63     63   32326 use Dumpvalue;
  63         298455  
  63         2098  
10 63     63   26625 use version ();
  63         118269  
  63         1705  
11 63     63   479 use File::Spec ();
  63         118  
  63         72200  
12              
13             our $VERSION = '0.44';
14             our $VERBOSE = 0;
15             our $ALLOW_DEV_VERSION = 0;
16             our $FORK = 0;
17             our $UNSAFE = $] < 5.010000 ? 1 : 0;
18              
19             sub new {
20 237     237 1 565495 my ($class, $meta, $opts) = @_;
21 237 100       651 bless {%{ $opts || {} }, META_CONTENT => $meta}, $class;
  237         2891  
22             }
23              
24             # from PAUSE::pmfile::examine_fio
25             sub parse {
26 238     238 1 8840 my ($self, $pmfile) = @_;
27              
28 238         784 $pmfile =~ s|\\|/|g;
29              
30 238         4477 my($filemtime) = (stat $pmfile)[9];
31 238         1480 $self->{MTIME} = $filemtime;
32 238         774 $self->{PMFILE} = $pmfile;
33              
34 238 100       825 unless ($self->_version_from_meta_ok) {
35 232         449 my $version;
36 232 50       476 unless (eval { $version = $self->_parse_version; 1 }) {
  232         726  
  195         1145  
37 0         0 $self->_verbose(1, "error with version in $pmfile: $@");
38 0         0 return;
39             }
40              
41 195         1456 $self->{VERSION} = $version;
42 195 50 66     3362 if ($self->{VERSION} =~ /^\{.*\}$/) {
    100 100        
43             # JSON error message
44             } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
45 5         48 return;
46             }
47             }
48              
49 196         2029 my($ppp) = $self->_packages_per_pmfile;
50 196         2711 my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
51 196         1960 $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 196         807 my ($package, %errors);
59 196         0 my %checked_in;
60 196         1042 DBPACK: foreach $package (@keys_ppp) {
61             # this part is taken from PAUSE::package::examine_pkg
62             # and PAUSE::package::_pkg_name_insane
63 196 50 33     8061 if ($package !~ /^\w[\w\:\']*\w?\z/
      33        
      33        
      33        
      33        
64             || $package !~ /\w\z/
65             || $package =~ /:/ && $package !~ /::/
66             || $package =~ /\w:\w/
67             || $package =~ /:::/
68             ){
69 0         0 $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
70 0         0 delete $ppp->{$package};
71 0         0 next;
72             }
73              
74 196 0 33     878 if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
      0        
75 0         0 delete $ppp->{$package};
76 0         0 next;
77             }
78              
79             # Check that package name matches case of file name
80             {
81 196         351 my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2;
  196         1353  
82 196 100       788 if ($module) {
83 6         33 $module =~ s{\.pm\z}{};
84 6         35 $module =~ s{/}{::}g;
85              
86 6 50 33     73 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 0         0 };
92             }
93             }
94             }
95              
96 196         613 my $pp = $ppp->{$package};
97 196 50 66     2000 if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
98 0         0 my $err = JSON::PP::decode_json($pp->{version});
99 0 0       0 if ($err->{x_normalize}) {
    0          
100             $errors{$package} = {
101             normalize => $err->{version},
102             infile => $pp->{infile},
103 0         0 };
104 0         0 $pp->{version} = "undef";
105             } elsif ($err->{openerr}) {
106 0         0 $pp->{version} = "undef";
107 0         0 $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 0         0 };
115             } else {
116 0         0 $pp->{version} = "undef";
117 0         0 $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 0         0 };
133             }
134             }
135              
136             # Sanity checks
137              
138 196         836 for (
139             $package,
140             $pp->{version},
141             ) {
142 392 50 66     4074 if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
      66        
143 4         14 delete $ppp->{$package};
144 4         12 next; # don't screw up 02packages
145             }
146             }
147 196 100       1350 unless ($self->_version_ok($pp)) {
148             $errors{$package} = {
149             long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"},
150             infile => $pp->{infile},
151 3         27 };
152 3         10 next;
153             }
154 193         932 $checked_in{$package} = $ppp->{$package};
155             } # end foreach package
156              
157 196 100 66     2583 return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
158             }
159              
160             sub _version_ok {
161 196     196   669 my ($self, $pp) = @_;
162 196 100 100     1037 return if length($pp->{version} || 0) > 16;
163 193         636 return 1
164             }
165              
166             sub _perm_check {
167 0     0   0 my ($self, $package) = @_;
168 0         0 my $userid = $self->{USERID};
169 0         0 my $module = $self->{PERMISSIONS}->module_permissions($package);
170 0 0       0 return 1 if !$module; # not listed yet
171 0 0 0     0 return 1 if defined $module->m && $module->m eq $userid;
172 0 0 0     0 return 1 if defined $module->f && $module->f eq $userid;
173 0 0 0     0 return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c};
  0         0  
  0         0  
174 0         0 return;
175             }
176              
177             # from PAUSE::pmfile;
178             sub _parse_version {
179 232     232   902 my $self = shift;
180              
181 63     63   560 use strict;
  63         166  
  63         24844  
182              
183 232         601 my $pmfile = $self->{PMFILE};
184 232         13470 my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
185              
186 232         839 my $pmcp = $pmfile;
187 232         757 for ($pmcp) {
188 232         982 s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
189             # solution to escape @s and \
190             }
191 232         386 my($v);
192             {
193              
194 232         364 package main; # seems necessary
195              
196             # XXX: do we need to fork as PAUSE does?
197             # or, is alarm() just fine?
198 232         367 my $pid;
199 232 100 66     2035 if ($self->{FORK} || $FORK) {
200 115         123250 $pid = fork();
201 115 50       9743 die "Can't fork: $!" unless defined $pid;
202             }
203 232 100       3016 if ($pid) {
204 78         35318768 waitpid($pid, 0);
205 78 50       23820 if (open my $fh, '<', $tmpfile) {
206 78         14657 $v = <$fh>;
207             }
208             } else {
209             # XXX Limit Resources too
210              
211 154         1028 my $comp;
212 154         1712 my $eval = qq{
213             local(\$^W) = 0;
214             Parse::PMFile::_parse_version_safely("$pmcp");
215             };
216 154 50 33     2905 unless ($self->{UNSAFE} || $UNSAFE) {
217 154         7558 $comp = Safe->new;
218 154         311844 $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
219 154         3034 $comp->share("*Parse::PMFile::_parse_version_safely");
220 154         22022 $comp->share("*version::new");
221 154         10096 $comp->share("*version::numify");
222 154         10352 $comp->share_from('main', ['*version::',
223             '*charstar::',
224             '*Exporter::',
225             '*DynaLoader::']);
226 154         236118 $comp->share_from('version', ['&qv']);
227 154         9194 $comp->permit(":base_math"); # atan2 (Acme-Pi)
228             # $comp->permit("require"); # no strict!
229 154         2467 $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
230             }
231              
232 154 50 33     5754 version->import('qv') if $self->{UNSAFE} || $UNSAFE;
233             {
234 63     63   512 no strict;
  63         219  
  63         19306  
  154         917  
235 154 50       2712 $v = $comp ? $comp->reval($eval) : eval $eval;
236             }
237 154 100       173279 if ($@){ # still in the child process, out of Safe::reval
238 21         117 my $err = $@;
239             # warn ">>>>>>>err[$err]<<<<<<<<";
240 21 50       157 if (ref $err) {
241 21 50       408 if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
242 21         129 local($^W) = 0;
243 21         172 my ($sigil, $vstr) = ($1, $3);
244 21 50       536 $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/;
245 21 50       130 $v = $comp ? $comp->reval($vstr) : eval $vstr;
246 21 50 33     22771 $v = $$v if $sigil eq '*' && ref $v;
247             }
248 21 50 33     321 if ($@ or !$v) {
249 0         0 $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]",
250             JSON::PP::encode_json($err),
251             $eval,
252             ));
253 0         0 $v = JSON::PP::encode_json($err);
254             }
255             } else {
256 0         0 $v = JSON::PP::encode_json({ openerr => $err });
257             }
258             }
259 154 50       1258 if (defined $v) {
260 63     63   535 no warnings;
  63         233  
  63         19139  
261 154 100       2490 $v = $v->numify if ref($v) =~ /^version(::vpp)?$/;
262             } else {
263 0         0 $v = "";
264             }
265 154 100 66     3458 if ($self->{FORK} || $FORK) {
266 37         6325 open my $fh, '>:utf8', $tmpfile;
267 37         695 print $fh $v;
268 37         3147 exit 0;
269             } else {
270 117         675 utf8::encode($v);
271             # undefine empty $v as if read from the tmpfile
272 117 50 33     1130 $v = undef if defined $v && !length $v;
273 117 50       964 $comp->erase if ($comp);
274 117         128784 $self->_restore_overloaded_stuff;
275             }
276             }
277             }
278 195 100 66     27472 unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile;
      66        
279              
280 195         3489 return $self->_normalize_version($v);
281             }
282              
283             sub _restore_overloaded_stuff {
284 138     138   715 my ($self, $used_version_in_safe) = @_;
285 138 50 33     2191 return if $self->{UNSAFE} || $UNSAFE;
286              
287 63     63   542 no strict 'refs';
  63         175  
  63         2212  
288 63     63   393 no warnings 'redefine';
  63         916  
  63         66210  
289              
290             # version XS in CPAN
291 138         660 my $restored;
292 138 50       890 if ($INC{'version/vxs.pm'}) {
293 0         0 *{'version::(""'} = \&version::vxs::stringify;
  0         0  
294 0         0 *{'version::(0+'} = \&version::vxs::numify;
  0         0  
295 0         0 *{'version::(cmp'} = \&version::vxs::VCMP;
  0         0  
296 0         0 *{'version::(<=>'} = \&version::vxs::VCMP;
  0         0  
297 0         0 *{'version::(bool'} = \&version::vxs::boolean;
  0         0  
298 0         0 $restored = 1;
299             }
300             # version PP in CPAN
301 138 50       727 if ($INC{'version/vpp.pm'}) {
302             {
303 0         0 package # hide from PAUSE
304             charstar;
305 0         0 overload->import;
306             }
307 0 0       0 if (!$used_version_in_safe) {
308             package # hide from PAUSE
309             version::vpp;
310 0         0 overload->import;
311             }
312 0 0       0 unless ($restored) {
313 0         0 *{'version::(""'} = \&version::vpp::stringify;
  0         0  
314 0         0 *{'version::(0+'} = \&version::vpp::numify;
  0         0  
315 0         0 *{'version::(cmp'} = \&version::vpp::vcmp;
  0         0  
316 0         0 *{'version::(<=>'} = \&version::vpp::vcmp;
  0         0  
317 0         0 *{'version::(bool'} = \&version::vpp::vbool;
  0         0  
318             }
319 0         0 *{'version::vpp::(""'} = \&version::vpp::stringify;
  0         0  
320 0         0 *{'version::vpp::(0+'} = \&version::vpp::numify;
  0         0  
321 0         0 *{'version::vpp::(cmp'} = \&version::vpp::vcmp;
  0         0  
322 0         0 *{'version::vpp::(<=>'} = \&version::vpp::vcmp;
  0         0  
323 0         0 *{'version::vpp::(bool'} = \&version::vpp::vbool;
  0         0  
324 0         0 *{'charstar::(""'} = \&charstar::thischar;
  0         0  
325 0         0 *{'charstar::(0+'} = \&charstar::thischar;
  0         0  
326 0         0 *{'charstar::(++'} = \&charstar::increment;
  0         0  
327 0         0 *{'charstar::(--'} = \&charstar::decrement;
  0         0  
328 0         0 *{'charstar::(+'} = \&charstar::plus;
  0         0  
329 0         0 *{'charstar::(-'} = \&charstar::minus;
  0         0  
330 0         0 *{'charstar::(*'} = \&charstar::multiply;
  0         0  
331 0         0 *{'charstar::(cmp'} = \&charstar::cmp;
  0         0  
332 0         0 *{'charstar::(<=>'} = \&charstar::spaceship;
  0         0  
333 0         0 *{'charstar::(bool'} = \&charstar::thischar;
  0         0  
334 0         0 *{'charstar::(='} = \&charstar::clone;
  0         0  
335 0         0 $restored = 1;
336             }
337             # version in core
338 138 50       657 if (!$restored) {
339 138         583 *{'version::(""'} = \&version::stringify;
  138         816  
340 138         428 *{'version::(0+'} = \&version::numify;
  138         717  
341 138         417 *{'version::(cmp'} = \&version::vcmp;
  138         445  
342 138         317 *{'version::(<=>'} = \&version::vcmp;
  138         385  
343 138         285 *{'version::(bool'} = \&version::boolean;
  138         979  
344             }
345             }
346              
347             # from PAUSE::pmfile;
348             sub _packages_per_pmfile {
349 196     196   641 my $self = shift;
350              
351 196         676 my $ppp = {};
352 196         722 my $pmfile = $self->{PMFILE};
353 196         626 my $filemtime = $self->{MTIME};
354 196         637 my $version = $self->{VERSION};
355              
356 196 50       11081 open my $fh, "<", "$pmfile" or return $ppp;
357              
358 196         2969 local $/ = "\n";
359 196         819 my $inpod = 0;
360              
361 196         5998 PLINE: while (<$fh>) {
362 5706         9008 chomp;
363 5706         9887 my($pline) = $_;
364 5706 50       13721 $inpod = $pline =~ /^=(?!cut)/ ? 1 :
    50          
365             $pline =~ /^=cut/ ? 0 : $inpod;
366 5706 50       9967 next if $inpod;
367 5706 50       11491 next if substr($pline,0,4) eq "=cut";
368              
369 5706         10254 $pline =~ s/\#.*//;
370 5706 100       17875 next if $pline =~ /^\s*$/;
371 4504 100 66     9697 if ($pline =~ /^__(?:END|DATA)__\b/
372             and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
373             ){
374 9         33 last PLINE;
375             }
376              
377 4495         6573 my $pkg;
378             my $strict_version;
379              
380 4495 100       29784 if (
381             $pline =~ m{
382             # (.*) # takes too much time if $pline is long
383             #(?
384             ^[\s\{;]*
385             \b(?:package|class|role)\s+
386             ([\w\:\']+)
387             \s*
388             (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
389             }x) {
390 205         1374 $pkg = $1;
391 205         629 $strict_version = $2;
392 205 50       824 if ($pkg eq "DB"){
393             # XXX if pumpkin and perl make him comaintainer! I
394             # think I always made the pumpkins comaint on DB
395             # without further ado (?)
396 0         0 next PLINE;
397             }
398             }
399              
400 4495 100       14800 if ($pkg) {
401             # Found something
402              
403             # from package
404 205         700 $pkg =~ s/\'/::/g;
405 205 50       1317 next PLINE unless $pkg =~ /^[A-Za-z]/;
406 205 50       1551 next PLINE unless $pkg =~ /\w$/;
407 205 100       844 next PLINE if $pkg eq "main";
408             # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
409             # database for modid in mods, package in packages, package in perms
410             # alter table mods modify modid varchar(128) binary NOT NULL default '';
411             # alter table packages modify package varchar(128) binary NOT NULL default '';
412 199 50       733 next PLINE if length($pkg) > 128;
413             #restriction
414 199         1840 $ppp->{$pkg}{parsed}++;
415 199         1160 $ppp->{$pkg}{infile} = $pmfile;
416 199 100       1383 if ($self->_simile($pmfile,$pkg)) {
417 193         906 $ppp->{$pkg}{simile} = $pmfile;
418 193 100       844 if ($self->_version_from_meta_ok) {
419 6         13 my $provides = $self->{META_CONTENT}{provides};
420 6 50       29 if (exists $provides->{$pkg}) {
421 6 50       57 if (defined $provides->{$pkg}{version}) {
422 6         16 my $v = $provides->{$pkg}{version};
423 6 100 33     102 if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
      66        
424 4         38 next PLINE;
425             }
426              
427 2 50       16 unless (eval { $version = $self->_normalize_version($v); 1 }) {
  2         12  
  2         12  
428 0         0 $self->_verbose(1, "error with version in $pmfile: $@");
429 0         0 next;
430              
431             }
432 2         15 $ppp->{$pkg}{version} = $version;
433             } else {
434 0         0 $ppp->{$pkg}{version} = "undef";
435             }
436             }
437             } else {
438 187 100       643 if (defined $strict_version){
439 19         169 $ppp->{$pkg}{version} = $strict_version ;
440             } else {
441 168 50       1081 $ppp->{$pkg}{version} = defined $version ? $version : "";
442             }
443 63     63   497 no warnings;
  63         134  
  63         15001  
444 187 100       730 if ($version eq 'undef') {
445 19 50       110 $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
446             } else {
447             $ppp->{$pkg}{version} =
448             $version
449             if $version
450             > $ppp->{$pkg}{version} ||
451             $version
452 168 50 33     2129 gt $ppp->{$pkg}{version};
453             }
454             }
455             } else { # not simile
456             #### it comes later, it would be nonsense
457             #### to set to "undef". MM_Unix gives us
458             #### the best we can reasonably consider
459             $ppp->{$pkg}{version} =
460             $version
461             unless defined $ppp->{$pkg}{version} &&
462 6 50 33     23 length($ppp->{$pkg}{version});
463             }
464 195         1329 $ppp->{$pkg}{filemtime} = $filemtime;
465             } else {
466             # $self->_verbose(2,"no pkg found");
467             }
468             }
469              
470 196         2849 close $fh;
471 196         2788 $ppp;
472             }
473              
474             # from PAUSE::pmfile;
475             {
476 63     63   465 no strict;
  63         140  
  63         30289  
477             sub _parse_version_safely {
478 154     154   79959 my($parsefile) = @_;
479 154         480 my $result;
480 154         586 local *FH;
481 154         1905 local $/ = "\n";
482 154 50       10571 open(FH,$parsefile) or die "Could not open '$parsefile': $!";
483 154         1317 my $inpod = 0;
484 154         6074 while () {
485 437 50       3009 $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
    50          
486 437 50 33     3937 next if $inpod || /^\s*#/;
487 437 100       1661 last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer
488 434         1064 chop;
489              
490 434 100       2283 if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) {
491             # XXX: should handle this better if version is bogus -- rjbs,
492             # 2014-03-16
493 6 100       54 return $ver if version::is_lax($ver);
494             }
495              
496             # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
497 431 100       4174 next unless /(?<=])\=(?![=>])/;
498 134         557 my $current_parsed_line = $_;
499 134         2236 my $eval = qq{
500             package #
501             ExtUtils::MakeMaker::_version;
502              
503             local $1$2;
504             \$$2=undef; do {
505             $_
506             }; \$$2
507             };
508 134         1247 local $^W = 0;
509 134     0   2491 local $SIG{__WARN__} = sub {};
510 134         1464 $result = __clean_eval($eval);
511             # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
512 134 100 66     1714 if ($@ or !defined $result){
513 21         1285 die +{
514             eval => $eval,
515             line => $current_parsed_line,
516             file => $parsefile,
517             err => $@,
518             };
519             }
520 113         919 last;
521             } #;
522 130         2443 close FH;
523              
524 130 100       826 $result = "undef" unless defined $result;
525 130 100       571 if ((ref $result) =~ /^version(?:::vpp)?\b/) {
526 63     63   497 no warnings;
  63         228  
  63         52728  
527 6         65 $result = $result->numify;
528             }
529 130         3609 return $result;
530             }
531             }
532              
533             # from PAUSE::pmfile;
534             sub _filter_ppps {
535 196     196   1075 my($self,@ppps) = @_;
536 196         464 my @res;
537              
538             # very similar code is in PAUSE::dist::filter_pms
539 196         1159 MANI: for my $ppp ( @ppps ) {
540 199 100       1006 if ($self->{META_CONTENT}){
541             my $no_index = $self->{META_CONTENT}{no_index}
542 9   66     71 || $self->{META_CONTENT}{private}; # backward compat
543 9 100       40 if (ref($no_index) eq 'HASH') {
544 3         45 my %map = (
545             package => qr{\z},
546             namespace => qr{::},
547             );
548 3         14 for my $k (qw(package namespace)) {
549 3 50       14 next unless my $v = $no_index->{$k};
550 3         10 my $rest = $map{$k};
551 3 50       28 if (ref $v eq "ARRAY") {
552 3         11 for my $ve (@$v) {
553 3         12 $ve =~ s|::$||;
554 3 50       54 if ($ppp =~ /^$ve$rest/){
555 3         26 $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
556 3         40 next MANI;
557             } else {
558 0         0 $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
559             }
560             }
561             } else {
562 0         0 $v =~ s|::$||;
563 0 0       0 if ($ppp =~ /^$v$rest/){
564 0         0 $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
565 0         0 next MANI;
566             } else {
567 0         0 $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
568             }
569             }
570             }
571             } else {
572 6         17 $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
573             }
574             } else {
575             # $self->_verbose(1,"no META_CONTENT"); # too noisy
576             }
577 196         932 push @res, $ppp;
578             }
579 196         1517 $self->_verbose(1,"Result of filter_ppps: res[@res]");
580 196         926 @res;
581             }
582              
583             # from PAUSE::pmfile;
584             sub _simile {
585 199     199   1211 my($self,$file,$package) = @_;
586             # MakeMaker gives them the chance to have the file Simple.pm in
587             # this directory but have the package HTML::Simple in it.
588             # Afaik, they wouldn't be able to do so with deeper nested packages
589 199         1960 $file =~ s|.*/||;
590 199         2170 $file =~ s|\.pm(?:\.PL)?||;
591 199         2936 my $ret = $package =~ m/\b\Q$file\E$/;
592 199   100     790 $ret ||= 0;
593 199 100       773 unless ($ret) {
594             # Apache::mod_perl_guide stuffs it into Version.pm
595 6 50       28 $ret = 1 if lc $file eq 'version';
596             }
597 199         1647 $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
598 199         933 $ret;
599             }
600              
601             # from PAUSE::pmfile
602             sub _normalize_version {
603 197     197   1871 my($self,$v) = @_;
604 197 50       1295 $v = "undef" unless defined $v;
605 197         5000 my $dv = Dumpvalue->new;
606 197         18032 my $sdv = $dv->stringify($v,1); # second argument prevents ticks
607 197         11650 $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
608              
609 197 100       1463 return $v if $v eq "undef";
610 178 50       2144 return $v if $v =~ /^\{.*\}$/; # JSON object
611 178         2493 $v =~ s/^\s+//;
612 178         1158 $v =~ s/\s+\z//;
613 178 100       1562 if ($v =~ /_/) {
614             # XXX should pass something like EDEVELOPERRELEASE up e.g.
615             # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
616             # such modules and the mesage was not helpful that "nothing
617             # was found".
618 10         128 return $v ;
619             }
620 168 50       2489 if (!version::is_lax($v)) {
621 0         0 return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v });
622             }
623             # may warn "Integer overflow"
624 63     63   542 my $vv = eval { no warnings; version->new($v)->numify };
  63         136  
  63         6541  
  168         11495  
  168         6037  
625 168 50       1357 if ($@) {
626             # warn "$v: $@";
627 0         0 return JSON::PP::encode_json({ x_normalize => $@, version => $v });
628             # return "undef";
629             }
630 168 100       1160 if ($vv eq $v) {
631             # the boring 3.14
632             } else {
633 141         1021 my $forced = $self->_force_numeric($v);
634 141 50       1049 if ($forced eq $vv) {
    50          
635             } elsif ($forced =~ /^v(.+)/) {
636             # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
637 63     63   434 no warnings;
  63         158  
  63         96425  
638 0         0 $vv = version->new($1)->numify;
639             } else {
640             # warn "Unequal forced[$forced] and vv[$vv]";
641 141 50       1128 if ($forced == $vv) {
642             # the trailing zeroes would cause unnecessary havoc
643 141         440 $vv = $forced;
644             }
645             }
646             }
647 168         2731 return $vv;
648             }
649              
650             # from PAUSE::pmfile;
651             sub _force_numeric {
652 141     141   1056 my($self,$v) = @_;
653 141         1311 $v = $self->_readable($v);
654              
655 141 50 33     3558 if (
      33        
656             $v =~
657             /^(\+?)(\d*)(\.(\d*))?/ &&
658             # "$2$4" ne ''
659             (
660             defined $2 && length $2
661             ||
662             defined $4 && length $4
663             )
664             ) {
665 141 50       998 my $two = defined $2 ? $2 : "";
666 141 50       750 my $three = defined $3 ? $3 : "";
667 141         443 $v = "$two$three";
668             }
669             # no else branch! We simply say, everything else is a string.
670 141         499 $v;
671             }
672              
673             # from PAUSE::dist
674             sub _version_from_meta_ok {
675 431     431   1467 my($self) = @_;
676 431 100       1970 return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
677 237         639 my $c = $self->{META_CONTENT};
678              
679             # If there's no provides hash, we can't get our module versions from the
680             # provides hash! -- rjbs, 2012-03-31
681 237 100       1466 return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
682              
683             # Some versions of Module::Build geneated an empty provides hash. If we're
684             # *not* looking at a Module::Build-generated metafile, then it's okay.
685 6 50       50 my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
686 6 50       47 return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
687              
688             # ??? I don't know why this is here.
689 0 0       0 return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
690              
691 0 0 0     0 if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
  0   0     0  
692             # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
693             # did not find the reason why this happened, but let's not go
694             # overboard, 0.26 seems a good threshold from the statistics: there
695             # are not many empty provides hashes from 0.26 up.
696 0         0 return($self->{VERSION_FROM_META_OK} = 0);
697             }
698              
699             # We're not in the suspect range of M::B versions. It's good to go.
700 0         0 return($self->{VERSION_FROM_META_OK} = 1);
701             }
702              
703             sub _verbose {
704 797     797   2500 my($self,$level,@what) = @_;
705 797 50 33     8370 warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE);
706             }
707              
708             # all of the following methods are stripped from CPAN::Version
709             # (as of version 5.5001, bundled in CPAN 2.03), and slightly
710             # modified (ie. made private, as well as CPAN->debug(...) are
711             # replaced with $self->_verbose(9, ...).)
712              
713             # CPAN::Version::vcmp courtesy Jost Krieger
714             sub _vcmp {
715 0     0   0 my($self,$l,$r) = @_;
716 0         0 local($^W) = 0;
717 0         0 $self->_verbose(9, "l[$l] r[$r]");
718              
719 0 0       0 return 0 if $l eq $r; # short circuit for quicker success
720              
721 0         0 for ($l,$r) {
722 0         0 s/_//g;
723             }
724 0         0 $self->_verbose(9, "l[$l] r[$r]");
725 0         0 for ($l,$r) {
726 0 0 0     0 next unless tr/.// > 1 || /^v/;
727 0         0 s/^v?/v/;
728 0         0 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
729             }
730 0         0 $self->_verbose(9, "l[$l] r[$r]");
731 0 0       0 if ($l=~/^v/ <=> $r=~/^v/) {
732 0         0 for ($l,$r) {
733 0 0       0 next if /^v/;
734 0         0 $_ = $self->_float2vv($_);
735             }
736             }
737 0         0 $self->_verbose(9, "l[$l] r[$r]");
738 0         0 my $lvstring = "v0";
739 0         0 my $rvstring = "v0";
740 0 0 0     0 if ($] >= 5.006
      0        
741             && $l =~ /^v/
742             && $r =~ /^v/) {
743 0         0 $lvstring = $self->_vstring($l);
744 0         0 $rvstring = $self->_vstring($r);
745 0         0 $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring);
746             }
747              
748             return (
749 0   0     0 ($l ne "undef") <=> ($r ne "undef")
750             ||
751             $lvstring cmp $rvstring
752             ||
753             $l <=> $r
754             ||
755             $l cmp $r
756             );
757             }
758              
759             sub _vgt {
760 0     0   0 my($self,$l,$r) = @_;
761 0         0 $self->_vcmp($l,$r) > 0;
762             }
763              
764             sub _vlt {
765 0     0   0 my($self,$l,$r) = @_;
766 0         0 $self->_vcmp($l,$r) < 0;
767             }
768              
769             sub _vge {
770 0     0   0 my($self,$l,$r) = @_;
771 0         0 $self->_vcmp($l,$r) >= 0;
772             }
773              
774             sub _vle {
775 0     0   0 my($self,$l,$r) = @_;
776 0         0 $self->_vcmp($l,$r) <= 0;
777             }
778              
779             sub _vstring {
780 0     0   0 my($self,$n) = @_;
781 0 0       0 $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";
782 0         0 pack "U*", split /\./, $n;
783             }
784              
785             # vv => visible vstring
786             sub _float2vv {
787 0     0   0 my($self,$n) = @_;
788 0         0 my($rev) = int($n);
789 0   0     0 $rev ||= 0;
790 0         0 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
791             # architecture influence
792 0   0     0 $mantissa ||= 0;
793 0         0 $mantissa .= "0" while length($mantissa)%3;
794 0         0 my $ret = "v" . $rev;
795 0         0 while ($mantissa) {
796 0 0       0 $mantissa =~ s/(\d{1,3})// or
797             die "Panic: length>0 but not a digit? mantissa[$mantissa]";
798 0         0 $ret .= ".".int($1);
799             }
800             # warn "n[$n]ret[$ret]";
801 0         0 $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
802 0         0 $ret;
803             }
804              
805             sub _readable {
806 141     141   713 my($self,$n) = @_;
807 141         1284 $n =~ /^([\w\-\+\.]+)/;
808              
809 141 50 33     2845 return $1 if defined $1 && length($1)>0;
810             # if the first user reaches version v43, he will be treated as "+".
811             # We'll have to decide about a new rule here then, depending on what
812             # will be the prevailing versioning behavior then.
813              
814 0 0         if ($] < 5.006) { # or whenever v-strings were introduced
815             # we get them wrong anyway, whatever we do, because 5.005 will
816             # have already interpreted 0.2.4 to be "0.24". So even if he
817             # indexer sends us something like "v0.2.4" we compare wrongly.
818              
819             # And if they say v1.2, then the old perl takes it as "v12"
820              
821 0           $self->_verbose(9, "Suspicious version string seen [$n]\n");
822 0           return $n;
823             }
824 0           my $better = sprintf "v%vd", $n;
825 0           $self->_verbose(9, "n[$n] better[$better]");
826 0           return $better;
827             }
828              
829             1;
830              
831             __END__