mirror of
https://github.com/Perl/perl5.git
synced 2026-01-26 16:39:36 +00:00
1c90da2f77
Allow a v prefix on versions expected by the core-cpan-diff and sync-with-cpan scripts. Also align the two scripts with each other, and handle the same file extensions expected by PAUSE.
790 lines
24 KiB
Perl
Executable File
790 lines
24 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# core-cpan-diff: Compare CPAN modules with their equivalent in core
|
|
|
|
# Originally based on App::DualLivedDiff by Steffen Mueller.
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use 5.010;
|
|
|
|
use Getopt::Long qw(:config bundling);
|
|
use File::Basename ();
|
|
use File::Copy ();
|
|
use File::Temp ();
|
|
use File::Path ();
|
|
use File::Spec;
|
|
use File::Spec::Functions;
|
|
use IO::Uncompress::Gunzip ();
|
|
use File::Compare ();
|
|
use ExtUtils::Manifest;
|
|
use ExtUtils::MakeMaker ();
|
|
use HTTP::Tiny;
|
|
|
|
BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
|
|
use lib 'Porting';
|
|
use Maintainers ();
|
|
|
|
use Archive::Tar;
|
|
use Cwd qw[cwd chdir];
|
|
use IPC::Open3;
|
|
use IO::Select;
|
|
local $Archive::Tar::WARN = 0;
|
|
|
|
# where, under the cache dir, to download tarballs to
|
|
use constant SRC_DIR => 'tarballs';
|
|
|
|
# where, under the cache dir, to untar stuff to
|
|
use constant UNTAR_DIR => 'untarred';
|
|
|
|
use constant DIFF_CMD => 'diff';
|
|
|
|
sub usage {
|
|
print STDERR "\n@_\n\n" if @_;
|
|
print STDERR <<HERE;
|
|
Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
|
|
|
|
-a/--all Scan all dual-life modules.
|
|
|
|
-c/--cachedir Where to save downloaded CPAN tarball files
|
|
(defaults to /tmp/something/ with deletion after each run).
|
|
|
|
-d/--diff Display file differences using diff(1), rather than just
|
|
listing which files have changed.
|
|
|
|
--diffopts Options to pass to the diff command. Defaults to '-u --text'
|
|
(except on *BSD, where it's just '-u').
|
|
|
|
-f/--force Force download from CPAN of new 02packages.details.txt file
|
|
(with --crosscheck only).
|
|
|
|
-m/--mirror Preferred CPAN mirror URI (http:// or file:///)
|
|
(Local mirror must be a complete mirror, not minicpan)
|
|
|
|
-o/--output File name to write output to (defaults to STDOUT).
|
|
|
|
-r/--reverse Reverses the diff (perl to CPAN).
|
|
|
|
-u/--upstream Only print modules with the given upstream (defaults to all)
|
|
|
|
-v/--verbose List the fate of *all* files in the tarball, not just those
|
|
that differ or are missing.
|
|
|
|
-x/--crosscheck List the distributions whose current CPAN version differs from
|
|
that in blead (i.e. the DISTRIBUTION field in Maintainers.pl).
|
|
|
|
By default (i.e. without the --crosscheck option), for each listed module
|
|
(or with -a, all CPAN modules listed in Maintainers.pl), grab the tarball
|
|
from CPAN associated with that module, and compare the files in it with
|
|
those in the perl source tree.
|
|
|
|
Must be run from the root of the perl source tree.
|
|
Module names must match the keys of %Modules in Maintainers.pl.
|
|
|
|
The diff(1) command is assumed to be in your PATH and is used to diff files
|
|
regardless of whether the --diff option has been chosen to display any file
|
|
differences.
|
|
HERE
|
|
exit(1);
|
|
}
|
|
|
|
sub run {
|
|
my $scan_all;
|
|
my $diff_opts;
|
|
my $reverse = 0;
|
|
my @wanted_upstreams;
|
|
my $cache_dir;
|
|
my $mirror_url = "http://www.cpan.org/";
|
|
my $use_diff;
|
|
my $output_file;
|
|
my $verbose = 0;
|
|
my $force;
|
|
my $do_crosscheck;
|
|
|
|
GetOptions(
|
|
'a|all' => \$scan_all,
|
|
'c|cachedir=s' => \$cache_dir,
|
|
'd|diff' => \$use_diff,
|
|
'diffopts:s' => \$diff_opts,
|
|
'f|force' => \$force,
|
|
'h|help' => \&usage,
|
|
'm|mirror=s' => \$mirror_url,
|
|
'o|output=s' => \$output_file,
|
|
'r|reverse' => \$reverse,
|
|
'u|upstream=s@' => \@wanted_upstreams,
|
|
'v|verbose:1' => \$verbose,
|
|
'x|crosscheck' => \$do_crosscheck,
|
|
) or usage;
|
|
|
|
my @modules;
|
|
|
|
usage("Cannot mix -a with module list") if $scan_all && @ARGV;
|
|
|
|
if ($do_crosscheck) {
|
|
usage("can't use -r, -d, --diffopts with --crosscheck")
|
|
if ( $reverse || $use_diff || $diff_opts );
|
|
}
|
|
else {
|
|
#$diff_opts = '-u --text' unless defined $diff_opts;
|
|
if (! defined $diff_opts) {
|
|
$diff_opts = ($^O =~ m/bsd$/i) ? '-u' : '-u --text';
|
|
};
|
|
usage("can't use -f without --crosscheck") if $force;
|
|
}
|
|
|
|
@modules =
|
|
$scan_all
|
|
? grep $Maintainers::Modules{$_}{CPAN},
|
|
( sort { lc $a cmp lc $b } keys %Maintainers::Modules )
|
|
: @ARGV;
|
|
usage("No modules specified") unless @modules;
|
|
|
|
my $outfh;
|
|
if ( defined $output_file ) {
|
|
open $outfh, '>', $output_file
|
|
or die "ERROR: could not open file '$output_file' for writing: $!\n";
|
|
}
|
|
else {
|
|
open $outfh, ">&STDOUT"
|
|
or die "ERROR: can't dup STDOUT: $!\n";
|
|
}
|
|
|
|
if ( defined $cache_dir ) {
|
|
die "ERROR: not a directory: '$cache_dir'\n"
|
|
if !-d $cache_dir && -e $cache_dir;
|
|
File::Path::mkpath($cache_dir);
|
|
}
|
|
else {
|
|
$cache_dir = File::Temp::tempdir( CLEANUP => 1 );
|
|
}
|
|
|
|
$mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/";
|
|
my $test_file = "modules/03modlist.data.gz";
|
|
my_getstore(
|
|
cpan_url( $mirror_url, $test_file ),
|
|
catfile( $cache_dir, $test_file )
|
|
) or die "ERROR: not a CPAN mirror '$mirror_url'\n";
|
|
|
|
if ($do_crosscheck) {
|
|
do_crosscheck(
|
|
$outfh, $cache_dir, $mirror_url, $verbose,
|
|
$force, \@modules, \@wanted_upstreams
|
|
);
|
|
}
|
|
else {
|
|
$verbose > 2 and $use_diff++;
|
|
do_compare(
|
|
\@modules, $outfh, $output_file,
|
|
$cache_dir, $mirror_url, $verbose,
|
|
$use_diff, $reverse, $diff_opts,
|
|
\@wanted_upstreams
|
|
);
|
|
}
|
|
}
|
|
|
|
# construct a CPAN url
|
|
|
|
sub cpan_url {
|
|
my ( $mirror_url, @path ) = @_;
|
|
return $mirror_url unless @path;
|
|
my $cpan_path = join( "/", map { split "/", $_ } @path );
|
|
$cpan_path =~ s{\A/}{}; # remove leading slash since url has one trailing
|
|
return $mirror_url . $cpan_path;
|
|
}
|
|
|
|
# construct a CPAN URL for a author/distribution string like:
|
|
# BINGOS/Archive-Extract-0.52.tar.gz
|
|
|
|
sub cpan_url_distribution {
|
|
my ( $mirror_url, $distribution ) = @_;
|
|
$distribution =~ /^([A-Z])([A-Z])/
|
|
or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
|
|
my $path = "authors/id/$1/$1$2/$distribution";
|
|
return cpan_url( $mirror_url, $path );
|
|
}
|
|
|
|
# compare a list of modules against their CPAN equivalents
|
|
|
|
sub do_compare {
|
|
my (
|
|
$modules, $outfh, $output_file, $cache_dir,
|
|
$mirror_url, $verbose, $use_diff, $reverse,
|
|
$diff_opts, $wanted_upstreams
|
|
) = @_;
|
|
|
|
# first, make sure we have a directory where they can all be untarred,
|
|
# and if its a permanent directory, clear any previous content
|
|
my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
|
|
my $src_dir = catdir( $cache_dir, SRC_DIR );
|
|
for my $d ( $src_dir, $untar_dir ) {
|
|
next if -d $d;
|
|
mkdir $d or die "mkdir $d: $!\n";
|
|
}
|
|
|
|
my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
|
|
my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
|
|
|
|
my %seen_dist;
|
|
for my $module (@$modules) {
|
|
warn "Processing $module ...\n" if defined $output_file;
|
|
|
|
my $m = $Maintainers::Modules{$module}
|
|
or die "ERROR: No such module in Maintainers.pl: '$module'\n";
|
|
|
|
unless ( $m->{CPAN} ) {
|
|
print $outfh "WARNING: $module is not dual-life; skipping\n";
|
|
next;
|
|
}
|
|
|
|
my $dist = $m->{DISTRIBUTION};
|
|
die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
|
|
|
|
if ( $seen_dist{$dist}++ ) {
|
|
warn "WARNING: duplicate entry for $dist in $module\n";
|
|
}
|
|
|
|
my $upstream = $m->{UPSTREAM} // 'undef';
|
|
next if @$wanted_upstreams and !$wanted_upstream{$upstream};
|
|
|
|
print $outfh "\n$module - "
|
|
. $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
|
|
print $outfh " upstream is: "
|
|
. ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
|
|
|
|
my $cpan_dir;
|
|
eval {
|
|
$cpan_dir =
|
|
get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
|
|
$dist );
|
|
};
|
|
if ($@) {
|
|
print $outfh " ", $@;
|
|
print $outfh " (skipping)\n";
|
|
next;
|
|
}
|
|
|
|
my @perl_files = Maintainers::get_module_files($module);
|
|
|
|
my $manifest = catfile( $cpan_dir, 'MANIFEST' );
|
|
die "ERROR: no such file: $manifest\n" unless -f $manifest;
|
|
|
|
my $cpan_files = ExtUtils::Manifest::maniread($manifest);
|
|
my @cpan_files = sort keys %$cpan_files;
|
|
|
|
( my $main_pm = $module ) =~ s{::}{/}g;
|
|
$main_pm .= ".pm";
|
|
|
|
my ( $excluded, $map, $customized ) =
|
|
get_map( $m, $module, \@perl_files );
|
|
|
|
my %perl_unseen;
|
|
@perl_unseen{@perl_files} = ();
|
|
my %perl_files = %perl_unseen;
|
|
|
|
foreach my $cpan_file (@cpan_files) {
|
|
my $mapped_file =
|
|
cpan_to_perl( $excluded, $map, $customized, $cpan_file );
|
|
unless ( defined $mapped_file ) {
|
|
print $outfh " Excluded: $cpan_file\n" if $verbose;
|
|
next;
|
|
}
|
|
|
|
if ( exists $perl_files{$mapped_file} ) {
|
|
delete $perl_unseen{$mapped_file};
|
|
}
|
|
else {
|
|
|
|
# some CPAN files foo are stored in core as foo.packed,
|
|
# which are then unpacked by 'make test_prep'
|
|
my $packed_file = "$mapped_file.packed";
|
|
if ( exists $perl_files{$packed_file} ) {
|
|
if ( !-f $mapped_file and -f $packed_file ) {
|
|
print $outfh <<EOF;
|
|
WARNING: $mapped_file not found, but .packed variant exists.
|
|
Perhaps you need to run 'make test_prep'?
|
|
EOF
|
|
next;
|
|
}
|
|
delete $perl_unseen{$packed_file};
|
|
}
|
|
else {
|
|
if ( $ignorable{$cpan_file} ) {
|
|
print $outfh " Ignored: $cpan_file\n" if $verbose;
|
|
next;
|
|
}
|
|
|
|
unless ($use_diff) {
|
|
print $outfh " CPAN only: $cpan_file",
|
|
( $cpan_file eq $mapped_file )
|
|
? "\n"
|
|
: " (missing $mapped_file)\n";
|
|
}
|
|
next;
|
|
}
|
|
}
|
|
|
|
my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
|
|
|
|
# should never happen
|
|
die "ERROR: can't find file $abs_cpan_file\n"
|
|
unless -f $abs_cpan_file;
|
|
|
|
# might happen if the FILES entry in Maintainers.pl is wrong
|
|
unless ( -f $mapped_file ) {
|
|
print $outfh "WARNING: perl file not found: $mapped_file\n";
|
|
next;
|
|
}
|
|
|
|
my $relative_mapped_file = relatively_mapped($mapped_file);
|
|
|
|
my $different =
|
|
file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
|
|
$diff_opts );
|
|
if ( $different && customized( $m, $relative_mapped_file ) ) {
|
|
print $outfh " Customized for blead: $relative_mapped_file\n";
|
|
if ( $use_diff && $verbose ) {
|
|
$different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
|
|
print $outfh $different;
|
|
}
|
|
}
|
|
elsif ($different) {
|
|
if ($use_diff) {
|
|
$different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
|
|
print $outfh $different;
|
|
}
|
|
else {
|
|
if ( $cpan_file eq $relative_mapped_file ) {
|
|
print $outfh " Modified: $relative_mapped_file\n";
|
|
}
|
|
else {
|
|
print $outfh
|
|
" Modified: $cpan_file $relative_mapped_file\n";
|
|
}
|
|
|
|
if ( $cpan_file =~ m{\.pm\z} ) {
|
|
my $pv = MM->parse_version($mapped_file) || 'unknown';
|
|
my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
|
|
if ( $pv ne $cv ) {
|
|
print $outfh
|
|
" Version mismatch in '$cpan_file':\n $cv (cpan) vs $pv (perl)\n";
|
|
}
|
|
}
|
|
|
|
}
|
|
}
|
|
elsif ( customized( $m, $relative_mapped_file ) ) {
|
|
# Maintainers.pl says we customized it, but it looks the
|
|
# same as CPAN so maybe we lost the customization, which
|
|
# could be bad
|
|
if ( $cpan_file eq $relative_mapped_file ) {
|
|
print $outfh " Blead customization missing: $cpan_file\n";
|
|
}
|
|
else {
|
|
print $outfh
|
|
" Blead customization missing: $cpan_file $relative_mapped_file\n";
|
|
}
|
|
}
|
|
elsif ($verbose) {
|
|
if ( $cpan_file eq $relative_mapped_file ) {
|
|
print $outfh " Unchanged: $cpan_file\n";
|
|
}
|
|
else {
|
|
print $outfh
|
|
" Unchanged: $cpan_file $relative_mapped_file\n";
|
|
}
|
|
}
|
|
}
|
|
for ( sort keys %perl_unseen ) {
|
|
my $relative_mapped_file = relatively_mapped($_);
|
|
if ( customized( $m, $relative_mapped_file ) ) {
|
|
print $outfh " Customized for blead: $_\n";
|
|
}
|
|
else {
|
|
print $outfh " Perl only: $_\n" unless $use_diff;
|
|
}
|
|
}
|
|
if ( $verbose ) {
|
|
foreach my $exclude (@$excluded) {
|
|
my $seen = 0;
|
|
foreach my $cpan_file (@cpan_files) {
|
|
# may be a simple string to match exactly, or a pattern
|
|
if ( ref $exclude ) {
|
|
$seen = 1 if $cpan_file =~ $exclude;
|
|
}
|
|
else {
|
|
$seen = 1 if $cpan_file eq $exclude;
|
|
}
|
|
last if $seen;
|
|
}
|
|
if ( not $seen ) {
|
|
print $outfh " Unnecessary exclusion: $exclude\n";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub relatively_mapped {
|
|
my $relative = shift;
|
|
$relative =~ s/^(cpan|dist|ext)\/.*?\///;
|
|
return $relative;
|
|
}
|
|
|
|
# given FooBar-1.23_45.tar.gz, return FooBar
|
|
|
|
sub distro_base {
|
|
my $d = shift;
|
|
my $tail_pat = qr/\.(?:tar\.(?:g?z|bz2|Z)|zip|tgz|tbz)/;
|
|
$d =~ s{-v?([0-9._]+(?:-TRIAL[0-9]*)?)$tail_pat\z}{};
|
|
return $d;
|
|
}
|
|
|
|
# process --crosscheck action:
|
|
# ie list all distributions whose CPAN versions differ from that listed in
|
|
# Maintainers.pl
|
|
|
|
sub do_crosscheck {
|
|
my (
|
|
$outfh, $cache_dir, $mirror_url, $verbose,
|
|
$force, $modules, $wanted_upstreams,
|
|
) = @_;
|
|
|
|
my $file = '02packages.details.txt';
|
|
my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
|
|
my $path = catfile( $download_dir, $file );
|
|
my $gzfile = "$path.gz";
|
|
|
|
# grab 02packages.details.txt
|
|
|
|
my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
|
|
|
|
if ( !-f $gzfile or $force ) {
|
|
unlink $gzfile;
|
|
my_getstore( $url, $gzfile );
|
|
}
|
|
unlink $path;
|
|
IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
|
|
or die
|
|
"ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
|
|
|
|
# suck in the data from it
|
|
|
|
open my $fh, '<', $path
|
|
or die "ERROR: open: $file: $!\n";
|
|
|
|
my %distros;
|
|
my %modules;
|
|
|
|
while (<$fh>) {
|
|
next if 1 .. /^$/;
|
|
chomp;
|
|
my @f = split ' ', $_;
|
|
if ( @f != 3 ) {
|
|
warn
|
|
"WARNING: $file:$.: line doesn't have three fields (skipping)\n";
|
|
next;
|
|
}
|
|
my $distro = $f[2];
|
|
$distro =~ s{^[A-Z]/[A-Z]{2}/}{}; # strip leading A/AB/
|
|
$modules{ $f[0] } = $distro;
|
|
|
|
( my $short_distro = $distro ) =~ s{^.*/}{};
|
|
|
|
$distros{ distro_base($short_distro) }{$distro} = 1;
|
|
}
|
|
|
|
my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
|
|
for my $module (@$modules) {
|
|
my $m = $Maintainers::Modules{$module}
|
|
or die "ERROR: No such module in Maintainers.pl: '$module'\n";
|
|
|
|
$verbose and warn "Checking $module\n";
|
|
|
|
unless ( $m->{CPAN} ) {
|
|
print $outfh "\nWARNING: $module is not dual-life; skipping\n";
|
|
next;
|
|
}
|
|
|
|
# given an entry like
|
|
# Foo::Bar 1.23 foo-bar-1.23.tar.gz,
|
|
# first compare the module name against Foo::Bar, and failing that,
|
|
# against foo-bar
|
|
|
|
my $pdist = $m->{DISTRIBUTION};
|
|
die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
|
|
|
|
my $upstream = $m->{UPSTREAM} // 'undef';
|
|
next if @$wanted_upstreams and !$wanted_upstream{$upstream};
|
|
|
|
my $cdist = $modules{$module};
|
|
( my $short_pdist = $pdist ) =~ s{^.*/}{};
|
|
|
|
unless ( defined $cdist ) {
|
|
my $d = $distros{ distro_base($short_pdist) };
|
|
unless ( defined $d ) {
|
|
print $outfh "\n$module: Can't determine current CPAN entry\n";
|
|
next;
|
|
}
|
|
if ( keys %$d > 1 ) {
|
|
print $outfh
|
|
"\n$module: (found more than one CPAN candidate):\n";
|
|
print $outfh " Perl: $pdist\n";
|
|
print $outfh " CPAN: $_\n" for sort keys %$d;
|
|
next;
|
|
}
|
|
$cdist = ( keys %$d )[0];
|
|
}
|
|
|
|
if ( $cdist ne $pdist ) {
|
|
print $outfh "\n$module:\n Perl: $pdist\n CPAN: $cdist\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
# get the EXCLUDED and MAP entries for this module, or
|
|
# make up defaults if they don't exist
|
|
|
|
sub get_map {
|
|
my ( $m, $module_name, $perl_files ) = @_;
|
|
|
|
my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
|
|
|
|
$excluded ||= [];
|
|
$customized ||= [];
|
|
|
|
return $excluded, $map, $customized if $map;
|
|
|
|
# all files under ext/foo-bar (plus maybe some under t/lib)???
|
|
|
|
my $ext;
|
|
for (@$perl_files) {
|
|
if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
|
|
if ( defined $ext and $ext ne $1 ) {
|
|
|
|
# more than one ext/$ext/
|
|
undef $ext;
|
|
last;
|
|
}
|
|
$ext = $1;
|
|
}
|
|
elsif (m{^t/lib/}) {
|
|
next;
|
|
}
|
|
else {
|
|
undef $ext;
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( defined $ext ) {
|
|
$map = { '' => $ext },;
|
|
}
|
|
else {
|
|
( my $base = $module_name ) =~ s{::}{/}g;
|
|
$base = "lib/$base";
|
|
$map = {
|
|
'lib/' => 'lib/',
|
|
'' => "$base/",
|
|
};
|
|
}
|
|
return $excluded, $map, $customized;
|
|
}
|
|
|
|
# Given an exclude list and a mapping hash, convert a CPAN filename
|
|
# (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
|
|
# Returns an empty list for an excluded file
|
|
|
|
sub cpan_to_perl {
|
|
my ( $excluded, $map, $customized, $cpan_file ) = @_;
|
|
|
|
my %customized = map { ( $_ => 1 ) } @$customized;
|
|
for my $exclude (@$excluded) {
|
|
next if $customized{$exclude};
|
|
|
|
# may be a simple string to match exactly, or a pattern
|
|
if ( ref $exclude ) {
|
|
return if $cpan_file =~ $exclude;
|
|
}
|
|
else {
|
|
return if $cpan_file eq $exclude;
|
|
}
|
|
}
|
|
|
|
my $perl_file = $cpan_file;
|
|
|
|
# try longest prefix first, then alphabetically on tie-break
|
|
for
|
|
my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
|
|
{
|
|
last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
|
|
}
|
|
return $perl_file;
|
|
}
|
|
|
|
# fetch a file from a URL and store it in a file given by a filename
|
|
|
|
sub my_getstore {
|
|
my ( $url, $file ) = @_;
|
|
File::Path::mkpath( File::Basename::dirname($file) );
|
|
if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
|
|
( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
|
|
File::Copy::copy( $local_path, $file );
|
|
} else {
|
|
my $http = HTTP::Tiny->new;
|
|
my $response = $http->mirror($url, $file);
|
|
return $response->{success};
|
|
}
|
|
}
|
|
|
|
# download and unpack a distribution
|
|
# Returns the full pathname of the extracted directory
|
|
# (eg '/tmp/XYZ/Foo_bar-1.23')
|
|
|
|
# cache_dir: where to download the .tar.gz file to
|
|
# mirror_url: CPAN mirror to download from
|
|
# untar_dir: where to untar or unzup the file
|
|
# module: name of module
|
|
# dist: name of the distribution
|
|
|
|
sub get_distribution {
|
|
my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
|
|
|
|
$dist =~ m{.+/([^/]+)$}
|
|
or die
|
|
"ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
|
|
my $filename = $1;
|
|
|
|
my $download_file = catfile( $src_dir, $filename );
|
|
|
|
# download distribution
|
|
|
|
if ( -f $download_file and !-s $download_file ) {
|
|
|
|
# failed download might leave a zero-length file
|
|
unlink $download_file;
|
|
}
|
|
|
|
unless ( -f $download_file ) {
|
|
|
|
# not cached
|
|
my $url = cpan_url_distribution( $mirror_url, $dist );
|
|
my_getstore( $url, $download_file )
|
|
or die "ERROR: Could not fetch '$url'\n";
|
|
}
|
|
|
|
# get the expected name of the extracted distribution dir
|
|
|
|
my $path = catfile( $untar_dir, $filename );
|
|
|
|
$path =~ s/\.tar\.gz$//
|
|
or $path =~ s/\.tgz$//
|
|
or $path =~ s/\.zip$//
|
|
or die
|
|
"ERROR: downloaded file does not have a recognised suffix: $path\n";
|
|
|
|
# extract it unless we already have it cached or tarball is newer
|
|
if ( !-d $path || ( -M $download_file < -M $path ) ) {
|
|
$path = extract( $download_file, $untar_dir )
|
|
or die
|
|
"ERROR: failed to extract distribution '$download_file to temp. dir: "
|
|
. $! . "\n";
|
|
}
|
|
|
|
die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
|
|
|
|
return $path;
|
|
}
|
|
|
|
# produce the diff of a single file
|
|
sub file_diff {
|
|
my $outfh = shift;
|
|
my $cpan_file = shift;
|
|
my $perl_file = shift;
|
|
my $reverse = shift;
|
|
my $diff_opts = shift;
|
|
|
|
my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
|
|
if ($reverse) {
|
|
push @cmd, $perl_file, $cpan_file;
|
|
}
|
|
else {
|
|
push @cmd, $cpan_file, $perl_file;
|
|
}
|
|
return `@cmd`;
|
|
|
|
}
|
|
|
|
sub customized {
|
|
my ( $module_data, $file ) = @_;
|
|
return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
|
|
}
|
|
|
|
sub extract {
|
|
my ($archive,$to) = @_;
|
|
my $cwd = cwd();
|
|
chdir $to or die "$!\n";
|
|
my @files;
|
|
EXTRACT: {
|
|
local $Archive::Tar::CHOWN = 0;
|
|
my $next;
|
|
unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
|
|
$! = $Archive::Tar::error;
|
|
last EXTRACT;
|
|
}
|
|
while ( my $file = $next->() ) {
|
|
push @files, $file->full_path;
|
|
unless ( $file->extract ) {
|
|
$! = $Archive::Tar::error;
|
|
last EXTRACT;
|
|
}
|
|
}
|
|
}
|
|
my $path = __get_extract_dir( \@files );
|
|
chdir $cwd or die "$!\n";
|
|
return $path;
|
|
}
|
|
|
|
sub __get_extract_dir {
|
|
my $files = shift || [];
|
|
|
|
return unless scalar @$files;
|
|
|
|
my($dir1, $dir2);
|
|
for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
|
|
my($dir,$pos) = @$aref;
|
|
|
|
### add a catdir(), so that any trailing slashes get
|
|
### take care of (removed)
|
|
### also, a catdir() normalises './dir/foo' to 'dir/foo';
|
|
### which was the problem in bug #23999
|
|
my $res = -d $files->[$pos]
|
|
? File::Spec->catdir( $files->[$pos], '' )
|
|
: File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
|
|
|
|
$$dir = $res;
|
|
}
|
|
|
|
### if the first and last dir don't match, make sure the
|
|
### dirname is not set wrongly
|
|
my $dir;
|
|
|
|
### dirs are the same, so we know for sure what the extract dir is
|
|
if( $dir1 eq $dir2 ) {
|
|
$dir = $dir1;
|
|
|
|
### dirs are different.. do they share the base dir?
|
|
### if so, use that, if not, fall back to '.'
|
|
} else {
|
|
my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
|
|
my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
|
|
|
|
$dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
|
|
}
|
|
|
|
return File::Spec->rel2abs( $dir );
|
|
}
|
|
|
|
run();
|
|
|