File: | Dpkg/Source/Functions.pm |
Coverage: | 65.8% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
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 | 7 7 7 | 15 4 77 | use strict; | ||||
19 | 7 7 7 | 12 2 223 | use warnings; | ||||
20 | |||||||
21 | our $VERSION = '0.01'; | ||||||
22 | our @EXPORT_OK = qw( | ||||||
23 | erasedir | ||||||
24 | fixperms | ||||||
25 | chmod_if_needed | ||||||
26 | fs_time | ||||||
27 | is_binary | ||||||
28 | ); | ||||||
29 | |||||||
30 | 7 7 7 | 14 4 73 | use Exporter qw(import); | ||||
31 | 7 7 7 | 601 2506 244 | use Errno qw(ENOENT); | ||||
32 | |||||||
33 | 7 7 7 | 128 5 192 | use Dpkg::ErrorHandling; | ||||
34 | 7 7 7 | 11 4 124 | use Dpkg::Gettext; | ||||
35 | 7 7 7 | 643 7 131 | use Dpkg::File; | ||||
36 | 7 7 7 | 135 4 1610 | use Dpkg::IPC; | ||||
37 | |||||||
38 | sub erasedir { | ||||||
39 | 1 | 0 | 1 | my $dir = shift; | |||
40 | 1 | 4 | if (not lstat($dir)) { | ||||
41 | 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 | 18 | subprocerr("rm -rf $dir") if $?; | ||||
46 | 1 | 12 | if (not stat($dir)) { | ||||
47 | 1 | 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 | |||||||
53 | sub fixperms { | ||||||
54 | 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 | 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 | 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 | 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. | ||||||
79 | sub chmod_if_needed { | ||||||
80 | 0 | 0 | 0 | my ($newperms, $pathname) = @_; | |||
81 | 0 | 0 | my $oldperms = (stat $pathname)[2] & 07777; | ||||
82 | |||||||
83 | 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. | ||||||
94 | sub fs_time($) { | ||||||
95 | 2 | 0 | 2 | my $file = shift; | |||
96 | 2 | 6 | my $is_temp = 0; | ||||
97 | 2 | 18 | if (not -e $file) { | ||||
98 | 0 | 0 | file_touch($file); | ||||
99 | 0 | 0 | $is_temp = 1; | ||||
100 | } else { | ||||||
101 | 2 | 18 | utime(undef, undef, $file) or | ||||
102 | syserr(g_('cannot change timestamp for %s'), $file); | ||||||
103 | } | ||||||
104 | 2 | 8 | stat($file) or syserr(g_('cannot read timestamp from %s'), $file); | ||||
105 | 2 | 2 | my $mtime = (stat(_))[9]; | ||||
106 | 2 | 4 | unlink($file) if $is_temp; | ||||
107 | 2 | 182 | return $mtime; | ||||
108 | } | ||||||
109 | |||||||
110 | sub is_binary($) { | ||||||
111 | 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 | 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 | |||||||
124 | 1; |