chiark - git - mdw - dpkg/blob - scripts/Dpkg/Source/Functions.pm

   1 # Copyright © 2008-2010, 2012-2015 Guillem Jover <guillem@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 package Dpkg::Source::Functions;
  17
  18 use strict;
  19 use warnings;
  20
  21 our $VERSION = '0.01';
  22 our @EXPORT_OK = qw(
  23     erasedir
  24     fixperms
  25     fs_time
  26     is_binary
  27 );
  28
  29 use Exporter qw(import);
  30 use POSIX qw(:errno_h);
  31
  32 use Dpkg::ErrorHandling;
  33 use Dpkg::Gettext;
  34 use Dpkg::IPC;
  35
  36 sub erasedir {
  37     my $dir = shift;
  38     if (not lstat($dir)) {
  39         return if $! == ENOENT;
  40         syserr(g_('cannot stat directory %s (before removal)'), $dir);
  41     }
  42     system 'rm', '-rf', '--', $dir;
  43     subprocerr("rm -rf $dir") if $?;
  44     if (not stat($dir)) {
  45         return if $! == ENOENT;
  46         syserr(g_("unable to check for removal of directory '%s'"), $dir);
  47     }
  48     error(g_("rm -rf failed to remove '%s'"), $dir);
  49 }
  50
  51 sub fixperms {
  52     my $dir = shift;
  53     my ($mode, $modes_set);
  54     # Unfortunately tar insists on applying our umask _to the original
  55     # permissions_ rather than mostly-ignoring the original
  56     # permissions.  We fix it up with chmod -R (which saves us some
  57     # work) but we have to construct a u+/- string which is a bit
  58     # of a palaver.  (Numeric doesn't work because we need [ugo]+X
  59     # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.)
  60     $mode = 0777 & ~umask;
  61     for my $i (0 .. 2) {
  62         $modes_set .= ',' if $i;
  63         $modes_set .= qw(u g o)[$i];
  64         for my $j (0 .. 2) {
  65             $modes_set .= $mode & (0400 >> ($i * 3 + $j)) ? '+' : '-';
  66             $modes_set .= qw(r w X)[$j];
  67         }
  68     }
  69     system('chmod', '-R', '--', $modes_set, $dir);
  70     subprocerr("chmod -R -- $modes_set $dir") if $?;
  71 }
  72
  73 # Touch the file and read the resulting mtime.
  74 #
  75 # If the file doesn't exist, create it, read the mtime and unlink it.
  76 #
  77 # Use this instead of time() when the timestamp is going to be
  78 # used to set file timestamps. This avoids confusion when an
  79 # NFS server and NFS client disagree about what time it is.
  80 sub fs_time($) {
  81     my $file = shift;
  82     my $is_temp = 0;
  83     if (not -e $file) {
  84         open(my $temp_fh, '>', $file) or syserr(g_('cannot write %s'));
  85         close($temp_fh);
  86         $is_temp = 1;
  87     } else {
  88         utime(undef, undef, $file) or
  89             syserr(g_('cannot change timestamp for %s'), $file);
  90     }
  91     stat($file) or syserr(g_('cannot read timestamp from %s'), $file);
  92     my $mtime = (stat(_))[9];
  93     unlink($file) if $is_temp;
  94     return $mtime;
  95 }
  96
  97 sub is_binary($) {
  98     my $file = shift;
  99
 100     # TODO: might want to reimplement what diff does, aka checking if the
 101     # file contains \0 in the first 4Kb of data
 102
 103     # Use diff to check if it's a binary file
 104     my $diffgen;
 105     my $diff_pid = spawn(
 106         exec => [ 'diff', '-u', '--', '/dev/null', $file ],
 107         env => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' },
 108         to_pipe => \$diffgen,
 109     );
 110     my $result = 0;
 111     local $_;
 112     while (<$diffgen>) {
 113         if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) {
 114             $result = 1;
 115             last;
 116         } elsif (m/^[-+\@ ]/) {
 117             $result = 0;
 118             last;
 119         }
 120     }
 121     close($diffgen) or syserr('close on diff pipe');
 122     wait_child($diff_pid, nocheck => 1, cmdline => "diff -u -- /dev/null $file");
 123     return $result;
 124 }
 125
 126 1;