Allow in-place extraction of a tar archive

* scripts/Dpkg/Source/Archive.pm: New "in_place" option to
extract an archive in the target directory instead of replacing
the whole target directory. Replace the logic to fix permissions
by fixperms() which is a...
* scripts/Dpkg/Source/Functions.pm (fixperms): new function to
fix permissions on a given directory so that they match the rights
expected through the umask.

2 files changed, 42 insertions, 32 deletions

diff --git a/scripts/Dpkg/Source/Archive.pm b/scripts/Dpkg/Source/Archive.pm
index 380f4ff36..5974e5111 100644
--- a/scripts/Dpkg/Source/Archive.pm
+++ b/scripts/Dpkg/Source/Archive.pm
@@ -19,10 +19,7 @@ package Dpkg::Source::Archive;
 use strict;
 use warnings;
 
-use Dpkg::Source::Functions qw(erasedir);
-use Dpkg::Source::CompressedFile;
-use Dpkg::Source::Compressor;
-use Dpkg::Compression;
+use Dpkg::Source::Functions qw(erasedir fixperms);
 use Dpkg::Gettext;
 use Dpkg::IPC;
 use Dpkg::ErrorHandling qw(error syserr warning);
@@ -95,12 +92,20 @@ sub finish {
 sub extract {
     my ($self, $dest, %opts) = @_;
     $opts{"options"} ||= [];
+    $opts{"in_place"} ||= 0;
+    $opts{"no_fixperms"} ||= 0;
     my %fork_opts = (wait_child => 1);
 
     # Prepare destination
-    my $template = basename($self->get_filename()) .  ".tmp-extract.XXXXX";
-    my $tmp = tempdir($template, DIR => getcwd(), CLEANUP => 1);
-    $fork_opts{"chdir"} = $tmp;
+    my $tmp;
+    if ($opts{"in_place"}) {
+        $fork_opts{"chdir"} = $dest;
+        $tmp = $dest; # So that fixperms call works
+    } else {
+        my $template = basename($self->get_filename()) .  ".tmp-extract.XXXXX";
+        $tmp = tempdir($template, DIR => getcwd(), CLEANUP => 1);
+        $fork_opts{"chdir"} = $tmp;
+    }
 
     # Prepare stuff that handles the input of tar
     $fork_opts{"from_handle"} = $self->open_for_read();
@@ -111,35 +116,18 @@ sub extract {
     fork_and_exec(%fork_opts);
     $self->cleanup_after_open();
 
-    # Fix permissions on extracted files...
-    my ($mode, $modes_set, $i, $j);
-    # Unfortunately tar insists on applying our umask _to the original
-    # permissions_ rather than mostly-ignoring the original
-    # permissions.  We fix it up with chmod -R (which saves us some
-    # work) but we have to construct a u+/- string which is a bit
-    # of a palaver.  (Numeric doesn't work because we need [ugo]+X
-    # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.)
-    #
+    # Fix permissions on extracted files because tar insists on applying
+    # our umask _to the original permissions_ rather than mostly-ignoring
+    # the original permissions.
     # We still need --no-same-permissions because otherwise tar might
     # extract directory setgid (which we want inherited, not
     # extracted); we need --no-same-owner because putting the owner
     # back is tedious - in particular, correct group ownership would
     # have to be calculated using mount options and other madness.
-    #
-    # It would be nice if tar could do it right, or if pax could cope
-    # with GNU format tarfiles with long filenames.
-    #
-    $mode = 0777 & ~umask;
-    for ($i = 0; $i < 9; $i += 3) {
-	$modes_set .= ',' if $i;
-	$modes_set .= qw(u g o)[$i/3];
-	for ($j = 0; $j < 3; $j++) {
-	    $modes_set .= $mode & (0400 >> ($i+$j)) ? '+' : '-';
-	    $modes_set .= qw(r w X)[$j];
-	}
-    }
-    system('chmod', '-R', $modes_set, '--', $tmp);
-    subprocerr("chmod -R $modes_set $tmp") if $?;
+    fixperms($tmp) unless $opts{"no_fixperms"};
+
+    # Stop here if we extracted in-place as there's nothing to move around
+    return if $opts{"in_place"};
 
     # Rename extracted directory
     opendir(D, $tmp) || syserr(_g("cannot opendir %s"), $tmp);
diff --git a/scripts/Dpkg/Source/Functions.pm b/scripts/Dpkg/Source/Functions.pm
index d55c25921..9ad04632f 100644
--- a/scripts/Dpkg/Source/Functions.pm
+++ b/scripts/Dpkg/Source/Functions.pm
@@ -5,7 +5,7 @@ use warnings;
 
 use Exporter;
 our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(erasedir);
+our @EXPORT_OK = qw(erasedir fixperms);
 
 use Dpkg::ErrorHandling qw(syserr subprocerr failure);
 use Dpkg::Gettext;
@@ -27,5 +27,27 @@ sub erasedir {
     failure(_g("rm -rf failed to remove `%s'"), $dir);
 }
 
+sub fixperms {
+    my ($dir) = @_;
+    my ($mode, $modes_set, $i, $j);
+    # Unfortunately tar insists on applying our umask _to the original
+    # permissions_ rather than mostly-ignoring the original
+    # permissions.  We fix it up with chmod -R (which saves us some
+    # work) but we have to construct a u+/- string which is a bit
+    # of a palaver.  (Numeric doesn't work because we need [ugo]+X
+    # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.)
+    $mode = 0777 & ~umask;
+    for ($i = 0; $i < 9; $i += 3) {
+        $modes_set .= ',' if $i;
+        $modes_set .= qw(u g o)[$i/3];
+        for ($j = 0; $j < 3; $j++) {
+            $modes_set .= $mode & (0400 >> ($i+$j)) ? '+' : '-';
+            $modes_set .= qw(r w X)[$j];
+        }
+    }
+    system('chmod', '-R', $modes_set, '--', $dir);
+    subprocerr("chmod -R $modes_set $dir") if $?;
+}
+
 # vim: set et sw=4 ts=8
 1;