view release on metacpan or  search on metacpan

lib/CPAN/ParseDistribution.pm  view on Meta::CPAN

=over

=item use_tar

The full path to 'tar'.  This is assumed to be GNU tar, and to be
sufficiently well-endowed as to be able to support bzip2 files.
Maybe I'll fix that at some point.  If this isn't specified, then
Archive::Tar is used instead.

You might want to use this if dealing with very large files, as
Archive::Tar is rather profligate with memory.

=back

=cut

sub new {
    my($class, $file, %extra_params) = @_;
    die("file parameter is mandatory\n") unless($file);
    die("$file doesn't exist\n") if(!-e $file);
    die("$file looks like a ppm\n")
        if($file =~ /\.ppm\.(tar(\.gz|\.bz2)?|tbz|tgz|zip)$/i);
    die("$file isn't the right type\n")
        if($file !~ /\.(tar(\.gz|\.bz2)?|tbz|tgz|zip)$/i);
    $file = abs_path($file);

    # dist name and version
    (my $dist = $file) =~ s{(^.*/|\.(tar(\.gz|\.bz2)?|tbz|tgz|zip)$)}{}gi;
    $dist =~ /^(.*)-(\d.*)$/;
    ($dist, my $distversion) = ($1, $2);
    die("Can't index perl itself ($dist-$distversion)\n")
        if($dist =~ /^(perl|ponie|kurila|parrot|Perl6-Pugs|v6-pugs)$/);

    bless {
        file    => $file,
        modules => {},
        dist    => $dist,
        distversion => $distversion,
        extra_params => \%extra_params,
    }, $class;
}

# takes a filename, unarchives it, returns the directory it's been
# unarchived into
sub _unarchive {
    my($file, %extra_params) = @_;
    my $olddir = getcwd();
    my $tempdir = tempdir(TMPDIR => 1);
    chdir($tempdir);
    if($file =~ /\.zip$/i) {
        my $zip = Archive::Zip->new($file);
        $zip->extractTree() if($zip);
    } elsif($file =~ /\.(tar(\.gz)?|tgz)$/i) {
        if($extra_params{use_tar}) {
            system(
                $extra_params{use_tar},
                (($file =~ /gz$/) ? 'xzf' : 'xf'),
                $file
            );
            system("chmod -R u+r *"); # tar might preserve unreadable perms
        } else {
            my $tar = Archive::Tar->new($file, 1);
            $tar->extract() if($tar);
        }
    } else {
        if($extra_params{use_tar}) {
            system( $extra_params{use_tar}, 'xjf', $file);
            system("chmod -R u+r *");
        } else {
            open(my $fh, '-|', qw(bzip2 -dc), $file) || die("Can't unbzip2\n");
            my $tar = Archive::Tar->new($fh);
            $tar->extract() if($tar);
        }
    }
    chdir($olddir);
    return $tempdir;
}

# adapted from PAUSE::pmfile::parse_version_safely in mldistwatch.pm
sub _parse_version_safely {
    my($parsefile) = @_;
    my $result;
    my $eval;
    local $/ = "\n";
    open(my $fh, $parsefile) or die "Could not open '$parsefile': $!";
    my $inpod = 0;
    while (<$fh>) {
        $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
        next if $inpod || /^\s*#/;
        chop;
        next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
        my($sigil, $var) = ($1, $2);
        my $current_parsed_line = $_;
        {
            local $^W = 0;
            no strict;
            my $c = Safe->new();
            $c->deny(qw(
                 tie untie tied chdir flock ioctl socket getpeername
                 ssockopt bind connect listen accept shutdown gsockopt
                 getsockname sleep alarm entereval reset dbstate
                 readline rcatline getc read formline enterwrite
                 leavewrite print sysread syswrite send recv eof
                 tell seek sysseek readdir telldir seekdir rewinddir
                 lock stat lstat readlink ftatime ftblk ftchr ftctime
                 ftdir fteexec fteowned fteread ftewrite ftfile ftis
                 ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftsgid
                 ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
                 fttext ftbinary fileno ghbyname ghbyaddr ghostent
                 shostent ehostent gnbyname gnbyaddr gnetent snetent
                 enetent gpbyname gpbynumber gprotoent sprotoent
                 eprotoent gsbyname gsbyport gservent sservent
                 eservent  gpwnam gpwuid gpwent spwent epwent
                 getlogin ggrnam ggrgid ggrent sgrent egrent msgctl
                 msgget msgrcv msgsnd semctl semget semop shmctl
                 shmget shmread shmwrite require dofile caller
                 syscall dump chroot link unlink rename symlink
                 truncate backtick system fork wait waitpid glob
                 exec exit kill time tms mkdir rmdir utime chmod
                 chown fcntl sysopen open close umask binmode
                 open_dir closedir 
            ), ($] >= 5.010 ? qw(say) : ()));
            $c->share_from(__PACKAGE__, [qw(qv)]);
            s/\buse\s+version\b.*?;//gs;
            # qv broke some time between version.pm 0.74 and 0.82
            # so just extract it and hope for the best
            s/\bqv\s*\(\s*(["']?)([\d\.]+)\1\s*\)\s*/"$2"/;
            s/\buse\s+vars\b//g;
            $eval = qq{
                local ${sigil}${var};
                \$$var = undef; do {
                    $_
                }; \$$var
            };

            $result = _run_safely($c, $eval);
        };
        # stuff that's my fault because of the Safe compartment
        if($result->{error} && $result->{error} =~ /trapped by operation mask|safe compartment timed out/i) {
            warn("Unsafe code in \$VERSION\n".$result->{error}."\n$parsefile\n$eval");
            $result = undef;
        } elsif($result->{error}) {
            warn "_parse_version_safely: ".Dumper({
                eval => $eval,
                line => $current_parsed_line,
                file => $parsefile,
                err  => $result->{error},
            });
        }
        last;
    }
    close $fh;

    return exists($result->{result}) ? $result->{result} : undef;
}

sub _run_safely {
    if(os_is('Unix')) {
        eval 'use CPAN::ParseDistribution::Unix';
        return CPAN::ParseDistribution::Unix->_run(@_);
    } elsif(os_is('MicrosoftWindows')) {
        # FIXME once someone supplies CPAN::ParseDistribution::Windows
        warn("Windows is not fully supported by CPAN::ParseDistribution\n");
        warn("See the LIMITATIONS section in the documentation\n");
        eval 'use CPAN::ParseDistribution::Unix';
        return CPAN::ParseDistribution::Unix->_run(@_);
    }
}

=head2 isdevversion

Returns true or false depending on whether this is a developer-only
or trial release of a distribution.  This is determined by looking for
an underscore in the distribution version or the string '-TRIAL' at the
end of the distribution version.

=cut

sub isdevversion {