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