File Coverage

File:Dpkg/Source/Functions.pm
Coverage:65.8%

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