From: Raphael Hertzog Date: Sat, 16 Feb 2008 19:20:36 +0000 (+0100) Subject: Dpkg::Source::Archiver: new module to work with tar archives X-Git-Url: https://err.no/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=6a773fa3d22ff6c267c4d74020f0130b25ccc76e;p=dpkg 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. --- diff --git a/scripts/Dpkg/Source/Archiver.pm b/scripts/Dpkg/Source/Archiver.pm new file mode 100644 index 00000000..c88c5780 --- /dev/null +++ b/scripts/Dpkg/Source/Archiver.pm @@ -0,0 +1,217 @@ +# Copyright 2008 Raphaël Hertzog + +# 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]= 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; diff --git a/scripts/Makefile.am b/scripts/Makefile.am index ef4cf307..f6bcb3e2 100644 --- a/scripts/Makefile.am +++ b/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 diff --git a/scripts/dpkg-source.pl b/scripts/dpkg-source.pl index aa0be565..ce1c72d0 100755 --- a/scripts/dpkg-source.pl +++ b/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]= 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) = @_; diff --git a/scripts/po/POTFILES.in b/scripts/po/POTFILES.in index 1ca810de..80667180 100644 --- a/scripts/po/POTFILES.in +++ b/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