Commit | Line | Data |
---|---|---|
1479465f GJ |
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; |