Dpkg::Source::Archiver: new module to work with tar archives

* scripts/Dpkg/Source/Archive.pm: New module handling tar
archive creation and extraction.
* scripts/dpkg-source.pl: Updated and simplified to use the new module.
* scripts/Makefile.am: Add new modules to dist tarball.
* scripts/po/POTFILES.in: Add new module in list of files to scan for
translations.

scripts/Dpkg/Source/Archiver.pm

@@ -0,0 +1,217 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Archiver;
+
+use strict;
+use warnings;
+
+use Dpkg::Source::Compressor;
+use Dpkg::Compression;
+use Dpkg::Gettext;
+use Dpkg::IPC;
+use Dpkg::ErrorHandling qw(error syserr warning);
+
+use POSIX;
+use File::Temp qw(tempdir);
+use File::Path qw(rmtree mkpath);
+use File::Basename qw(basename);
+
+sub new {
+    my ($this, %args) = @_;
+    my $class = ref($this) || $this;
+    my $self = {};
+    bless $self, $class;
+    if (exists $args{"compression"}) {
+	$self->use_compression($args{"compression"});
+    }
+    if (exists $args{"compression_level"}) {
+	$self->set_compression_level($args{"compression_level"});
+    }
+    if (exists $args{"filename"}) {
+	$self->set_filename($args{"filename"});
+    }
+    return $self;
+}
+
+sub reset {
+    my ($self) = @_;
+    %{$self} = ();
+}
+
+sub use_compression {
+    my ($self, $method) = @_;
+    error(_g("%s is not a supported compression method"), $method)
+	    unless $comp_supported{$method};
+    $self->{"compression"} = $method;
+}
+
+sub set_compression_level {
+    my ($self, $level) = @_;
+    error(_g("%s is not a compression level"), $level)
+            unless $level =~ /^([1-9]|fast|best)$/;
+    $self->{"compression_level"} = $level;
+}
+
+sub set_filename {
+    my ($self, $filename) = @_;
+    $self->{"filename"} = $filename;
+    # Check if compression is used
+    foreach my $comp (@comp_supported) {
+	if ($filename =~ /^(.*)\.\Q$comp_ext{$comp}\E$/) {
+	    $self->use_compression($comp);
+	    last;
+	}
+    }
+}
+
+sub get_filename {
+    my $self = shift;
+    return $self->{"filename"};
+}
+
+sub create {
+    my ($self, %opts) = @_;
+    $opts{"options"} ||= [];
+    my %fork_opts;
+    # Prepare stuff that handles the output of tar
+    if ($self->{"compression"}) {
+	$self->{"compressor"} = Dpkg::Source::Compressor->new(
+	    compressed_filename => $self->get_filename(),
+	    compression => $self->{"compression"},
+	);
+	$self->{"compressor"}->compress(from_pipe => \$fork_opts{"to_handle"});
+    } else {
+	$fork_opts{"to_file"} = $self->get_filename();
+    }
+    # Prepare input to tar
+    $fork_opts{"from_pipe"} = \$self->{'tar_input'};
+    # Call tar creation process
+    $fork_opts{'exec'} = [ 'tar', '--null', '-T', '-', @{$opts{"options"}}, '-cf', '-' ];
+    $self->{"pid"} = fork_and_exec(%fork_opts);
+    binmode($self->{'tar_input'});
+    $self->{"cwd"} = getcwd();
+}
+
+sub _add_entry {
+    my ($self, $file) = @_;
+    error("call create first") unless $self->{"tar_input"};
+    $file = $2 if ($file =~ /^\Q$self->{'cwd'}\E\/(.+)$/); # Relative names
+    print { $self->{'tar_input'} } "$file\0" ||
+	    syserr(_g("write on tar input"));
+}
+
+sub add_file {
+    my ($self, $file) = @_;
+    error("add_file() doesn't handle directories") if not -l $file and -d _;
+    $self->_add_entry($file);
+}
+
+sub add_directory {
+    my ($self, $file) = @_;
+    error("add_directory() only handles directories") unless not -l $file and -d _;
+    $self->_add_entry($file);
+}
+
+sub close {
+    my ($self) = @_;
+    close($self->{'tar_input'}) or syserr(_g("close on tar input"));
+    wait_child($self->{'pid'}, cmdline => 'tar -cf -');
+    $self->{'compressor'}->wait_end_process() if $self->{'compressor'};
+    delete $self->{'pid'};
+    delete $self->{'tar_input'};
+    delete $self->{'cwd'};
+    delete $self->{'compressor'};
+}
+
+sub extract {
+    my ($self, $dest, %opts) = @_;
+    $opts{"options"} ||= [];
+    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;
+
+    # Prepare stuff that handles the input of tar
+    if ($self->{"compression"}) {
+	$self->{"compressor"} = Dpkg::Source::Compressor->new(
+	    compressed_filename => $self->get_filename(),
+	    compression => $self->{"compression"},
+	);
+	$self->{"compressor"}->uncompress(to_pipe => \$fork_opts{"from_handle"});
+    } else {
+	$fork_opts{"from_file"} = $self->get_filename();
+    }
+
+    # Call tar extraction process
+    $fork_opts{'exec'} = [ 'tar', '--no-same-owner', '--no-same-permissions',
+	    @{$opts{"options"}}, '-xkf', '-' ];
+    fork_and_exec(%fork_opts);
+
+    # Clean up compressor
+    $self->{'compressor'}->wait_end_process() if $self->{'compressor'};
+    delete $self->{'compressor'};
+
+    # 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.)
+    #
+    # 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 $?;
+
+    # Rename extracted directory
+    opendir(D, $tmp) || syserr(_g("Unable to open dir %s"), $tmp);
+    my @entries = grep { $_ ne "." && $_ ne ".." } readdir(D);
+    closedir(D);
+    my $done = 0;
+    rmtree($dest) if -e $dest;
+    if (scalar(@entries) == 1 && -d "$tmp/$entries[0]") {
+	rename("$tmp/$entries[0]", $dest) ||
+		syserr(_g("Unable to rename %s to %s"),
+		       "$tmp/$entries[0]", $dest);
+    } else {
+	rename($tmp, $dest) || syserr(_g("Unable to rename %s to %s"),
+				      "$tmp/$_", "$dest/$_");
+    }
+    rmtree($tmp);
+}
+
+1;

scripts/Makefile.am

@@ -104,6 +104,8 @@ nobase_dist_perllib_DATA = \
 	Dpkg/Substvars.pm \
 	Dpkg/Vars.pm \
 	Dpkg/Version.pm \
+	Dpkg/Source/Archiver.pm \
+	Dpkg/Source/Compressor.pm \
 	Dpkg/Source/VCS/git.pm \
 	Dpkg.pm
 

scripts/dpkg-source.pl

@@ -19,6 +19,7 @@ use Dpkg::Version qw(check_version);
 use Dpkg::Vars;
 use Dpkg::Changelog qw(parse_changelog);
 use Dpkg::Source::Compressor;
+use Dpkg::Source::Archiver;
 
 my @filesinarchive;
 my %dirincluded;
@@ -589,24 +590,16 @@ if ($opmode eq 'build') {
         }
 
         printf(_g("%s: building %s in %s")."\n",
-               $progname, $sourcepackage, $tarname)
-            || &syserr(_g("write building tar message"));
-	my ($ntfh, $newtar) = tempfile( "$tarname.new.XXXXXX",
-					DIR => &getcwd, UNLINK => 0 );
-        &forkgzipwrite($newtar);
-	defined(my $c2 = fork) || syserr(_g("fork for tar"));
-        if (!$c2) {
-            chdir($tardirbase) ||
-                syserr(_g("chdir to above (orig) source %s"), $tardirbase);
-            open(STDOUT,">&GZIP") || &syserr(_g("reopen gzip for tar"));
-            # FIXME: put `--' argument back when tar is fixed
-            exec('tar',@tar_ignore,'-cf','-',$tardirname) or &syserr(_g("exec tar"));
-        }
-        close(GZIP);
-        &reapgzip;
-        $c2 == waitpid($c2,0) || &syserr(_g("wait for tar"));
-        $? && !(WIFSIGNALED($c2) && WTERMSIG($c2) == SIGPIPE) && subprocerr("tar");
-        rename($newtar,$tarname) ||
+               $progname, $sourcepackage, $tarname);
+
+	my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
+				       DIR => getcwd(), UNLINK => 0);
+	my $tar = Dpkg::Source::Archiver->new(filename => $newtar,
+		    compression => get_compression_from_filename($tarname));
+	$tar->create(options => \@tar_ignore);
+	$tar->add_directory($tardirname);
+	$tar->close();
+        rename($newtar, $tarname) ||
             syserr(_g("unable to rename `%s' (newly created) to `%s'"),
                    $newtar, $tarname);
 	chmod(0666 &~ umask(), $tarname) ||
@@ -615,9 +608,8 @@ if ($opmode eq 'build') {
     } else {
         
         printf(_g("%s: building %s using existing %s")."\n",
-               $progname, $sourcepackage, $tarname)
-            || &syserr(_g("write using existing tar message"));
-        
+               $progname, $sourcepackage, $tarname);
+
     }
     
     addfile($fields, "$tarname");
@@ -638,18 +630,8 @@ if ($opmode eq 'build') {
         }
 
         $expectprefix= $origdir; $expectprefix =~ s,^\./,,;
-	my $expectprefix_dirname = $origdirname;
-        mkdir("$origtargz.tmp-nest",0755) ||
-            syserr(_g("unable to create `%s'"), "$origtargz.tmp-nest");
-	push @exit_handlers, sub { erasedir("$origtargz.tmp-nest") };
-        extracttar($origtargz,"$origtargz.tmp-nest",$expectprefix_dirname);
-        rename("$origtargz.tmp-nest/$expectprefix_dirname",$expectprefix) ||
-            syserr(_g("unable to rename `%s' to `%s'"),
-                   "$origtargz.tmp-nest/$expectprefix_dirname",
-                   $expectprefix);
-        rmdir("$origtargz.tmp-nest") ||
-            syserr(_g("unable to remove `%s'"), "$origtargz.tmp-nest");
-	    pop @exit_handlers;
+	my $tar = Dpkg::Source::Archiver->new(filename => $origtargz);
+	$tar->extract($expectprefix);
     }
 
     if ($sourcestyle eq 'v') {
@@ -1013,16 +995,9 @@ if ($opmode eq 'build') {
 	    $target = $expectprefix;
 	}
 
-	my $tmp = "$target.tmp-nest";
-	(my $t = $target) =~ s!.*/!!;
-
-	mkdir($tmp, 0700) || syserr(_g("unable to create `%s'"), $tmp);
 	printf(_g("%s: unpacking %s")."\n", $progname, $tarfile);
-	extracttar("$dscdir/$tarfile",$tmp,$t);
-	rename("$tmp/$t",$target)
-	    || syserr(_g("unable to rename `%s' to `%s'"), "$tmp/$t", $target);
-	rmdir($tmp)
-	    || syserr(_g("unable to remove `%s'"), $tmp);
+	my $tar = Dpkg::Source::Archiver->new(filename => "$dscdir/$tarfile");
+	$tar->extract($target);
 
 	# for the first tar file:
 	if ($tarfile eq $tarfiles[0] and !$native)
@@ -1324,81 +1299,6 @@ sub checkdiff
     &reapgzip if $diff =~ /\.$comp_regex$/;
 }
 
-sub extracttar {
-    my ($tarfileread,$dirchdir,$newtopdir) = @_;
-    my ($mode, $modes_set, $i, $j);
-    &forkgzipread("$tarfileread");
-    defined(my $c2 = fork) || syserr(_g("fork for tar -xkf -"));
-    if (!$c2) {
-        open(STDIN,"<&GZIP") || &syserr(_g("reopen gzip for tar -xkf -"));
-        &cpiostderr;
-	chdir($dirchdir) ||
-	    syserr(_g("cannot chdir to `%s' for tar extract"), $dirchdir);
-	exec('tar','--no-same-owner','--no-same-permissions',
-	     '-xkf','-') or &syserr(_g("exec tar -xkf -"));
-    }
-    close(GZIP);
-    $c2 == waitpid($c2,0) || &syserr(_g("wait for tar -xkf -"));
-    $? && subprocerr("tar -xkf -");
-    &reapgzip;
-
-    # 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.)
-    #
-    # 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,'--',$dirchdir;
-    $? && subprocerr("chmod -R $modes_set $dirchdir");
-
-    opendir(D, "$dirchdir") || syserr(_g("Unable to open dir %s"), $dirchdir);
-    my @dirchdirfiles = grep($_ ne "." && $_ ne "..", readdir(D));
-    closedir(D) || syserr(_g("Unable to close dir %s"), $dirchdir);
-    if (@dirchdirfiles==1 && -d "$dirchdir/$dirchdirfiles[0]") {
-	rename("$dirchdir/$dirchdirfiles[0]", "$dirchdir/$newtopdir") ||
-	    syserr(_g("Unable to rename %s to %s"),
-	           "$dirchdir/$dirchdirfiles[0]",
-	           "$dirchdir/$newtopdir");
-    } else {
-	mkdir("$dirchdir/$newtopdir.tmp", 0777) or
-	    syserr(_g("Unable to mkdir %s"), "$dirchdir/$newtopdir.tmp");
-	for (@dirchdirfiles) {
-	    rename("$dirchdir/$_", "$dirchdir/$newtopdir.tmp/$_") or
-	        syserr(_g("Unable to rename %s to %s"),
-	               "$dirchdir/$_",
-	               "$dirchdir/$newtopdir.tmp/$_");
-	}
-	rename("$dirchdir/$newtopdir.tmp", "$dirchdir/$newtopdir") or
-	    syserr(_g("Unable to rename %s to %s"),
-	           "$dirchdir/$newtopdir.tmp",
-	           "$dirchdir/$newtopdir");
-    }
-}
-
-sub cpiostderr {
-    open(STDERR,"| grep -E -v '^[0-9]+ blocks\$' >&2") ||
-        &syserr(_g("reopen stderr for tar to grep out blocks message"));
-}
-
 sub checktype {
     my ($dir, $fn, $type) = @_;
 

scripts/po/POTFILES.in

@@ -26,6 +26,7 @@ scripts/Dpkg/IPC.pm
 scripts/Dpkg/Shlibs.pm
 scripts/Dpkg/Shlibs/Objdump.pm
 scripts/Dpkg/Shlibs/SymbolFile.pm
+scripts/Dpkg/Source/Archiver.pm
 scripts/Dpkg/Source/Compressor.pm
 scripts/Dpkg/Source/VCS/git.pm
 scripts/Dpkg/Substvars.pm