path: root/lib/Parse/PMFile.pm

package Parse::PMFile;

sub __clean_eval { eval $_[0] } # needs to be here (RT#101273)

use strict;
use warnings;
use Safe;
use JSON::PP ();
use Dumpvalue;
use version ();
use File::Spec ();

our $VERSION = '0.41';
our $VERBOSE = 0;
our $ALLOW_DEV_VERSION = 0;
our $FORK = 0;
our $UNSAFE = $] < 5.010000 ? 1 : 0;

sub new {
    my ($class, $meta, $opts) = @_;
    bless {%{ $opts || {} }, META_CONTENT => $meta}, $class;
}

# from PAUSE::pmfile::examine_fio
sub parse {
    my ($self, $pmfile) = @_;

    $pmfile =~ s|\\|/|g;

    my($filemtime) = (stat $pmfile)[9];
    $self->{MTIME} = $filemtime;
    $self->{PMFILE} = $pmfile;

    unless ($self->_version_from_meta_ok) {
        my $version;
        unless (eval { $version = $self->_parse_version; 1 }) {
          $self->_verbose(1, "error with version in $pmfile: $@");
          return;
        }

        $self->{VERSION} = $version;
        if ($self->{VERSION} =~ /^\{.*\}$/) {
            # JSON error message
        } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){   # ignore developer releases and "You suck!"
            return;
        }
    }

    my($ppp) = $self->_packages_per_pmfile;
    my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
    $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");

    #
    # Immediately after each package (pmfile) examined contact
    # the database
    #

    my ($package, %errors);
    my %checked_in;
  DBPACK: foreach $package (@keys_ppp) {
        # this part is taken from PAUSE::package::examine_pkg
        # and PAUSE::package::_pkg_name_insane
        if ($package !~ /^\w[\w\:\']*\w?\z/
         || $package !~ /\w\z/
         || $package =~ /:/ && $package !~ /::/
         || $package =~ /\w:\w/
         || $package =~ /:::/
        ){
            $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
            delete $ppp->{$package};
            next;
        }

        if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
            delete $ppp->{$package};
            next;
        }

        # Check that package name matches case of file name
        {
          my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2;
          if ($module) {
            $module =~ s{\.pm\z}{};
            $module =~ s{/}{::}g;

            if (lc $module eq lc $package && $module ne $package) {
              # warn "/// $self->{PMFILE} vs. $module vs. $package\n";
              $errors{$package} = {
                indexing_warning => "Capitalization of package ($package) does not match filename!",
                infile => $self->{PMFILE},
              };
            }
          }
        }

        my $pp = $ppp->{$package};
        if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
            my $err = JSON::PP::decode_json($pp->{version});
            if ($err->{x_normalize}) {
                $errors{$package} = {
                    normalize => $err->{version},
                    infile => $pp->{infile},
                };
                $pp->{version} = "undef";
            } elsif ($err->{openerr}) {
                $pp->{version} = "undef";
                $self->_verbose(1,
                              qq{Parse::PMFile was not able to
        read the file. It issued the following error: C< $err->{r} >},
                              );
                $errors{$package} = {
                    open => $err->{r},
                    infile => $pp->{infile},
                };
            } else {
                $pp->{version} = "undef";
                $self->_verbose(1, 
                              qq{Parse::PMFile was not able to
        parse the following line in that file: C< $err->{line} >

        Note: the indexer is running in a Safe compartement and cannot
        provide the full functionality of perl in the VERSION line. It
        is trying hard, but sometime it fails. As a workaround, please
        consider writing a META.yml that contains a 'provides'
        attribute or contact the CPAN admins to investigate (yet
        another) workaround against "Safe" limitations.)},

                              );
                $errors{$package} = {
                    parse_version => $err->{line},
                    infile => $err->{file},
                };
            }
        }

        # Sanity checks

        for (
            $package,
            $pp->{version},
        ) {
            if (!defined || /^\s*$/ || /\s/){  # for whatever reason I come here
                delete $ppp->{$package};
                next;            # don't screw up 02packages
            }
        }
        unless ($self->_version_ok($pp)) {
            $errors{$package} = {
                long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"},
                infile => $pp->{infile},
            };
            next;
        }
        $checked_in{$package} = $ppp->{$package};
    }                       # end foreach package

    return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
}

sub _version_ok {
    my ($self, $pp) = @_;
    return if length($pp->{version} || 0) > 16;
    return 1
}

sub _perm_check {
    my ($self, $package) = @_;
    my $userid = $self->{USERID};
    my $module = $self->{PERMISSIONS}->module_permissions($package);
    return 1 if !$module; # not listed yet
    return 1 if defined $module->m && $module->m eq $userid;
    return 1 if defined $module->f && $module->f eq $userid;
    return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c};
    return;
}

# from PAUSE::pmfile;
sub _parse_version {
    my $self = shift;

    use strict;

    my $pmfile = $self->{PMFILE};
    my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));

    my $pmcp = $pmfile;
    for ($pmcp) {
        s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
        # solution to escape @s and \
    }
    my($v);
    {

        package main; # seems necessary

        # XXX: do we need to fork as PAUSE does?
        # or, is alarm() just fine?
        my $pid;
        if ($self->{FORK} || $FORK) {
            $pid = fork();
            die "Can't fork: $!" unless defined $pid;
        }
        if ($pid) {
            waitpid($pid, 0);
            if (open my $fh, '<', $tmpfile) {
                $v = <$fh>;
            }
        } else {
            # XXX Limit Resources too

            my($comp) = Safe->new;
            my $eval = qq{
                local(\$^W) = 0;
                Parse::PMFile::_parse_version_safely("$pmcp");
            };
            $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
            $comp->share("*Parse::PMFile::_parse_version_safely");
            $comp->share("*version::new");
            $comp->share("*version::numify");
            $comp->share_from('main', ['*version::',
                                        '*charstar::',
                                        '*Exporter::',
                                        '*DynaLoader::']);
            $comp->share_from('version', ['&qv']);
            $comp->permit(":base_math"); # atan2 (Acme-Pi)
            # $comp->permit("require"); # no strict!
            $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample

            version->import('qv') if $self->{UNSAFE} || $UNSAFE;
            {
                no strict;
                $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval);
            }
            if ($@){ # still in the child process, out of Safe::reval
                my $err = $@;
                # warn ">>>>>>>err[$err]<<<<<<<<";
                if (ref $err) {
                    if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
                        local($^W) = 0;
                        my ($sigil, $vstr) = ($1, $3);
                        $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/;
                        $v = ($self->{UNSAFE} || $UNSAFE) ? eval $vstr : $comp->reval($vstr);
                        $v = $$v if $sigil eq '*' && ref $v;
                    }
                    if ($@ or !$v) {
                        $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]",
                                      JSON::PP::encode_json($err),
                                      $eval,
                                    ));
                        $v = JSON::PP::encode_json($err);
                    }
                } else {
                    $v = JSON::PP::encode_json({ openerr => $err });
                }
            }
            if (defined $v) {
                no warnings;
                $v = $v->numify if ref($v) =~ /^version(::vpp)?$/;
            } else {
                $v = "";
            }
            if ($self->{FORK} || $FORK) {
                open my $fh, '>:utf8', $tmpfile;
                print $fh $v;
                exit 0;
            } else {
                utf8::encode($v);
                # undefine empty $v as if read from the tmpfile
                $v = undef if defined $v && !length $v;
                $comp->erase;
                $self->_restore_overloaded_stuff;
            }
        }
    }
    unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile;

    return $self->_normalize_version($v);
}

sub _restore_overloaded_stuff {
    my ($self, $used_version_in_safe) = @_;
    return if $self->{UNSAFE} || $UNSAFE;

    no strict 'refs';
    no warnings 'redefine';

    # version XS in CPAN
    my $restored;
    if ($INC{'version/vxs.pm'}) {
        *{'version::(""'} = \&version::vxs::stringify;
        *{'version::(0+'} = \&version::vxs::numify;
        *{'version::(cmp'} = \&version::vxs::VCMP;
        *{'version::(<=>'} = \&version::vxs::VCMP;
        *{'version::(bool'} = \&version::vxs::boolean;
        $restored = 1;
    }
    # version PP in CPAN
    if ($INC{'version/vpp.pm'}) {
        {
            package # hide from PAUSE
                charstar;
            overload->import;
        }
        if (!$used_version_in_safe) {
            package # hide from PAUSE
                version::vpp;
            overload->import;
        }
        unless ($restored) {
            *{'version::(""'} = \&version::vpp::stringify;
            *{'version::(0+'} = \&version::vpp::numify;
            *{'version::(cmp'} = \&version::vpp::vcmp;
            *{'version::(<=>'} = \&version::vpp::vcmp;
            *{'version::(bool'} = \&version::vpp::vbool;
        }
        *{'version::vpp::(""'} = \&version::vpp::stringify;
        *{'version::vpp::(0+'} = \&version::vpp::numify;
        *{'version::vpp::(cmp'} = \&version::vpp::vcmp;
        *{'version::vpp::(<=>'} = \&version::vpp::vcmp;
        *{'version::vpp::(bool'} = \&version::vpp::vbool;
        *{'charstar::(""'} = \&charstar::thischar;
        *{'charstar::(0+'} = \&charstar::thischar;
        *{'charstar::(++'} = \&charstar::increment;
        *{'charstar::(--'} = \&charstar::decrement;
        *{'charstar::(+'} = \&charstar::plus;
        *{'charstar::(-'} = \&charstar::minus;
        *{'charstar::(*'} = \&charstar::multiply;
        *{'charstar::(cmp'} = \&charstar::cmp;
        *{'charstar::(<=>'} = \&charstar::spaceship;
        *{'charstar::(bool'} = \&charstar::thischar;
        *{'charstar::(='} = \&charstar::clone;
        $restored = 1;
    }
    # version in core
    if (!$restored) {
        *{'version::(""'} = \&version::stringify;
        *{'version::(0+'} = \&version::numify;
        *{'version::(cmp'} = \&version::vcmp;
        *{'version::(<=>'} = \&version::vcmp;
        *{'version::(bool'} = \&version::boolean;
    }
}

# from PAUSE::pmfile;
sub _packages_per_pmfile {
    my $self = shift;

    my $ppp = {};
    my $pmfile = $self->{PMFILE};
    my $filemtime = $self->{MTIME};
    my $version = $self->{VERSION};

    open my $fh, "<", "$pmfile" or return $ppp;

    local $/ = "\n";
    my $inpod = 0;

  PLINE: while (<$fh>) {
        chomp;
        my($pline) = $_;
        $inpod = $pline =~ /^=(?!cut)/ ? 1 :
            $pline =~ /^=cut/ ? 0 : $inpod;
        next if $inpod;
        next if substr($pline,0,4) eq "=cut";

        $pline =~ s/\#.*//;
        next if $pline =~ /^\s*$/;
        if ($pline =~ /^__(?:END|DATA)__\b/
            and $pmfile !~ /\.PL$/   # PL files may well have code after __DATA__
            ){
            last PLINE;
        }

        my $pkg;
        my $strict_version;

        if (
            $pline =~ m{
                      # (.*) # takes too much time if $pline is long
                      #(?<![*\$\\@%&]) # no sigils
                      ^[\s\{;]*
                      \bpackage\s+
                      ([\w\:\']+)
                      \s*
                      (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
                    }x) {
            $pkg = $1;
            $strict_version = $2;
            if ($pkg eq "DB"){
                # XXX if pumpkin and perl make him comaintainer! I
                # think I always made the pumpkins comaint on DB
                # without further ado (?)
                next PLINE;
            }
        }

        if ($pkg) {
            # Found something

            # from package
            $pkg =~ s/\'/::/g;
            next PLINE unless $pkg =~ /^[A-Za-z]/;
            next PLINE unless $pkg =~ /\w$/;
            next PLINE if $pkg eq "main";
            # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
            # database for modid in mods, package in packages, package in perms
            # alter table mods modify modid varchar(128) binary NOT NULL default '';
            # alter table packages modify package varchar(128) binary NOT NULL default '';
            next PLINE if length($pkg) > 128;
            #restriction
            $ppp->{$pkg}{parsed}++;
            $ppp->{$pkg}{infile} = $pmfile;
            if ($self->_simile($pmfile,$pkg)) {
                $ppp->{$pkg}{simile} = $pmfile;
                if ($self->_version_from_meta_ok) {
                    my $provides = $self->{META_CONTENT}{provides};
                    if (exists $provides->{$pkg}) {
                        if (defined $provides->{$pkg}{version}) {
                            my $v = $provides->{$pkg}{version};
                            if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){   # ignore developer releases and "You suck!"
                                next PLINE;
                            }

                            unless (eval { $version = $self->_normalize_version($v); 1 }) {
                              $self->_verbose(1, "error with version in $pmfile: $@");
                              next;

                            }
                            $ppp->{$pkg}{version} = $version;
                        } else {
                            $ppp->{$pkg}{version} = "undef";
                        }
                    }
                } else {
                    if (defined $strict_version){
                        $ppp->{$pkg}{version} = $strict_version ;
                    } else {
                        $ppp->{$pkg}{version} = defined $version ? $version : "";
                    }
                    no warnings;
                    if ($version eq 'undef') {
                        $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
                    } else {
                        $ppp->{$pkg}{version} =
                            $version
                                if $version
                                    > $ppp->{$pkg}{version} ||
                                        $version
                                            gt $ppp->{$pkg}{version};
                    }
                }
            } else {        # not simile
                #### it comes later, it would be nonsense
                #### to set to "undef". MM_Unix gives us
                #### the best we can reasonably consider
                $ppp->{$pkg}{version} =
                    $version
                        unless defined $ppp->{$pkg}{version} &&
                            length($ppp->{$pkg}{version});
            }
            $ppp->{$pkg}{filemtime} = $filemtime;
        } else {
            # $self->_verbose(2,"no pkg found");
        }
    }

    close $fh;
    $ppp;
}

# from PAUSE::pmfile;
{
    no strict;
    sub _parse_version_safely {
        my($parsefile) = @_;
        my $result;
        local *FH;
        local $/ = "\n";
        open(FH,$parsefile) or die "Could not open '$parsefile': $!";
        my $inpod = 0;
        while (<FH>) {
            $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
            next if $inpod || /^\s*#/;
            last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer
            chop;

            if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) {
              # XXX: should handle this better if version is bogus -- rjbs,
              # 2014-03-16
              return $ver if version::is_lax($ver);
            }

            # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
            next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
            my $current_parsed_line = $_;
            my $eval = qq{
                package #
                    ExtUtils::MakeMaker::_version;

                local $1$2;
                \$$2=undef; do {
                    $_
                }; \$$2
            };
            local $^W = 0;
            local $SIG{__WARN__} = sub {};
            $result = __clean_eval($eval);
            # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
            if ($@ or !defined $result){
                die +{
                      eval => $eval,
                      line => $current_parsed_line,
                      file => $parsefile,
                      err => $@,
                      };
            }
            last;
        } #;
        close FH;

        $result = "undef" unless defined $result;
        if ((ref $result) =~ /^version(?:::vpp)?\b/) {
            no warnings;
            $result = $result->numify;
        }
        return $result;
    }
}

# from PAUSE::pmfile;
sub _filter_ppps {
    my($self,@ppps) = @_;
    my @res;

    # very similar code is in PAUSE::dist::filter_pms
  MANI: for my $ppp ( @ppps ) {
        if ($self->{META_CONTENT}){
            my $no_index = $self->{META_CONTENT}{no_index}
                            || $self->{META_CONTENT}{private}; # backward compat
            if (ref($no_index) eq 'HASH') {
                my %map = (
                            package => qr{\z},
                            namespace => qr{::},
                          );
                for my $k (qw(package namespace)) {
                    next unless my $v = $no_index->{$k};
                    my $rest = $map{$k};
                    if (ref $v eq "ARRAY") {
                        for my $ve (@$v) {
                            $ve =~ s|::$||;
                            if ($ppp =~ /^$ve$rest/){
                                $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
                                next MANI;
                            } else {
                                $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
                            }
                        }
                    } else {
                        $v =~ s|::$||;
                        if ($ppp =~ /^$v$rest/){
                            $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
                            next MANI;
                        } else {
                            $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
                        }
                    }
                }
            } else {
                $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
            }
        } else {
            # $self->_verbose(1,"no META_CONTENT"); # too noisy
        }
        push @res, $ppp;
    }
    $self->_verbose(1,"Result of filter_ppps: res[@res]");
    @res;
}

# from PAUSE::pmfile;
sub _simile {
    my($self,$file,$package) = @_;
    # MakeMaker gives them the chance to have the file Simple.pm in
    # this directory but have the package HTML::Simple in it.
    # Afaik, they wouldn't be able to do so with deeper nested packages
    $file =~ s|.*/||;
    $file =~ s|\.pm(?:\.PL)?||;
    my $ret = $package =~ m/\b\Q$file\E$/;
    $ret ||= 0;
    unless ($ret) {
        # Apache::mod_perl_guide stuffs it into Version.pm
        $ret = 1 if lc $file eq 'version';
    }
    $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
    $ret;
}

# from PAUSE::pmfile
sub _normalize_version {
    my($self,$v) = @_;
    $v = "undef" unless defined $v;
    my $dv = Dumpvalue->new;
    my $sdv = $dv->stringify($v,1); # second argument prevents ticks
    $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");

    return $v if $v eq "undef";
    return $v if $v =~ /^\{.*\}$/; # JSON object
    $v =~ s/^\s+//;
    $v =~ s/\s+\z//;
    if ($v =~ /_/) {
        # XXX should pass something like EDEVELOPERRELEASE up e.g.
        # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
        # such modules and the mesage was not helpful that "nothing
        # was found".
        return $v ;
    }
    if (!version::is_lax($v)) {
        return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v });
    }
    # may warn "Integer overflow"
    my $vv = eval { no warnings; version->new($v)->numify };
    if ($@) {
        # warn "$v: $@";
        return JSON::PP::encode_json({ x_normalize => $@, version => $v });
        # return "undef";
    }
    if ($vv eq $v) {
        # the boring 3.14
    } else {
        my $forced = $self->_force_numeric($v);
        if ($forced eq $vv) {
        } elsif ($forced =~ /^v(.+)/) {
            # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
            no warnings;
            $vv = version->new($1)->numify;
        } else {
            # warn "Unequal forced[$forced] and vv[$vv]";
            if ($forced == $vv) {
                # the trailing zeroes would cause unnecessary havoc
                $vv = $forced;
            }
        }
    }
    return $vv;
}

# from PAUSE::pmfile;
sub _force_numeric {
    my($self,$v) = @_;
    $v = $self->_readable($v);

    if (
        $v =~
        /^(\+?)(\d*)(\.(\d*))?/ &&
        # "$2$4" ne ''
        (
          defined $2 && length $2
          ||
          defined $4 && length $4
        )
        ) {
        my $two = defined $2 ? $2 : "";
        my $three = defined $3 ? $3 : "";
        $v = "$two$three";
    }
    # no else branch! We simply say, everything else is a string.
    $v;
}

# from PAUSE::dist
sub _version_from_meta_ok {
  my($self) = @_;
  return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
  my $c = $self->{META_CONTENT};

  # If there's no provides hash, we can't get our module versions from the
  # provides hash! -- rjbs, 2012-03-31
  return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};

  # Some versions of Module::Build geneated an empty provides hash.  If we're
  # *not* looking at a Module::Build-generated metafile, then it's okay.
  my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
  return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;

  # ??? I don't know why this is here.
  return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';

  if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
      # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
      # did not find the reason why this happened, but let's not go
      # overboard, 0.26 seems a good threshold from the statistics: there
      # are not many empty provides hashes from 0.26 up.
      return($self->{VERSION_FROM_META_OK} = 0);
  }

  # We're not in the suspect range of M::B versions.  It's good to go.
  return($self->{VERSION_FROM_META_OK} = 1);
}

sub _verbose {
    my($self,$level,@what) = @_;
    warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE);
}

# all of the following methods are stripped from CPAN::Version
# (as of version 5.5001, bundled in CPAN 2.03), and slightly
# modified (ie. made private, as well as CPAN->debug(...) are
# replaced with $self->_verbose(9, ...).)

# CPAN::Version::vcmp courtesy Jost Krieger
sub _vcmp {
    my($self,$l,$r) = @_;
    local($^W) = 0;
    $self->_verbose(9, "l[$l] r[$r]");

    return 0 if $l eq $r; # short circuit for quicker success

    for ($l,$r) {
        s/_//g;
    }
    $self->_verbose(9, "l[$l] r[$r]");
    for ($l,$r) {
        next unless tr/.// > 1 || /^v/;
        s/^v?/v/;
        1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
    }
    $self->_verbose(9, "l[$l] r[$r]");
    if ($l=~/^v/ <=> $r=~/^v/) {
        for ($l,$r) {
            next if /^v/;
            $_ = $self->_float2vv($_);
        }
    }
    $self->_verbose(9, "l[$l] r[$r]");
    my $lvstring = "v0";
    my $rvstring = "v0";
    if ($] >= 5.006
     && $l =~ /^v/
     && $r =~ /^v/) {
        $lvstring = $self->_vstring($l);
        $rvstring = $self->_vstring($r);
        $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring);
    }

    return (
            ($l ne "undef") <=> ($r ne "undef")
            ||
            $lvstring cmp $rvstring
            ||
            $l <=> $r
            ||
            $l cmp $r
    );
}

sub _vgt {
    my($self,$l,$r) = @_;
    $self->_vcmp($l,$r) > 0;
}

sub _vlt {
    my($self,$l,$r) = @_;
    $self->_vcmp($l,$r) < 0;
}

sub _vge {
    my($self,$l,$r) = @_;
    $self->_vcmp($l,$r) >= 0;
}

sub _vle {
    my($self,$l,$r) = @_;
    $self->_vcmp($l,$r) <= 0;
}

sub _vstring {
    my($self,$n) = @_;
    $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";
    pack "U*", split /\./, $n;
}

# vv => visible vstring
sub _float2vv {
    my($self,$n) = @_;
    my($rev) = int($n);
    $rev ||= 0;
    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
                                          # architecture influence
    $mantissa ||= 0;
    $mantissa .= "0" while length($mantissa)%3;
    my $ret = "v" . $rev;
    while ($mantissa) {
        $mantissa =~ s/(\d{1,3})// or
            die "Panic: length>0 but not a digit? mantissa[$mantissa]";
        $ret .= ".".int($1);
    }
    # warn "n[$n]ret[$ret]";
    $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
    $ret;
}

sub _readable {
    my($self,$n) = @_;
    $n =~ /^([\w\-\+\.]+)/;

    return $1 if defined $1 && length($1)>0;
    # if the first user reaches version v43, he will be treated as "+".
    # We'll have to decide about a new rule here then, depending on what
    # will be the prevailing versioning behavior then.

    if ($] < 5.006) { # or whenever v-strings were introduced
        # we get them wrong anyway, whatever we do, because 5.005 will
        # have already interpreted 0.2.4 to be "0.24". So even if he
        # indexer sends us something like "v0.2.4" we compare wrongly.

        # And if they say v1.2, then the old perl takes it as "v12"

        $self->_verbose(9, "Suspicious version string seen [$n]\n");
        return $n;
    }
    my $better = sprintf "v%vd", $n;
    $self->_verbose(9, "n[$n] better[$better]");
    return $better;
}

1;

__END__

=head1 NAME

Parse::PMFile - parses .pm file as PAUSE does

=head1 SYNOPSIS

    use Parse::PMFile;

    my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1});
    my $packages_info = $parser->parse($pmfile);

    # if you need info about invalid versions
    my ($packages_info, $errors) = $parser->parse($pmfile);

    # to check permissions
    my $parser = Parse::PMFile->new($metadata, {
        USERID => 'ISHIGAKI',
        PERMISSIONS => PAUSE::Permissions->new,
    });

=head1 DESCRIPTION

The 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.

This module doesn't provide features to extract a distribution or parse meta files intentionally.

=head1 METHODS

=head2 new

creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are:

=over 4

=item ALLOW_DEV_VERSION

Parse::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.

=item VERBOSE

Set this to true if you need to know some details.

=item FORK

As 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.

=item USERID, PERMISSIONS

As 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.

=item UNSAFE

Parse::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.

=back

=head2 parse

takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file.

=head1 SEE ALSO

L<Parse::LocalDistribution>, L<PAUSE::Permissions>

Most part of this module is derived from PAUSE and CPAN::Version.

L<https://github.com/andk/pause>

L<https://github.com/andk/cpanpm>

=head1 AUTHOR

Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>

Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code.

Copyright 2013 by Kenichi Ishigaki for some.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut