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
16=encoding utf8
17
18 - 29
=head1 NAME

Dpkg::Source::Functions - miscellaneous source package handling functions

=head1 DESCRIPTION

This module provides a set of miscellaneous helper functions to handle
source packages.

B<Note>: This is a private module, its API can change at any time.

=cut
30
31package Dpkg::Source::Functions 0.01;
32
33
24
24
24
24
57
14
323
use strict;
34
24
24
24
24
86
20
725
use warnings;
35
36our @EXPORT_OK = qw(
37    erasedir
38    fixperms
39    chmod_if_needed
40    fs_time
41    is_binary
42);
43
44
24
24
24
24
81
14
322
use Exporter qw(import);
45
24
24
24
24
1695
8040
1061
use Errno qw(ENOENT);
46
47
24
24
24
24
378
26
859
use Dpkg::ErrorHandling;
48
24
24
24
24
44
22
596
use Dpkg::Gettext;
49
24
24
24
24
2122
18
560
use Dpkg::File;
50
24
24
24
24
1006
20
6600
use Dpkg::IPC;
51
52sub erasedir {
53
6
6
0
9
    my $dir = shift;
54
6
50
18
    if (not lstat($dir)) {
55
0
0
0
        return if $! == ENOENT;
56
0
0
        syserr(g_('cannot stat directory %s (before removal)'), $dir);
57    }
58
6
13496
    system 'rm', '-rf', '--', $dir;
59
6
50
109
    subprocerr("rm -rf $dir") if $?;
60
6
50
75
    if (not stat($dir)) {
61
6
50
196
        return if $! == ENOENT;
62
0
0
        syserr(g_("unable to check for removal of directory '%s'"), $dir);
63    }
64
0
0
    error(g_("rm -rf failed to remove '%s'"), $dir);
65}
66
67sub fixperms {
68
3
3
0
3
    my $dir = shift;
69
3
3
    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
3
17
    $mode = 0777 & ~umask;
77
3
8
    for my $i (0 .. 2) {
78
9
100
10
        $modes_set .= ',' if $i;
79
9
9
        $modes_set .= qw(u g o)[$i];
80
9
11
        for my $j (0 .. 2) {
81
27
100
23
            $modes_set .= $mode & (0400 >> ($i * 3 + $j)) ? '+' : '-';
82
27
21
            $modes_set .= qw(r w X)[$j];
83        }
84    }
85
3
4983
    system('chmod', '-R', '--', $modes_set, $dir);
86
3
50
63
    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.
93sub chmod_if_needed {
94
0
0
0
0
    my ($newperms, $pathname) = @_;
95
0
0
    my $oldperms = (stat $pathname)[2] & 07777;
96
97
0
0
0
    return 1 if $oldperms == $newperms;
98
0
0
    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.
108sub fs_time($) {
109
6
6
0
6
    my $file = shift;
110
6
6
    my $is_temp = 0;
111
6
50
38
    if (not -e $file) {
112
0
0
        file_touch($file);
113
0
0
        $is_temp = 1;
114    } else {
115
6
50
44
        utime(undef, undef, $file) or
116            syserr(g_('cannot change timestamp for %s'), $file);
117    }
118
6
50
20
    stat($file) or syserr(g_('cannot read timestamp from %s'), $file);
119
6
10
    my $mtime = (stat(_))[9];
120
6
50
6
    unlink($file) if $is_temp;
121
6
12
    return $mtime;
122}
123
124sub is_binary($) {
125
0
0
0
    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
0
0
    open my $fh, '<', $file
130        or syserr(g_('cannot open file %s for binary detection'), $file);
131
0
    read $fh, my $buf, 4096, 0;
132
0
    my $res = index $buf, "\0";
133
0
    close $fh;
134
135
0
    return $res >= 0;
136}
137
138 - 144
=head1 CHANGES

=head2 Version 0.xx

This is a private module.

=cut
145
1461;