+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 );
+}
+