final commit for v5.24.0!
[perl.git] / Porting / core-cpan-diff
1 #!/usr/bin/env perl
2
3 # core-cpan-diff: Compare CPAN modules with their equivalent in core
4
5 # Originally based on App::DualLivedDiff by Steffen Mueller.
6
7 use strict;
8 use warnings;
9
10 use 5.010;
11
12 use Getopt::Long;
13 use File::Basename ();
14 use File::Copy     ();
15 use File::Temp     ();
16 use File::Path     ();
17 use File::Spec;
18 use File::Spec::Functions;
19 use IO::Uncompress::Gunzip ();
20 use File::Compare          ();
21 use ExtUtils::Manifest;
22 use ExtUtils::MakeMaker ();
23 use HTTP::Tiny;
24
25 BEGIN { die "Must be run from root of perl source tree\n" unless -d 'Porting' }
26 use lib 'Porting';
27 use Maintainers ();
28
29 use Archive::Tar;
30 use Cwd qw[cwd chdir];
31 use IPC::Open3;
32 use IO::Select;
33 local $Archive::Tar::WARN=0;
34
35 # where, under the cache dir, to download tarballs to
36 use constant SRC_DIR => 'tarballs';
37
38 # where, under the cache dir, to untar stuff to
39 use constant UNTAR_DIR => 'untarred';
40
41 use constant DIFF_CMD => 'diff';
42
43 sub usage {
44     print STDERR "\n@_\n\n" if @_;
45     print STDERR <<HERE;
46 Usage: $0 [opts] [ -d | -v | -x ] [ -a | module ... ]
47
48 -a/--all      Scan all dual-life modules.
49
50 -c/--cachedir Where to save downloaded CPAN tarball files
51               (defaults to /tmp/something/ with deletion after each run).
52
53 -d/--diff     Display file differences using diff(1), rather than just
54               listing which files have changed.
55
56 --diffopts    Options to pass to the diff command. Defaults to '-u --binary'.
57
58 -f|force      Force download from CPAN of new 02packages.details.txt file
59               (with --crosscheck only).
60
61 -m|mirror     Preferred CPAN mirror URI (http:// or file:///)
62               (Local mirror must be a complete mirror, not minicpan)
63
64 -o/--output   File name to write output to (defaults to STDOUT).
65
66 -r/--reverse  Reverses the diff (perl to CPAN).
67
68 -u/--upstream only print modules with the given upstream (defaults to all)
69
70 -v/--verbose  List the fate of *all* files in the tarball, not just those
71               that differ or are missing.
72
73 -x|crosscheck List the distributions whose current CPAN version differs from
74               that in blead (i.e. the DISTRIBUTION field in Maintainers.pl).
75
76 By default (i.e. without the --crosscheck option),  for each listed module
77 (or with -a, all CPAN modules listed in Maintainers.pl), grab the tarball
78 from CPAN associated with that module, and compare the files in it with
79 those in the perl source tree.
80
81 Must be run from the root of the perl source tree.
82 Module names must match the keys of %Modules in Maintainers.pl.
83
84 The diff(1) command is assumed to be in your PATH and is used to diff files
85 regardless of whether the --diff option has been chosen to display any file
86 differences.
87 HERE
88     exit(1);
89 }
90
91 sub run {
92     my $scan_all;
93     my $diff_opts;
94     my $reverse = 0;
95     my @wanted_upstreams;
96     my $cache_dir;
97     my $mirror_url = "http://www.cpan.org/";
98     my $use_diff;
99     my $output_file;
100     my $verbose = 0;
101     my $force;
102     my $do_crosscheck;
103
104     GetOptions(
105         'a|all'         => \$scan_all,
106         'c|cachedir=s'  => \$cache_dir,
107         'd|diff'        => \$use_diff,
108         'diffopts:s'    => \$diff_opts,
109         'f|force'       => \$force,
110         'h|help'        => \&usage,
111         'm|mirror=s'    => \$mirror_url,
112         'o|output=s'    => \$output_file,
113         'r|reverse'     => \$reverse,
114         'u|upstream=s@' => \@wanted_upstreams,
115         'v|verbose:1'   => \$verbose,
116         'x|crosscheck'  => \$do_crosscheck,
117     ) or usage;
118
119     my @modules;
120
121     usage("Cannot mix -a with module list") if $scan_all && @ARGV;
122
123     if ($do_crosscheck) {
124         usage("can't use -r, -d, --diffopts with --crosscheck")
125           if ( $reverse || $use_diff || $diff_opts );
126     }
127     else {
128         $diff_opts = '-u --binary' unless defined $diff_opts;
129         usage("can't use -f without --crosscheck") if $force;
130     }
131
132     @modules =
133       $scan_all
134       ? grep $Maintainers::Modules{$_}{CPAN},
135       ( sort { lc $a cmp lc $b } keys %Maintainers::Modules )
136       : @ARGV;
137     usage("No modules specified") unless @modules;
138
139     my $outfh;
140     if ( defined $output_file ) {
141         open $outfh, '>', $output_file
142           or die "ERROR: could not open file '$output_file' for writing: $!\n";
143     }
144     else {
145         open $outfh, ">&STDOUT"
146           or die "ERROR: can't dup STDOUT: $!\n";
147     }
148
149     if ( defined $cache_dir ) {
150         die "ERROR: not a directory: '$cache_dir'\n"
151             if !-d $cache_dir && -e $cache_dir;
152         File::Path::mkpath($cache_dir);
153     }
154     else {
155         $cache_dir = File::Temp::tempdir( CLEANUP => 1 );
156     }
157
158     $mirror_url .= "/" unless substr( $mirror_url, -1 ) eq "/";
159     my $test_file = "modules/03modlist.data.gz";
160     my_getstore(
161         cpan_url( $mirror_url, $test_file ),
162         catfile( $cache_dir, $test_file )
163     ) or die "ERROR: not a CPAN mirror '$mirror_url'\n";
164
165     if ($do_crosscheck) {
166         do_crosscheck(
167             $outfh, $cache_dir, $mirror_url, $verbose,
168             $force, \@modules,  \@wanted_upstreams
169         );
170     }
171     else {
172         $verbose > 2 and $use_diff++;
173         do_compare(
174             \@modules,  $outfh,      $output_file,
175             $cache_dir, $mirror_url, $verbose,
176             $use_diff,  $reverse,    $diff_opts,
177             \@wanted_upstreams
178         );
179     }
180 }
181
182 # construct a CPAN url
183
184 sub cpan_url {
185     my ( $mirror_url, @path ) = @_;
186     return $mirror_url unless @path;
187     my $cpan_path = join( "/", map { split "/", $_ } @path );
188     $cpan_path =~ s{\A/}{};    # remove leading slash since url has one trailing
189     return $mirror_url . $cpan_path;
190 }
191
192 # construct a CPAN URL for a author/distribution string like:
193 # BINGOS/Archive-Extract-0.52.tar.gz
194
195 sub cpan_url_distribution {
196     my ( $mirror_url, $distribution ) = @_;
197     $distribution =~ /^([A-Z])([A-Z])/
198         or die "ERROR: invalid DISTRIBUTION name (not /^[A-Z]{2}/): $distribution\n";
199     my $path = "authors/id/$1/$1$2/$distribution";
200     return cpan_url( $mirror_url, $path );
201 }
202
203 # compare a list of modules against their CPAN equivalents
204
205 sub do_compare {
206     my (
207         $modules,    $outfh,   $output_file, $cache_dir,
208         $mirror_url, $verbose, $use_diff,    $reverse,
209         $diff_opts,  $wanted_upstreams
210     ) = @_;
211
212     # first, make sure we have a directory where they can all be untarred,
213     # and if its a permanent directory, clear any previous content
214     my $untar_dir = catdir( $cache_dir, UNTAR_DIR );
215     my $src_dir   = catdir( $cache_dir, SRC_DIR );
216     for my $d ( $src_dir, $untar_dir ) {
217         next if -d $d;
218         mkdir $d or die "mkdir $d: $!\n";
219     }
220
221     my %ignorable = map { ( $_ => 1 ) } @Maintainers::IGNORABLE;
222     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
223
224     my %seen_dist;
225     for my $module (@$modules) {
226         warn "Processing $module ...\n" if defined $output_file;
227
228         my $m = $Maintainers::Modules{$module}
229           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
230
231         unless ( $m->{CPAN} ) {
232             print $outfh "WARNING: $module is not dual-life; skipping\n";
233             next;
234         }
235
236         my $dist = $m->{DISTRIBUTION};
237         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $dist;
238
239         if ( $seen_dist{$dist}++ ) {
240             warn "WARNING: duplicate entry for $dist in $module\n";
241         }
242
243         my $upstream = $m->{UPSTREAM} // 'undef';
244         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
245
246         print $outfh "\n$module - "
247           . $Maintainers::Modules{$module}->{DISTRIBUTION} . "\n";
248         print $outfh "  upstream is: "
249           . ( $m->{UPSTREAM} // 'UNKNOWN!' ) . "\n";
250
251         my $cpan_dir;
252         eval {
253             $cpan_dir =
254               get_distribution( $src_dir, $mirror_url, $untar_dir, $module,
255                 $dist );
256         };
257         if ($@) {
258             print $outfh "  ", $@;
259             print $outfh "  (skipping)\n";
260             next;
261         }
262
263         my @perl_files = Maintainers::get_module_files($module);
264
265         my $manifest = catfile( $cpan_dir, 'MANIFEST' );
266         die "ERROR: no such file: $manifest\n" unless -f $manifest;
267
268         my $cpan_files = ExtUtils::Manifest::maniread($manifest);
269         my @cpan_files = sort keys %$cpan_files;
270
271         ( my $main_pm = $module ) =~ s{::}{/}g;
272         $main_pm .= ".pm";
273
274         my ( $excluded, $map, $customized ) =
275           get_map( $m, $module, \@perl_files );
276
277         my %perl_unseen;
278         @perl_unseen{@perl_files} = ();
279         my %perl_files = %perl_unseen;
280
281         foreach my $cpan_file (@cpan_files) {
282             my $mapped_file =
283               cpan_to_perl( $excluded, $map, $customized, $cpan_file );
284             unless ( defined $mapped_file ) {
285                 print $outfh "  Excluded:  $cpan_file\n" if $verbose;
286                 next;
287             }
288
289             if ( exists $perl_files{$mapped_file} ) {
290                 delete $perl_unseen{$mapped_file};
291             }
292             else {
293
294                 # some CPAN files foo are stored in core as foo.packed,
295                 # which are then unpacked by 'make test_prep'
296                 my $packed_file = "$mapped_file.packed";
297                 if ( exists $perl_files{$packed_file} ) {
298                     if ( !-f $mapped_file and -f $packed_file ) {
299                         print $outfh <<EOF;
300 WARNING: $mapped_file not found, but .packed variant exists.
301 Perhaps you need to run 'make test_prep'?
302 EOF
303                         next;
304                     }
305                     delete $perl_unseen{$packed_file};
306                 }
307                 else {
308                     if ( $ignorable{$cpan_file} ) {
309                         print $outfh "  Ignored:   $cpan_file\n" if $verbose;
310                         next;
311                     }
312
313                     unless ($use_diff) {
314                         print $outfh "  CPAN only: $cpan_file",
315                           ( $cpan_file eq $mapped_file )
316                           ? "\n"
317                           : " (missing $mapped_file)\n";
318                     }
319                     next;
320                 }
321             }
322
323             my $abs_cpan_file = catfile( $cpan_dir, $cpan_file );
324
325             # should never happen
326             die "ERROR: can't find file $abs_cpan_file\n"
327               unless -f $abs_cpan_file;
328
329             # might happen if the FILES entry in Maintainers.pl is wrong
330             unless ( -f $mapped_file ) {
331                 print $outfh "WARNING: perl file not found: $mapped_file\n";
332                 next;
333             }
334
335             my $relative_mapped_file = relatively_mapped($mapped_file);
336
337             my $different =
338               file_diff( $outfh, $abs_cpan_file, $mapped_file, $reverse,
339                 $diff_opts );
340             if ( $different && customized( $m, $relative_mapped_file ) ) {
341                 print $outfh "  Customized for blead: $relative_mapped_file\n";
342                 if ( $use_diff && $verbose ) {
343                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
344                     print $outfh $different;
345                 }
346             }
347             elsif ($different) {
348                 if ($use_diff) {
349                     $different =~ s{^(--- |\+\+\+ )/tmp/[^/]+/}{$1}gm;
350                     print $outfh $different;
351                 }
352                 else {
353                     if ( $cpan_file eq $relative_mapped_file ) {
354                         print $outfh "  Modified:  $relative_mapped_file\n";
355                     }
356                     else {
357                         print $outfh
358                           "  Modified:  $cpan_file $relative_mapped_file\n";
359                     }
360
361                     if ( $cpan_file =~ m{\.pm\z} ) {
362                         my $pv = MM->parse_version($mapped_file)   || 'unknown';
363                         my $cv = MM->parse_version($abs_cpan_file) || 'unknown';
364                         if ( $pv ne $cv ) {
365                             print $outfh
366 "  Version mismatch in '$cpan_file':\n    $cv (cpan) vs $pv (perl)\n";
367                         }
368                     }
369
370                 }
371             }
372             elsif ( customized( $m, $relative_mapped_file ) ) {
373                 # Maintainers.pl says we customized it, but it looks the
374                 # same as CPAN so maybe we lost the customization, which
375                 # could be bad
376                 if ( $cpan_file eq $relative_mapped_file ) {
377                     print $outfh "  Blead customization missing: $cpan_file\n";
378                 }
379                 else {
380                     print $outfh
381                       "  Blead customization missing: $cpan_file $relative_mapped_file\n";
382                 }
383             }
384             elsif ($verbose) {
385                 if ( $cpan_file eq $relative_mapped_file ) {
386                     print $outfh "  Unchanged: $cpan_file\n";
387                 }
388                 else {
389                     print $outfh
390                       "  Unchanged: $cpan_file $relative_mapped_file\n";
391                 }
392             }
393         }
394         for ( sort keys %perl_unseen ) {
395             my $relative_mapped_file = relatively_mapped($_);
396             if ( customized( $m, $relative_mapped_file ) ) {
397                 print $outfh "  Customized for blead: $_\n";
398             }
399             else {
400                 print $outfh "  Perl only: $_\n" unless $use_diff;
401             }
402         }
403         if ( $verbose ) {
404             foreach my $exclude (@$excluded) {
405                 my $seen = 0;
406                 foreach my $cpan_file (@cpan_files) {
407                     # may be a simple string to match exactly, or a pattern
408                     if ( ref $exclude ) {
409                         $seen = 1 if $cpan_file =~ $exclude;
410                     }
411                     else {
412                         $seen = 1 if $cpan_file eq $exclude;
413                     }
414                     last if $seen;
415                 }
416                 if ( not $seen ) {
417                     print $outfh "  Unnecessary exclusion: $exclude\n";
418                 }
419             }
420         }
421     }
422 }
423
424 sub relatively_mapped {
425     my $relative = shift;
426     $relative =~ s/^(cpan|dist|ext)\/.*?\///;
427     return $relative;
428 }
429
430 # given FooBar-1.23_45.tar.gz, return FooBar
431
432 sub distro_base {
433     my $d = shift;
434     $d =~ s/\.tar\.gz$//;
435     $d =~ s/\.gip$//;
436     $d =~ s/[\d\-_\.]+$//;
437     return $d;
438 }
439
440 # process --crosscheck action:
441 # ie list all distributions whose CPAN versions differ from that listed in
442 # Maintainers.pl
443
444 sub do_crosscheck {
445     my (
446         $outfh, $cache_dir, $mirror_url, $verbose,
447         $force, $modules,   $wanted_upstreams,
448     ) = @_;
449
450     my $file         = '02packages.details.txt';
451     my $download_dir = $cache_dir || File::Temp::tempdir( CLEANUP => 1 );
452     my $path         = catfile( $download_dir, $file );
453     my $gzfile       = "$path.gz";
454
455     # grab 02packages.details.txt
456
457     my $url = cpan_url( $mirror_url, "modules/02packages.details.txt.gz" );
458
459     if ( !-f $gzfile or $force ) {
460         unlink $gzfile;
461         my_getstore( $url, $gzfile );
462     }
463     unlink $path;
464     IO::Uncompress::Gunzip::gunzip( $gzfile, $path )
465       or die
466       "ERROR: failed to ungzip $gzfile: $IO::Uncompress::Gunzip::GunzipError\n";
467
468     # suck in the data from it
469
470     open my $fh, '<', $path
471       or die "ERROR: open: $file: $!\n";
472
473     my %distros;
474     my %modules;
475
476     while (<$fh>) {
477         next if 1 .. /^$/;
478         chomp;
479         my @f = split ' ', $_;
480         if ( @f != 3 ) {
481             warn
482               "WARNING: $file:$.: line doesn't have three fields (skipping)\n";
483             next;
484         }
485         my $distro = $f[2];
486         $distro =~ s{^[A-Z]/[A-Z]{2}/}{};    # strip leading A/AB/
487         $modules{ $f[0] } = $distro;
488
489         ( my $short_distro = $distro ) =~ s{^.*/}{};
490
491         $distros{ distro_base($short_distro) }{$distro} = 1;
492     }
493
494     my %wanted_upstream = map { ( $_ => 1 ) } @$wanted_upstreams;
495     for my $module (@$modules) {
496         my $m = $Maintainers::Modules{$module}
497           or die "ERROR: No such module in Maintainers.pl: '$module'\n";
498
499         $verbose and warn "Checking $module\n";
500
501         unless ( $m->{CPAN} ) {
502             print $outfh "\nWARNING: $module is not dual-life; skipping\n";
503             next;
504         }
505
506         # given an entry like
507         #   Foo::Bar 1.23 foo-bar-1.23.tar.gz,
508         # first compare the module name against Foo::Bar, and failing that,
509         # against foo-bar
510
511         my $pdist = $m->{DISTRIBUTION};
512         die "ERROR: $module has no DISTRIBUTION entry\n" unless defined $pdist;
513
514         my $upstream = $m->{UPSTREAM} // 'undef';
515         next if @$wanted_upstreams and !$wanted_upstream{$upstream};
516
517         my $cdist = $modules{$module};
518         ( my $short_pdist = $pdist ) =~ s{^.*/}{};
519
520         unless ( defined $cdist ) {
521             my $d = $distros{ distro_base($short_pdist) };
522             unless ( defined $d ) {
523                 print $outfh "\n$module: Can't determine current CPAN entry\n";
524                 next;
525             }
526             if ( keys %$d > 1 ) {
527                 print $outfh
528                   "\n$module: (found more than one CPAN candidate):\n";
529                 print $outfh "    Perl: $pdist\n";
530                 print $outfh "    CPAN: $_\n" for sort keys %$d;
531                 next;
532             }
533             $cdist = ( keys %$d )[0];
534         }
535
536         if ( $cdist ne $pdist ) {
537             print $outfh "\n$module:\n    Perl: $pdist\n    CPAN: $cdist\n";
538         }
539     }
540 }
541
542 # get the EXCLUDED and MAP entries for this module, or
543 # make up defaults if they don't exist
544
545 sub get_map {
546     my ( $m, $module_name, $perl_files ) = @_;
547
548     my ( $excluded, $map, $customized ) = @$m{qw(EXCLUDED MAP CUSTOMIZED)};
549
550     $excluded   ||= [];
551     $customized ||= [];
552
553     return $excluded, $map, $customized if $map;
554
555     # all files under ext/foo-bar (plus maybe some under t/lib)???
556
557     my $ext;
558     for (@$perl_files) {
559         if (m{^((?:ext|dist|cpan)/[^/]+/)}) {
560             if ( defined $ext and $ext ne $1 ) {
561
562                 # more than one ext/$ext/
563                 undef $ext;
564                 last;
565             }
566             $ext = $1;
567         }
568         elsif (m{^t/lib/}) {
569             next;
570         }
571         else {
572             undef $ext;
573             last;
574         }
575     }
576
577     if ( defined $ext ) {
578         $map = { '' => $ext },;
579     }
580     else {
581         ( my $base = $module_name ) =~ s{::}{/}g;
582         $base = "lib/$base";
583         $map  = {
584             'lib/' => 'lib/',
585             ''     => "$base/",
586         };
587     }
588     return $excluded, $map, $customized;
589 }
590
591 # Given an exclude list and a mapping hash, convert a CPAN filename
592 # (eg 't/bar.t') to the equivalent perl filename (eg 'lib/Foo/Bar/t/bar.t').
593 # Returns an empty list for an excluded file
594
595 sub cpan_to_perl {
596     my ( $excluded, $map, $customized, $cpan_file ) = @_;
597
598     my %customized = map { ( $_ => 1 ) } @$customized;
599     for my $exclude (@$excluded) {
600         next if $customized{$exclude};
601
602         # may be a simple string to match exactly, or a pattern
603         if ( ref $exclude ) {
604             return if $cpan_file =~ $exclude;
605         }
606         else {
607             return if $cpan_file eq $exclude;
608         }
609     }
610
611     my $perl_file = $cpan_file;
612
613     # try longest prefix first, then alphabetically on tie-break
614     for
615       my $prefix ( sort { length($b) <=> length($a) || $a cmp $b } keys %$map )
616     {
617         last if $perl_file =~ s/^\Q$prefix/$map->{$prefix}/;
618     }
619     return $perl_file;
620 }
621
622 # fetch a file from a URL and store it in a file given by a filename
623
624 sub my_getstore {
625     my ( $url, $file ) = @_;
626     File::Path::mkpath( File::Basename::dirname($file) );
627     if ( $url =~ qr{\Afile://(?:localhost)?/} ) {
628         ( my $local_path = $url ) =~ s{\Afile://(?:localhost)?}{};
629         File::Copy::copy( $local_path, $file );
630     } else {
631         my $http = HTTP::Tiny->new;
632         my $response = $http->mirror($url, $file);
633         return $response->{success};
634     }
635 }
636
637 # download and unpack a distribution
638 # Returns the full pathname of the extracted directory
639 # (eg '/tmp/XYZ/Foo_bar-1.23')
640
641 # cache_dir:  where to download the .tar.gz file to
642 # mirror_url: CPAN mirror to download from
643 # untar_dir:  where to untar or unzup the file
644 # module:     name of module
645 # dist:       name of the distribution
646
647 sub get_distribution {
648     my ( $src_dir, $mirror_url, $untar_dir, $module, $dist ) = @_;
649
650     $dist =~ m{.+/([^/]+)$}
651       or die
652       "ERROR: $module: invalid DISTRIBUTION name (no AUTHOR/ prefix): $dist\n";
653     my $filename = $1;
654
655     my $download_file = catfile( $src_dir, $filename );
656
657     # download distribution
658
659     if ( -f $download_file and !-s $download_file ) {
660
661         # failed download might leave a zero-length file
662         unlink $download_file;
663     }
664
665     unless ( -f $download_file ) {
666
667         # not cached
668         my $url = cpan_url_distribution( $mirror_url, $dist );
669         my_getstore( $url, $download_file )
670           or die "ERROR: Could not fetch '$url'\n";
671     }
672
673     # get the expected name of the extracted distribution dir
674
675     my $path = catfile( $untar_dir, $filename );
676
677     $path =~ s/\.tar\.gz$//
678       or $path =~ s/\.tgz$//
679       or $path =~ s/\.zip$//
680       or die
681       "ERROR: downloaded file does not have a recognised suffix: $path\n";
682
683     # extract it unless we already have it cached or tarball is newer
684     if ( !-d $path || ( -M $download_file < -M $path ) ) {
685         $path = extract( $download_file, $untar_dir )
686           or die
687           "ERROR: failed to extract distribution '$download_file to temp. dir: "
688           . $! . "\n";
689     }
690
691     die "ERROR: Extracted tarball does not appear as $path\n" unless -d $path;
692
693     return $path;
694 }
695
696 # produce the diff of a single file
697 sub file_diff {
698     my $outfh     = shift;
699     my $cpan_file = shift;
700     my $perl_file = shift;
701     my $reverse   = shift;
702     my $diff_opts = shift;
703
704     my @cmd = ( DIFF_CMD, split ' ', $diff_opts );
705     if ($reverse) {
706         push @cmd, $perl_file, $cpan_file;
707     }
708     else {
709         push @cmd, $cpan_file, $perl_file;
710     }
711     return `@cmd`;
712
713 }
714
715 sub customized {
716     my ( $module_data, $file ) = @_;
717     return grep { $file eq $_ } @{ $module_data->{CUSTOMIZED} };
718 }
719
720 sub extract {
721   my ($archive,$to) = @_;
722   my $cwd = cwd();
723   chdir $to or die "$!\n";
724   my @files;
725   EXTRACT: {
726     local $Archive::Tar::CHOWN = 0;
727     my $next;
728     unless ( $next = Archive::Tar->iter( $archive, 1 ) ) {
729        $! = $Archive::Tar::error;
730        last EXTRACT;
731     }
732     while ( my $file = $next->() ) {
733       push @files, $file->full_path;
734       unless ( $file->extract ) {
735         $! = $Archive::Tar::error;
736         last EXTRACT;
737       }
738     }
739   }
740   my $path = __get_extract_dir( \@files );
741   chdir $cwd or die "$!\n";
742   return $path;
743 }
744
745 sub __get_extract_dir {
746     my $files   = shift || [];
747
748     return unless scalar @$files;
749
750     my($dir1, $dir2);
751     for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
752         my($dir,$pos) = @$aref;
753
754         ### add a catdir(), so that any trailing slashes get
755         ### take care of (removed)
756         ### also, a catdir() normalises './dir/foo' to 'dir/foo';
757         ### which was the problem in bug #23999
758         my $res = -d $files->[$pos]
759                     ? File::Spec->catdir( $files->[$pos], '' )
760                     : File::Spec->catdir( File::Basename::dirname( $files->[$pos] ) );
761
762         $$dir = $res;
763     }
764
765     ### if the first and last dir don't match, make sure the
766     ### dirname is not set wrongly
767     my $dir;
768
769     ### dirs are the same, so we know for sure what the extract dir is
770     if( $dir1 eq $dir2 ) {
771         $dir = $dir1;
772
773     ### dirs are different.. do they share the base dir?
774     ### if so, use that, if not, fall back to '.'
775     } else {
776         my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
777         my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
778
779         $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
780     }
781
782     return File::Spec->rel2abs( $dir );
783 }
784
785 run();
786