scripts/Dpkg/Source/Archive.pm

   1 # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 =encoding utf8
  17
  18 =head1 NAME
  19
  20 Dpkg::Source::Archive - source tarball archive support
  21
  22 =head1 DESCRIPTION
  23
  24 This module provides a class that implements support for handling
  25 source tarballs.
  26
  27 B<Note>: This is a private module, its API can change at any time.
  28
  29 =cut
  30
  31 package Dpkg::Source::Archive 0.01;
  32
  33 use strict;
  34 use warnings;
  35
  36 use Carp;
  37 use Errno qw(ENOENT);
  38 use File::Temp qw(tempdir);
  39 use File::Basename qw(basename);
  40 use File::Spec;
  41 use File::Find;
  42 use Cwd;
  43
  44 use Dpkg ();
  45 use Dpkg::Gettext;
  46 use Dpkg::ErrorHandling;
  47 use Dpkg::IPC;
  48 use Dpkg::Source::Functions qw(erasedir fixperms);
  49
  50 use parent qw(Dpkg::Compression::FileHandle);
  51
  52 sub create {
  53     my ($self, %opts) = @_;
  54     $opts{options} //= [];
  55     my %spawn_opts;
  56     # Possibly run tar from another directory
  57     if ($opts{chdir}) {
  58         $spawn_opts{chdir} = $opts{chdir};
  59         *$self->{chdir} = $opts{chdir};
  60     }
  61     # Redirect input/output appropriately
  62     $self->ensure_open('w');
  63     $spawn_opts{to_handle} = $self->get_filehandle();
  64     $spawn_opts{from_pipe} = \*$self->{tar_input};
  65     # Try to use a deterministic mtime.
  66     my $mtime = $opts{source_date} // $ENV{SOURCE_DATE_EPOCH} || time;
  67     # Call tar creation process
  68     $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ];
  69     $spawn_opts{exec} = [
  70         $Dpkg::PROGTAR, '-cf', '-', '--format=gnu', '--sort=name',
  71                         '--mtime', "\@$mtime", '--clamp-mtime', '--null',
  72                         '--numeric-owner', '--owner=0', '--group=0',
  73                         @{$opts{options}}, '-T', '-',
  74     ];
  75     *$self->{pid} = spawn(%spawn_opts);
  76     *$self->{cwd} = getcwd();
  77 }
  78
  79 sub _add_entry {
  80     my ($self, $file) = @_;
  81     my $cwd = *$self->{cwd};
  82     croak 'call create() first' unless *$self->{tar_input};
  83     if ($file =~ m{^\Q$cwd\E/(.+)$}) {
  84         # Make pathname relative to the source root directory.
  85         $file = $1;
  86     }
  87     print({ *$self->{tar_input} } "$file\0")
  88         or syserr(g_('write on tar input'));
  89 }
  90
  91 sub add_file {
  92     my ($self, $file) = @_;
  93     my $testfile = $file;
  94     if (*$self->{chdir}) {
  95         $testfile = File::Spec->catfile(*$self->{chdir}, $file);
  96     }
  97     croak 'add_file() does not handle directories'
  98         if not -l $testfile and -d _;
  99     $self->_add_entry($file);
 100 }
 101
 102 sub add_directory {
 103     my ($self, $file) = @_;
 104     my $testfile = $file;
 105     if (*$self->{chdir}) {
 106         $testfile = File::Spec->catdir(*$self->{chdir}, $file);
 107     }
 108     croak 'add_directory() only handles directories'
 109         if -l $testfile or not -d _;
 110     $self->_add_entry($file);
 111 }
 112
 113 sub finish {
 114     my $self = shift;
 115
 116     close(*$self->{tar_input}) or syserr(g_('close on tar input'));
 117     wait_child(*$self->{pid}, cmdline => "$Dpkg::PROGTAR -cf -");
 118     delete *$self->{pid};
 119     delete *$self->{tar_input};
 120     delete *$self->{cwd};
 121     delete *$self->{chdir};
 122     $self->close();
 123 }
 124
 125 sub extract {
 126     my ($self, $dest, %opts) = @_;
 127     $opts{options} //= [];
 128     $opts{in_place} //= 0;
 129     $opts{no_fixperms} //= 0;
 130     my %spawn_opts = (wait_child => 1);
 131
 132     # Prepare destination
 133     my $template = basename($self->get_filename()) .  '.tmp-extract.XXXXX';
 134     unless (-e $dest) {
 135         # Kludge so that realpath works
 136         mkdir($dest) or syserr(g_('cannot create directory %s'), $dest);
 137     }
 138     my $tmp = tempdir($template, DIR => Cwd::realpath("$dest/.."), CLEANUP => 1);
 139     $spawn_opts{chdir} = $tmp;
 140
 141     # Prepare stuff that handles the input of tar
 142     $self->ensure_open('r', delete_sig => [ 'PIPE' ]);
 143     $spawn_opts{from_handle} = $self->get_filehandle();
 144
 145     # Call tar extraction process
 146     $spawn_opts{delete_env} = [ 'TAR_OPTIONS' ];
 147     $spawn_opts{exec} = [
 148         $Dpkg::PROGTAR, '-xf', '-', '--no-same-permissions',
 149                         '--no-same-owner', @{$opts{options}},
 150     ];
 151     spawn(%spawn_opts);
 152     $self->close();
 153
 154     # Fix permissions on extracted files because tar insists on applying
 155     # our umask _to the original permissions_ rather than mostly-ignoring
 156     # the original permissions.
 157     # We still need --no-same-permissions because otherwise tar might
 158     # extract directory setgid (which we want inherited, not
 159     # extracted); we need --no-same-owner because putting the owner
 160     # back is tedious - in particular, correct group ownership would
 161     # have to be calculated using mount options and other madness.
 162     fixperms($tmp) unless $opts{no_fixperms};
 163
 164     # If we are extracting "in-place" do not remove the destination directory.
 165     if ($opts{in_place}) {
 166         my $canon_basedir = Cwd::realpath($dest);
 167         # On Solaris /dev/null points to /devices/pseudo/mm@0:null.
 168         my $canon_devnull = Cwd::realpath('/dev/null');
 169         my $check_symlink = sub {
 170             my $pathname = shift;
 171             my $canon_pathname = Cwd::realpath($pathname);
 172             if (not defined $canon_pathname) {
 173                 return if $! == ENOENT;
 174
 175                 syserr(g_("pathname '%s' cannot be canonicalized"), $pathname);
 176             }
 177             return if $canon_pathname eq $canon_devnull;
 178             return if $canon_pathname eq $canon_basedir;
 179             return if $canon_pathname =~ m{^\Q$canon_basedir/\E};
 180             warning(g_("pathname '%s' points outside source root (to '%s')"),
 181                     $pathname, $canon_pathname);
 182         };
 183
 184         my $move_in_place = sub {
 185             my $relpath = File::Spec->abs2rel($File::Find::name, $tmp);
 186             my $destpath = File::Spec->catfile($dest, $relpath);
 187
 188             my ($mode, $atime, $mtime);
 189             lstat $File::Find::name
 190                 or syserr(g_('cannot get source pathname %s metadata'), $File::Find::name);
 191             ((undef) x 2, $mode, (undef) x 5, $atime, $mtime) = lstat _;
 192             my $src_is_dir = -d _;
 193
 194             my $dest_exists = 1;
 195             if (not lstat $destpath) {
 196                 if ($! == ENOENT) {
 197                     $dest_exists = 0;
 198                 } else {
 199                     syserr(g_('cannot get target pathname %s metadata'), $destpath);
 200                 }
 201             }
 202             my $dest_is_dir = -d _;
 203             if ($dest_exists) {
 204                 if ($dest_is_dir && $src_is_dir) {
 205                     # Refresh the destination directory attributes with the
 206                     # ones from the tarball.
 207                     chmod $mode, $destpath
 208                         or syserr(g_('cannot change directory %s mode'), $File::Find::name);
 209                     utime $atime, $mtime, $destpath
 210                         or syserr(g_('cannot change directory %s times'), $File::Find::name);
 211
 212                     # We should do nothing, and just walk further tree.
 213                     return;
 214                 } elsif ($dest_is_dir) {
 215                     rmdir $destpath
 216                         or syserr(g_('cannot remove destination directory %s'), $destpath);
 217                 } else {
 218                     $check_symlink->($destpath);
 219                     unlink $destpath
 220                         or syserr(g_('cannot remove destination file %s'), $destpath);
 221                 }
 222             }
 223             # If we are moving a directory, we do not need to walk it.
 224             if ($src_is_dir) {
 225                 $File::Find::prune = 1;
 226             }
 227             rename $File::Find::name, $destpath
 228                 or syserr(g_('cannot move %s to %s'), $File::Find::name, $destpath);
 229         };
 230
 231         find({
 232             wanted => $move_in_place,
 233             no_chdir => 1,
 234             dangling_symlinks => 0,
 235         }, $tmp);
 236     } else {
 237         # Rename extracted directory
 238         opendir(my $dir_dh, $tmp) or syserr(g_('cannot opendir %s'), $tmp);
 239         my @entries = grep { $_ ne '.' && $_ ne '..' } readdir($dir_dh);
 240         closedir($dir_dh);
 241
 242         erasedir($dest);
 243
 244         if (scalar(@entries) == 1 && ! -l "$tmp/$entries[0]" && -d _) {
 245             rename("$tmp/$entries[0]", $dest)
 246                 or syserr(g_('unable to rename %s to %s'),
 247                           "$tmp/$entries[0]", $dest);
 248         } else {
 249             rename($tmp, $dest)
 250                 or syserr(g_('unable to rename %s to %s'), $tmp, $dest);
 251         }
 252     }
 253     erasedir($tmp);
 254 }
 255
 256 =head1 CHANGES
 257
 258 =head2 Version 0.xx
 259
 260 This is a private module.
 261
 262 =cut
 263
 264 1;