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 =encoding utf8
  17
  18 =head1 NAME
  19
  20 Dpkg::Source::Functions - miscellaneous source package handling functions
  21
  22 =head1 DESCRIPTION
  23
  24 This module provides a set of miscellaneous helper functions to handle
  25 source packages.
  26
  27 B<Note>: This is a private module, its API can change at any time.
  28
  29 =cut
  30
  31 package Dpkg::Source::Functions 0.01;
  32
  33 use strict;
  34 use warnings;
  35
  36 our @EXPORT_OK = qw(
  37     erasedir
  38     fixperms
  39     chmod_if_needed
  40     fs_time
  41     is_binary
  42 );
  43
  44 use Exporter qw(import);
  45 use Errno qw(ENOENT);
  46
  47 use Dpkg::ErrorHandling;
  48 use Dpkg::Gettext;
  49 use Dpkg::File;
  50 use Dpkg::IPC;
  51
  52 sub erasedir {
  53     my $dir = shift;
  54     if (not lstat($dir)) {
  55         return if $! == ENOENT;
  56         syserr(g_('cannot stat directory %s (before removal)'), $dir);
  57     }
  58     system 'rm', '-rf', '--', $dir;
  59     subprocerr("rm -rf $dir") if $?;
  60     if (not stat($dir)) {
  61         return if $! == ENOENT;
  62         syserr(g_("unable to check for removal of directory '%s'"), $dir);
  63     }
  64     error(g_("rm -rf failed to remove '%s'"), $dir);
  65 }
  66
  67 sub fixperms {
  68     my $dir = shift;
  69     my ($mode, $modes_set);
  70     # Unfortunately tar insists on applying our umask _to the original
  71     # permissions_ rather than mostly-ignoring the original
  72     # permissions.  We fix it up with chmod -R (which saves us some
  73     # work) but we have to construct a u+/- string which is a bit
  74     # of a palaver.  (Numeric doesn't work because we need [ugo]+X
  75     # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.)
  76     $mode = 0777 & ~umask;
  77     for my $i (0 .. 2) {
  78         $modes_set .= ',' if $i;
  79         $modes_set .= qw(u g o)[$i];
  80         for my $j (0 .. 2) {
  81             $modes_set .= $mode & (0400 >> ($i * 3 + $j)) ? '+' : '-';
  82             $modes_set .= qw(r w X)[$j];
  83         }
  84     }
  85     system('chmod', '-R', '--', $modes_set, $dir);
  86     subprocerr("chmod -R -- $modes_set $dir") if $?;
  87 }
  88
  89 # Only change the pathname permissions if they differ from the desired.
  90 #
  91 # To be able to build a source tree, a user needs write permissions on it,
  92 # but not necessarily ownership of those files.
  93 sub chmod_if_needed {
  94     my ($newperms, $pathname) = @_;
  95     my $oldperms = (stat $pathname)[2] & 07777;
  96
  97     return 1 if $oldperms == $newperms;
  98     return chmod $newperms, $pathname;
  99 }
 100
 101 # Touch the file and read the resulting mtime.
 102 #
 103 # If the file doesn't exist, create it, read the mtime and unlink it.
 104 #
 105 # Use this instead of time() when the timestamp is going to be
 106 # used to set file timestamps. This avoids confusion when an
 107 # NFS server and NFS client disagree about what time it is.
 108 sub fs_time {
 109     my $file = shift;
 110     my $is_temp = 0;
 111     if (not -e $file) {
 112         file_touch($file);
 113         $is_temp = 1;
 114     } else {
 115         utime(undef, undef, $file) or
 116             syserr(g_('cannot change timestamp for %s'), $file);
 117     }
 118     stat($file) or syserr(g_('cannot read timestamp from %s'), $file);
 119     my $mtime = (stat(_))[9];
 120     unlink($file) if $is_temp;
 121     return $mtime;
 122 }
 123
 124 sub is_binary {
 125     my $file = shift;
 126
 127     # Perform the same check as diff(1), look for a NUL character in the first
 128     # 4 KiB of the file.
 129     open my $fh, '<', $file
 130         or syserr(g_('cannot open file %s for binary detection'), $file);
 131     read $fh, my $buf, 4096, 0;
 132     my $res = index $buf, "\0";
 133     close $fh;
 134
 135     return $res >= 0;
 136 }
 137
 138 =head1 CHANGES
 139
 140 =head2 Version 0.xx
 141
 142 This is a private module.
 143
 144 =cut
 145
 146 1;