--- /dev/null
+# 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;
Dpkg/Substvars.pm \
Dpkg/Vars.pm \
Dpkg/Version.pm \
+ Dpkg/Source/Archiver.pm \
+ Dpkg/Source/Compressor.pm \
Dpkg/Source/VCS/git.pm \
Dpkg.pm
use Dpkg::Vars;
use Dpkg::Changelog qw(parse_changelog);
use Dpkg::Source::Compressor;
+use Dpkg::Source::Archiver;
my @filesinarchive;
my %dirincluded;
}
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) ||
} 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");
}
$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') {
$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)
&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/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
projects / dpkg / commitdiff