File: | Dpkg/Source/Patch.pm |
Coverage: | 34.5% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org> | ||||||
2 | # Copyright © 2008-2010, 2012-2015 Guillem Jover <guillem@debian.org> | ||||||
3 | # | ||||||
4 | # This program is free software; you can redistribute it and/or modify | ||||||
5 | # it under the terms of the GNU General Public License as published by | ||||||
6 | # the Free Software Foundation; either version 2 of the License, or | ||||||
7 | # (at your option) any later version. | ||||||
8 | # | ||||||
9 | # This program is distributed in the hope that it will be useful, | ||||||
10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||
11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||
12 | # GNU General Public License for more details. | ||||||
13 | # | ||||||
14 | # You should have received a copy of the GNU General Public License | ||||||
15 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | ||||||
16 | |||||||
17 | package Dpkg::Source::Patch; | ||||||
18 | |||||||
19 | 4 4 4 | 8 4 44 | use strict; | ||||
20 | 4 4 4 | 4 4 103 | use warnings; | ||||
21 | |||||||
22 | our $VERSION = '0.01'; | ||||||
23 | |||||||
24 | 4 4 4 | 7 7 11 | use POSIX qw(:errno_h :sys_wait_h); | ||||
25 | 4 4 4 | 1116 3 79 | use File::Find; | ||||
26 | 4 4 4 | 5 4 80 | use File::Basename; | ||||
27 | 4 4 4 | 8 0 62 | use File::Spec; | ||||
28 | 4 4 4 | 7 1 65 | use File::Path qw(make_path); | ||||
29 | 4 4 4 | 534 1458 87 | use File::Compare; | ||||
30 | 4 4 4 | 9 3 312 | use Fcntl ':mode'; | ||||
31 | 4 4 4 | 8 1 11 | use Time::HiRes qw(stat); | ||||
32 | |||||||
33 | 4 4 4 | 480 4 68 | use Dpkg; | ||||
34 | 4 4 4 | 344 3 91 | use Dpkg::Gettext; | ||||
35 | 4 4 4 | 356 30 115 | use Dpkg::ErrorHandling; | ||||
36 | 4 4 4 | 514 1 116 | use Dpkg::IPC; | ||||
37 | 4 4 4 | 457 0 93 | use Dpkg::Source::Functions qw(fs_time); | ||||
38 | |||||||
39 | 4 4 4 | 8 4 8 | use parent qw(Dpkg::Compression::FileHandle); | ||||
40 | |||||||
41 | sub create { | ||||||
42 | 0 | 0 | 0 | my ($self, %opts) = @_; | |||
43 | 0 | 0 | $self->ensure_open('w'); # Creates the file | ||||
44 | 0 | 0 | *$self->{errors} = 0; | ||||
45 | 0 | 0 | *$self->{empty} = 1; | ||||
46 | 0 | 0 | if ($opts{old} and $opts{new} and $opts{filename}) { | ||||
47 | 0 | 0 | $opts{old} = '/dev/null' unless -e $opts{old}; | ||||
48 | 0 | 0 | $opts{new} = '/dev/null' unless -e $opts{new}; | ||||
49 | 0 | 0 | if (-d $opts{old} and -d $opts{new}) { | ||||
50 | 0 | 0 | $self->add_diff_directory($opts{old}, $opts{new}, %opts); | ||||
51 | } elsif (-f $opts{old} and -f $opts{new}) { | ||||||
52 | 0 | 0 | $self->add_diff_file($opts{old}, $opts{new}, %opts); | ||||
53 | } else { | ||||||
54 | 0 | 0 | $self->_fail_not_same_type($opts{old}, $opts{new}, $opts{filename}); | ||||
55 | } | ||||||
56 | 0 | 0 | $self->finish() unless $opts{nofinish}; | ||||
57 | } | ||||||
58 | } | ||||||
59 | |||||||
60 | sub set_header { | ||||||
61 | 0 | 0 | 0 | my ($self, $header) = @_; | |||
62 | 0 | 0 | *$self->{header} = $header; | ||||
63 | } | ||||||
64 | |||||||
65 | sub get_header { | ||||||
66 | 0 | 0 | 0 | my $self = shift; | |||
67 | |||||||
68 | 0 | 0 | if (ref *$self->{header} eq 'CODE') { | ||||
69 | 0 | 0 | return *$self->{header}->(); | ||||
70 | } else { | ||||||
71 | 0 | 0 | return *$self->{header}; | ||||
72 | } | ||||||
73 | } | ||||||
74 | |||||||
75 | sub add_diff_file { | ||||||
76 | 0 | 0 | 0 | my ($self, $old, $new, %opts) = @_; | |||
77 | 0 | 0 | $opts{include_timestamp} //= 0; | ||||
78 | my $handle_binary = $opts{handle_binary_func} // sub { | ||||||
79 | 0 | 0 | my ($self, $old, $new, %opts) = @_; | ||||
80 | 0 | 0 | my $file = $opts{filename}; | ||||
81 | 0 | 0 | $self->_fail_with_msg($file, g_('binary file contents changed')); | ||||
82 | 0 | 0 | }; | ||||
83 | # Optimization to avoid forking diff if unnecessary | ||||||
84 | 0 | 0 | return 1 if compare($old, $new, 4096) == 0; | ||||
85 | # Default diff options | ||||||
86 | 0 | 0 | my @options; | ||||
87 | 0 | 0 | if ($opts{options}) { | ||||
88 | 0 0 | 0 0 | push @options, @{$opts{options}}; | ||||
89 | } else { | ||||||
90 | 0 | 0 | push @options, '-p'; | ||||
91 | } | ||||||
92 | # Add labels | ||||||
93 | 0 | 0 | if ($opts{label_old} and $opts{label_new}) { | ||||
94 | 0 | 0 | if ($opts{include_timestamp}) { | ||||
95 | 0 | 0 | my $ts = (stat($old))[9]; | ||||
96 | 0 | 0 | my $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); | ||||
97 | 0 | 0 | $opts{label_old} .= sprintf("\t%s.%09d +0000", $t, | ||||
98 | ($ts - int($ts)) * 1_000_000_000); | ||||||
99 | 0 | 0 | $ts = (stat($new))[9]; | ||||
100 | 0 | 0 | $t = POSIX::strftime('%Y-%m-%d %H:%M:%S', gmtime($ts)); | ||||
101 | 0 | 0 | $opts{label_new} .= sprintf("\t%s.%09d +0000", $t, | ||||
102 | ($ts - int($ts)) * 1_000_000_000); | ||||||
103 | } else { | ||||||
104 | # Space in filenames need special treatment | ||||||
105 | 0 | 0 | $opts{label_old} .= "\t" if $opts{label_old} =~ / /; | ||||
106 | 0 | 0 | $opts{label_new} .= "\t" if $opts{label_new} =~ / /; | ||||
107 | } | ||||||
108 | push @options, '-L', $opts{label_old}, | ||||||
109 | 0 | 0 | '-L', $opts{label_new}; | ||||
110 | } | ||||||
111 | # Generate diff | ||||||
112 | 0 | 0 | my $diffgen; | ||||
113 | 0 | 0 | my $diff_pid = spawn( | ||||
114 | exec => [ 'diff', '-u', @options, '--', $old, $new ], | ||||||
115 | env => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' }, | ||||||
116 | to_pipe => \$diffgen, | ||||||
117 | ); | ||||||
118 | # Check diff and write it in patch file | ||||||
119 | 0 | 0 | my $difflinefound = 0; | ||||
120 | 0 | 0 | my $binary = 0; | ||||
121 | 0 | 0 | local $_; | ||||
122 | |||||||
123 | 0 | 0 | while (<$diffgen>) { | ||||
124 | 0 | 0 | if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) { | ||||
125 | 0 | 0 | $binary = 1; | ||||
126 | 0 | 0 | $handle_binary->($self, $old, $new, %opts); | ||||
127 | 0 | 0 | last; | ||||
128 | } elsif (m/^[-+\@ ]/) { | ||||||
129 | 0 | 0 | $difflinefound++; | ||||
130 | } elsif (m/^\\ /) { | ||||||
131 | 0 | 0 | warning(g_('file %s has no final newline (either ' . | ||||
132 | 'original or modified version)'), $new); | ||||||
133 | } else { | ||||||
134 | 0 | 0 | chomp; | ||||
135 | 0 | 0 | error(g_("unknown line from diff -u on %s: '%s'"), $new, $_); | ||||
136 | } | ||||||
137 | 0 | 0 | if (*$self->{empty} and defined(*$self->{header})) { | ||||
138 | 0 | 0 | $self->print($self->get_header()) or syserr(g_('failed to write')); | ||||
139 | 0 | 0 | *$self->{empty} = 0; | ||||
140 | } | ||||||
141 | 0 0 | 0 0 | print { $self } $_ or syserr(g_('failed to write')); | ||||
142 | } | ||||||
143 | 0 | 0 | close($diffgen) or syserr('close on diff pipe'); | ||||
144 | 0 | 0 | wait_child($diff_pid, nocheck => 1, | ||||
145 | cmdline => "diff -u @options -- $old $new"); | ||||||
146 | # Verify diff process ended successfully | ||||||
147 | # Exit code of diff: 0 => no difference, 1 => diff ok, 2 => error | ||||||
148 | # Ignore error if binary content detected | ||||||
149 | 0 | 0 | my $exit = WEXITSTATUS($?); | ||||
150 | 0 | 0 | unless (WIFEXITED($?) && ($exit == 0 || $exit == 1 || $binary)) { | ||||
151 | 0 | 0 | subprocerr(g_('diff on %s'), $new); | ||||
152 | } | ||||||
153 | 0 | 0 | return ($exit == 0 || $exit == 1); | ||||
154 | } | ||||||
155 | |||||||
156 | sub add_diff_directory { | ||||||
157 | 0 | 0 | 0 | my ($self, $old, $new, %opts) = @_; | |||
158 | # TODO: make this function more configurable | ||||||
159 | # - offer to disable some checks | ||||||
160 | 0 | 0 | my $basedir = $opts{basedirname} || basename($new); | ||||
161 | 0 | 0 | my $diff_ignore; | ||||
162 | 0 | 0 | if ($opts{diff_ignore_func}) { | ||||
163 | 0 | 0 | $diff_ignore = $opts{diff_ignore_func}; | ||||
164 | } elsif ($opts{diff_ignore_regex}) { | ||||||
165 | 0 0 | 0 0 | $diff_ignore = sub { return $_[0] =~ /$opts{diff_ignore_regex}/o }; | ||||
166 | } else { | ||||||
167 | 0 0 | 0 0 | $diff_ignore = sub { return 0 }; | ||||
168 | } | ||||||
169 | |||||||
170 | 0 | 0 | my @diff_files; | ||||
171 | my %files_in_new; | ||||||
172 | my $scan_new = sub { | ||||||
173 | 0 | 0 | my $fn = (length > length($new)) ? substr($_, length($new) + 1) : '.'; | ||||
174 | 0 | 0 | return if $diff_ignore->($fn); | ||||
175 | 0 | 0 | $files_in_new{$fn} = 1; | ||||
176 | 0 | 0 | lstat("$new/$fn") or syserr(g_('cannot stat file %s'), "$new/$fn"); | ||||
177 | 0 | 0 | my $mode = S_IMODE((lstat(_))[2]); | ||||
178 | 0 | 0 | my $size = (lstat(_))[7]; | ||||
179 | 0 | 0 | if (-l _) { | ||||
180 | 0 | 0 | unless (-l "$old/$fn") { | ||||
181 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
182 | 0 | 0 | return; | ||||
183 | } | ||||||
184 | 0 | 0 | my $n = readlink("$new/$fn"); | ||||
185 | 0 | 0 | unless (defined $n) { | ||||
186 | 0 | 0 | syserr(g_('cannot read link %s'), "$new/$fn"); | ||||
187 | } | ||||||
188 | 0 | 0 | my $n2 = readlink("$old/$fn"); | ||||
189 | 0 | 0 | unless (defined $n2) { | ||||
190 | 0 | 0 | syserr(g_('cannot read link %s'), "$old/$fn"); | ||||
191 | } | ||||||
192 | 0 | 0 | unless ($n eq $n2) { | ||||
193 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
194 | } | ||||||
195 | } elsif (-f _) { | ||||||
196 | 0 | 0 | my $old_file = "$old/$fn"; | ||||
197 | 0 | 0 | if (not lstat("$old/$fn")) { | ||||
198 | 0 | 0 | if ($! != ENOENT) { | ||||
199 | 0 | 0 | syserr(g_('cannot stat file %s'), "$old/$fn"); | ||||
200 | } | ||||||
201 | 0 | 0 | $old_file = '/dev/null'; | ||||
202 | } elsif (not -f _) { | ||||||
203 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
204 | 0 | 0 | return; | ||||
205 | } | ||||||
206 | |||||||
207 | 0 | 0 | my $label_old = "$basedir.orig/$fn"; | ||||
208 | 0 | 0 | if ($opts{use_dev_null}) { | ||||
209 | 0 | 0 | $label_old = $old_file if $old_file eq '/dev/null'; | ||||
210 | } | ||||||
211 | 0 | 0 | push @diff_files, [$fn, $mode, $size, $old_file, "$new/$fn", | ||||
212 | $label_old, "$basedir/$fn"]; | ||||||
213 | } elsif (-p _) { | ||||||
214 | 0 | 0 | unless (-p "$old/$fn") { | ||||
215 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
216 | } | ||||||
217 | } elsif (-b _ || -c _ || -S _) { | ||||||
218 | 0 | 0 | $self->_fail_with_msg("$new/$fn", | ||||
219 | g_('device or socket is not allowed')); | ||||||
220 | } elsif (-d _) { | ||||||
221 | 0 | 0 | if (not lstat("$old/$fn")) { | ||||
222 | 0 | 0 | if ($! != ENOENT) { | ||||
223 | 0 | 0 | syserr(g_('cannot stat file %s'), "$old/$fn"); | ||||
224 | } | ||||||
225 | } elsif (not -d _) { | ||||||
226 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
227 | } | ||||||
228 | } else { | ||||||
229 | 0 | 0 | $self->_fail_with_msg("$new/$fn", g_('unknown file type')); | ||||
230 | } | ||||||
231 | 0 | 0 | }; | ||||
232 | my $scan_old = sub { | ||||||
233 | 0 | 0 | my $fn = (length > length($old)) ? substr($_, length($old) + 1) : '.'; | ||||
234 | 0 | 0 | return if $diff_ignore->($fn); | ||||
235 | 0 | 0 | return if $files_in_new{$fn}; | ||||
236 | 0 | 0 | lstat("$old/$fn") or syserr(g_('cannot stat file %s'), "$old/$fn"); | ||||
237 | 0 | 0 | if (-f _) { | ||||
238 | 0 | 0 | if (not defined $opts{include_removal}) { | ||||
239 | 0 | 0 | warning(g_('ignoring deletion of file %s'), $fn); | ||||
240 | } elsif (not $opts{include_removal}) { | ||||||
241 | 0 | 0 | warning(g_('ignoring deletion of file %s, use --include-removal to override'), $fn); | ||||
242 | } else { | ||||||
243 | 0 | 0 | push @diff_files, [$fn, 0, 0, "$old/$fn", '/dev/null', | ||||
244 | "$basedir.orig/$fn", '/dev/null']; | ||||||
245 | } | ||||||
246 | } elsif (-d _) { | ||||||
247 | 0 | 0 | warning(g_('ignoring deletion of directory %s'), $fn); | ||||
248 | } elsif (-l _) { | ||||||
249 | 0 | 0 | warning(g_('ignoring deletion of symlink %s'), $fn); | ||||
250 | } else { | ||||||
251 | 0 | 0 | $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn); | ||||
252 | } | ||||||
253 | 0 | 0 | }; | ||||
254 | |||||||
255 | 0 | 0 | find({ wanted => $scan_new, no_chdir => 1 }, $new); | ||||
256 | 0 | 0 | find({ wanted => $scan_old, no_chdir => 1 }, $old); | ||||
257 | |||||||
258 | 0 | 0 | if ($opts{order_from} and -e $opts{order_from}) { | ||||
259 | my $order_from = Dpkg::Source::Patch->new( | ||||||
260 | 0 | 0 | filename => $opts{order_from}); | ||||
261 | 0 | 0 | my $analysis = $order_from->analyze($basedir, verbose => 0); | ||||
262 | 0 | 0 | my %patchorder; | ||||
263 | 0 | 0 | my $i = 0; | ||||
264 | 0 0 | 0 0 | foreach my $fn (@{$analysis->{patchorder}}) { | ||||
265 | 0 | 0 | $fn =~ s{^[^/]+/}{}; | ||||
266 | 0 | 0 | $patchorder{$fn} = $i++; | ||||
267 | } | ||||||
268 | # 'quilt refresh' sorts files as follows: | ||||||
269 | # - Any files in the existing patch come first, in the order in | ||||||
270 | # which they appear in the existing patch. | ||||||
271 | # - New files follow, sorted lexicographically. | ||||||
272 | # This seems a reasonable policy to follow, and avoids autopatches | ||||||
273 | # being shuffled when they are regenerated. | ||||||
274 | 0 0 | 0 0 | foreach my $diff_file (sort { $a->[0] cmp $b->[0] } @diff_files) { | ||||
275 | 0 | 0 | my $fn = $diff_file->[0]; | ||||
276 | 0 | 0 | $patchorder{$fn} //= $i++; | ||||
277 | } | ||||||
278 | 0 0 | 0 0 | @diff_files = sort { $patchorder{$a->[0]} <=> $patchorder{$b->[0]} } | ||||
279 | @diff_files; | ||||||
280 | } else { | ||||||
281 | 0 0 | 0 0 | @diff_files = sort { $a->[0] cmp $b->[0] } @diff_files; | ||||
282 | } | ||||||
283 | |||||||
284 | 0 | 0 | foreach my $diff_file (@diff_files) { | ||||
285 | 0 | 0 | my ($fn, $mode, $size, | ||||
286 | $old_file, $new_file, $label_old, $label_new) = @$diff_file; | ||||||
287 | 0 | 0 | my $success = $self->add_diff_file($old_file, $new_file, | ||||
288 | filename => $fn, | ||||||
289 | label_old => $label_old, | ||||||
290 | label_new => $label_new, %opts); | ||||||
291 | 0 | 0 | if ($success and | ||||
292 | $old_file eq '/dev/null' and $new_file ne '/dev/null') { | ||||||
293 | 0 | 0 | if (not $size) { | ||||
294 | 0 | 0 | warning(g_("newly created empty file '%s' will not " . | ||||
295 | 'be represented in diff'), $fn); | ||||||
296 | } else { | ||||||
297 | 0 | 0 | if ($mode & (S_IXUSR | S_IXGRP | S_IXOTH)) { | ||||
298 | 0 | 0 | warning(g_("executable mode %04o of '%s' will " . | ||||
299 | 'not be represented in diff'), $mode, $fn) | ||||||
300 | unless $fn eq 'debian/rules'; | ||||||
301 | } | ||||||
302 | 0 | 0 | if ($mode & (S_ISUID | S_ISGID | S_ISVTX)) { | ||||
303 | 0 | 0 | warning(g_("special mode %04o of '%s' will not " . | ||||
304 | 'be represented in diff'), $mode, $fn); | ||||||
305 | } | ||||||
306 | } | ||||||
307 | } | ||||||
308 | } | ||||||
309 | } | ||||||
310 | |||||||
311 | sub finish { | ||||||
312 | 0 | 0 | 0 | my $self = shift; | |||
313 | 0 | 0 | close($self) or syserr(g_('cannot close %s'), $self->get_filename()); | ||||
314 | 0 | 0 | return not *$self->{errors}; | ||||
315 | } | ||||||
316 | |||||||
317 | sub register_error { | ||||||
318 | 0 | 0 | 0 | my $self = shift; | |||
319 | 0 | 0 | *$self->{errors}++; | ||||
320 | } | ||||||
321 | sub _fail_with_msg { | ||||||
322 | 0 | 0 | my ($self, $file, $msg) = @_; | ||||
323 | 0 | 0 | errormsg(g_('cannot represent change to %s: %s'), $file, $msg); | ||||
324 | 0 | 0 | $self->register_error(); | ||||
325 | } | ||||||
326 | sub _fail_not_same_type { | ||||||
327 | 0 | 0 | my ($self, $old, $new, $file) = @_; | ||||
328 | 0 | 0 | my $old_type = get_type($old); | ||||
329 | 0 | 0 | my $new_type = get_type($new); | ||||
330 | 0 | 0 | errormsg(g_('cannot represent change to %s:'), $file); | ||||
331 | 0 | 0 | errormsg(g_(' new version is %s'), $new_type); | ||||
332 | 0 | 0 | errormsg(g_(' old version is %s'), $old_type); | ||||
333 | 0 | 0 | $self->register_error(); | ||||
334 | } | ||||||
335 | |||||||
336 | sub _getline { | ||||||
337 | 79 | 83 | my $handle = shift; | ||||
338 | |||||||
339 | 79 | 173 | my $line = <$handle>; | ||||
340 | 79 | 134 | if (defined $line) { | ||||
341 | # Strip end-of-line chars | ||||||
342 | 74 | 93 | chomp($line); | ||||
343 | 74 | 215 | $line =~ s/\r$//; | ||||
344 | } | ||||||
345 | 79 | 115 | return $line; | ||||
346 | } | ||||||
347 | |||||||
348 | # Fetch the header filename ignoring the optional timestamp | ||||||
349 | sub _fetch_filename { | ||||||
350 | 26 | 33 | my ($diff, $header) = @_; | ||||
351 | |||||||
352 | # Strip any leading spaces. | ||||||
353 | 26 | 48 | $header =~ s/^\s+//; | ||||
354 | |||||||
355 | # Is it a C-style string? | ||||||
356 | 26 | 56 | if ($header =~ m/^"/) { | ||||
357 | 6 | 21 | error(g_('diff %s patches file with C-style encoded filename'), $diff); | ||||
358 | } else { | ||||||
359 | # Tab is the official separator, it's always used when | ||||||
360 | # filename contain spaces. Try it first, otherwise strip on space | ||||||
361 | # if there's no tab | ||||||
362 | 20 | 64 | $header =~ s/\s.*// unless $header =~ s/\t.*//; | ||||
363 | } | ||||||
364 | |||||||
365 | 20 | 40 | return $header; | ||||
366 | } | ||||||
367 | |||||||
368 | sub _intuit_file_patched { | ||||||
369 | 7 | 13 | my ($old, $new) = @_; | ||||
370 | |||||||
371 | 7 | 8 | return $new unless defined $old; | ||||
372 | 2 | 4 | return $old unless defined $new; | ||||
373 | 2 | 6 | return $new if -e $new and not -e $old; | ||||
374 | 2 | 4 | return $old if -e $old and not -e $new; | ||||
375 | |||||||
376 | # We don't consider the case where both files are non-existent and | ||||||
377 | # where patch picks the one with the fewest directories to create | ||||||
378 | # since dpkg-source will pre-create the required directories | ||||||
379 | |||||||
380 | # Precalculate metrics used by patch | ||||||
381 | 2 | 2 | my ($tmp_o, $tmp_n) = ($old, $new); | ||||
382 | 2 | 2 | my ($len_o, $len_n) = (length($old), length($new)); | ||||
383 | 2 | 6 | $tmp_o =~ s{[/\\]+}{/}g; | ||||
384 | 2 | 4 | $tmp_n =~ s{[/\\]+}{/}g; | ||||
385 | 2 | 2 | my $nb_comp_o = ($tmp_o =~ tr{/}{/}); | ||||
386 | 2 | 2 | my $nb_comp_n = ($tmp_n =~ tr{/}{/}); | ||||
387 | 2 | 8 | $tmp_o =~ s{^.*/}{}; | ||||
388 | 2 | 2 | $tmp_n =~ s{^.*/}{}; | ||||
389 | 2 | 2 | my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n)); | ||||
390 | |||||||
391 | # Decide like patch would | ||||||
392 | 2 | 4 | if ($nb_comp_o != $nb_comp_n) { | ||||
393 | 0 | 0 | return ($nb_comp_o < $nb_comp_n) ? $old : $new; | ||||
394 | } elsif ($blen_o != $blen_n) { | ||||||
395 | 0 | 0 | return ($blen_o < $blen_n) ? $old : $new; | ||||
396 | } elsif ($len_o != $len_n) { | ||||||
397 | 0 | 0 | return ($len_o < $len_n) ? $old : $new; | ||||
398 | } | ||||||
399 | 2 | 2 | return $old; | ||||
400 | } | ||||||
401 | |||||||
402 | # check diff for sanity, find directories to create as a side effect | ||||||
403 | sub analyze { | ||||||
404 | 21 | 0 | 57 | my ($self, $destdir, %opts) = @_; | |||
405 | |||||||
406 | 21 | 44 | $opts{verbose} //= 1; | ||||
407 | 21 | 48 | my $diff = $self->get_filename(); | ||||
408 | 21 | 42 | my %filepatched; | ||||
409 | my %dirtocreate; | ||||||
410 | 21 | 0 | my @patchorder; | ||||
411 | 21 | 29 | my $patch_header = ''; | ||||
412 | 21 | 29 | my $diff_count = 0; | ||||
413 | |||||||
414 | 21 | 36 | my $line = _getline($self); | ||||
415 | |||||||
416 | HUNK: | ||||||
417 | 21 | 89 | while (defined $line or not eof $self) { | ||||
418 | 21 | 33 | my (%path, %fn); | ||||
419 | |||||||
420 | # Skip comments leading up to the patch (if any). Although we do not | ||||||
421 | # look for an Index: pseudo-header in the comments, because we would | ||||||
422 | # not use it anyway, as we require both ---/+++ filename headers. | ||||||
423 | 21 | 24 | while (1) { | ||||
424 | 49 | 128 | if ($line =~ /^(?:--- |\+\+\+ |@@ -)/) { | ||||
425 | 21 | 34 | last; | ||||
426 | } else { | ||||||
427 | 28 | 45 | $patch_header .= "$line\n"; | ||||
428 | } | ||||||
429 | 28 | 38 | $line = _getline($self); | ||||
430 | 28 | 46 | last HUNK if not defined $line; | ||||
431 | } | ||||||
432 | 21 | 26 | $diff_count++; | ||||
433 | # read file header (---/+++ pair) | ||||||
434 | 21 | 57 | unless ($line =~ s/^--- //) { | ||||
435 | 8 | 25 | error(g_("expected ^--- in line %d of diff '%s'"), $., $diff); | ||||
436 | } | ||||||
437 | 13 | 28 | $path{old} = $line = _fetch_filename($diff, $line); | ||||
438 | 13 | 51 | if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { | ||||
439 | 2 | 2 | $fn{old} = $line; | ||||
440 | } | ||||||
441 | 13 | 45 | if ($line =~ /\.dpkg-orig$/) { | ||||
442 | 0 | 0 | error(g_("diff '%s' patches file with name ending in .dpkg-orig"), | ||||
443 | $diff); | ||||||
444 | } | ||||||
445 | |||||||
446 | 13 | 23 | $line = _getline($self); | ||||
447 | 13 | 28 | unless (defined $line) { | ||||
448 | 0 | 0 | error(g_("diff '%s' finishes in middle of ---/+++ (line %d)"), | ||||
449 | $diff, $.); | ||||||
450 | } | ||||||
451 | 13 | 39 | unless ($line =~ s/^\+\+\+ //) { | ||||
452 | 0 | 0 | error(g_("line after --- isn't as expected in diff '%s' (line %d)"), | ||||
453 | $diff, $.); | ||||||
454 | } | ||||||
455 | 13 | 19 | $path{new} = $line = _fetch_filename($diff, $line); | ||||
456 | 7 | 66 | if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) { | ||||
457 | 7 | 13 | $fn{new} = $line; | ||||
458 | } | ||||||
459 | |||||||
460 | 7 | 31 | unless (defined $fn{old} or defined $fn{new}) { | ||||
461 | 0 | 0 | error(g_("none of the filenames in ---/+++ are valid in diff '%s' (line %d)"), | ||||
462 | $diff, $.); | ||||||
463 | } | ||||||
464 | |||||||
465 | # Safety checks on both filenames that patch could use | ||||||
466 | 7 | 15 | foreach my $key ('old', 'new') { | ||||
467 | 14 | 23 | next unless defined $fn{$key}; | ||||
468 | 9 | 13 | if ($path{$key} =~ m{/\.\./}) { | ||||
469 | 0 | 0 | error(g_('%s contains an insecure path: %s'), $diff, $path{$key}); | ||||
470 | } | ||||||
471 | 9 | 10 | my $path = $fn{$key}; | ||||
472 | 9 | 5 | while (1) { | ||||
473 | 13 | 76 | if (-l $path) { | ||||
474 | error(g_('diff %s modifies file %s through a symlink: %s'), | ||||||
475 | 0 | 0 | $diff, $fn{$key}, $path); | ||||
476 | } | ||||||
477 | 13 | 36 | last unless $path =~ s{/+[^/]*$}{}; | ||||
478 | 13 | 22 | last if length($path) <= length($destdir); # $destdir is assumed safe | ||||
479 | } | ||||||
480 | } | ||||||
481 | |||||||
482 | 7 | 29 | if ($path{old} eq '/dev/null' and $path{new} eq '/dev/null') { | ||||
483 | 0 | 0 | error(g_("original and modified files are /dev/null in diff '%s' (line %d)"), | ||||
484 | $diff, $.); | ||||||
485 | } elsif ($path{new} eq '/dev/null') { | ||||||
486 | error(g_("file removal without proper filename in diff '%s' (line %d)"), | ||||||
487 | 0 | 0 | $diff, $. - 1) unless defined $fn{old}; | ||||
488 | 0 | 0 | if ($opts{verbose}) { | ||||
489 | warning(g_('diff %s removes a non-existing file %s (line %d)'), | ||||||
490 | 0 | 0 | $diff, $fn{old}, $.) unless -e $fn{old}; | ||||
491 | } | ||||||
492 | } | ||||||
493 | 7 | 21 | my $fn = _intuit_file_patched($fn{old}, $fn{new}); | ||||
494 | |||||||
495 | 7 | 13 | my $dirname = $fn; | ||||
496 | 7 | 58 | if ($dirname =~ s{/[^/]+$}{} and not -d $dirname) { | ||||
497 | 2 | 2 | $dirtocreate{$dirname} = 1; | ||||
498 | } | ||||||
499 | |||||||
500 | 7 | 29 | if (-e $fn and not -f _) { | ||||
501 | 0 | 0 | error(g_("diff '%s' patches something which is not a plain file"), | ||||
502 | $diff); | ||||||
503 | } | ||||||
504 | |||||||
505 | 7 | 13 | if ($filepatched{$fn}) { | ||||
506 | 0 | 0 | $filepatched{$fn}++; | ||||
507 | |||||||
508 | 0 | 0 | if ($opts{fatal_dupes}) { | ||||
509 | 0 | 0 | error(g_("diff '%s' patches files multiple times; split the " . | ||||
510 | 'diff in multiple files or merge the hunks into a ' . | ||||||
511 | 'single one'), $diff); | ||||||
512 | } elsif ($opts{verbose} and $filepatched{$fn} == 2) { | ||||||
513 | 0 | 0 | warning(g_("diff '%s' patches file %s more than once"), $diff, $fn) | ||||
514 | } | ||||||
515 | } else { | ||||||
516 | 7 | 15 | $filepatched{$fn} = 1; | ||||
517 | 7 | 8 | push @patchorder, $fn; | ||||
518 | } | ||||||
519 | |||||||
520 | # read hunks | ||||||
521 | 7 | 7 | my $hunk = 0; | ||||
522 | 7 | 11 | while (defined($line = _getline($self))) { | ||||
523 | # read hunk header (@@) | ||||||
524 | 7 | 11 | next if $line =~ /^\\ /; | ||||
525 | 7 | 32 | last unless $line =~ /^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@(?: .*)?$/; | ||||
526 | 5 | 53 | my ($olines, $nlines) = ($1 ? $2 : 1, $3 ? $4 : 1); | ||||
527 | # read hunk | ||||||
528 | 5 | 26 | while ($olines || $nlines) { | ||||
529 | 5 | 6 | unless (defined($line = _getline($self))) { | ||||
530 | 0 | 0 | if (($olines == $nlines) and ($olines < 3)) { | ||||
531 | warning(g_("unexpected end of diff '%s'"), $diff) | ||||||
532 | 0 | 0 | if $opts{verbose}; | ||||
533 | 0 | 0 | last; | ||||
534 | } else { | ||||||
535 | 0 | 0 | error(g_("unexpected end of diff '%s'"), $diff); | ||||
536 | } | ||||||
537 | } | ||||||
538 | 5 | 8 | next if $line =~ /^\\ /; | ||||
539 | # Check stats | ||||||
540 | 5 | 33 | if ($line =~ /^ / or length $line == 0) { | ||||
541 | 0 | 0 | --$olines; | ||||
542 | 0 | 0 | --$nlines; | ||||
543 | } elsif ($line =~ /^-/) { | ||||||
544 | 0 | 0 | --$olines; | ||||
545 | } elsif ($line =~ /^\+/) { | ||||||
546 | 5 | 19 | --$nlines; | ||||
547 | } else { | ||||||
548 | 0 | 0 | error(g_("expected [ +-] at start of line %d of diff '%s'"), | ||||
549 | $., $diff); | ||||||
550 | } | ||||||
551 | } | ||||||
552 | 5 | 8 | $hunk++; | ||||
553 | } | ||||||
554 | 7 | 54 | unless ($hunk) { | ||||
555 | 2 | 4 | error(g_("expected ^\@\@ at line %d of diff '%s'"), $., $diff); | ||||
556 | } | ||||||
557 | } | ||||||
558 | 5 | 58 | close($self); | ||||
559 | 5 | 8 | unless ($diff_count) { | ||||
560 | warning(g_("diff '%s' doesn't contain any patch"), $diff) | ||||||
561 | 0 | 0 | if $opts{verbose}; | ||||
562 | } | ||||||
563 | 5 | 15 | *$self->{analysis}{$destdir}{dirtocreate} = \%dirtocreate; | ||||
564 | 5 | 8 | *$self->{analysis}{$destdir}{filepatched} = \%filepatched; | ||||
565 | 5 | 26 | *$self->{analysis}{$destdir}{patchorder} = \@patchorder; | ||||
566 | 5 | 8 | *$self->{analysis}{$destdir}{patchheader} = $patch_header; | ||||
567 | 5 | 14 | return *$self->{analysis}{$destdir}; | ||||
568 | } | ||||||
569 | |||||||
570 | sub prepare_apply { | ||||||
571 | 5 | 0 | 14 | my ($self, $analysis, %opts) = @_; | |||
572 | 5 | 8 | if ($opts{create_dirs}) { | ||||
573 | 5 5 | 5 13 | foreach my $dir (keys %{$analysis->{dirtocreate}}) { | ||||
574 | 0 0 | 0 0 | eval { make_path($dir, { mode => 0777 }) }; | ||||
575 | 0 | 0 | syserr(g_('cannot create directory %s'), $dir) if $@; | ||||
576 | } | ||||||
577 | } | ||||||
578 | } | ||||||
579 | |||||||
580 | sub apply { | ||||||
581 | 21 | 0 | 48 | my ($self, $destdir, %opts) = @_; | |||
582 | # Set default values to options | ||||||
583 | 21 | 92 | $opts{force_timestamp} //= 1; | ||||
584 | 21 | 79 | $opts{remove_backup} //= 1; | ||||
585 | 21 | 75 | $opts{create_dirs} //= 1; | ||||
586 | 21 | 109 | $opts{options} ||= [ '-t', '-F', '0', '-N', '-p1', '-u', | ||||
587 | '-V', 'never', '-b', '-z', '.dpkg-orig']; | ||||||
588 | 21 | 79 | $opts{add_options} //= []; | ||||
589 | 21 21 21 | 30 31 32 | push @{$opts{options}}, @{$opts{add_options}}; | ||||
590 | # Check the diff and create missing directories | ||||||
591 | 21 | 76 | my $analysis = $self->analyze($destdir, %opts); | ||||
592 | 5 | 18 | $self->prepare_apply($analysis, %opts); | ||||
593 | # Apply the patch | ||||||
594 | 5 | 11 | $self->ensure_open('r'); | ||||
595 | 5 | 6 | my ($stdout, $stderr) = ('', ''); | ||||
596 | spawn( | ||||||
597 | 5 5 | 8 35 | exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], | ||||
598 | chdir => $destdir, | ||||||
599 | env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, | ||||||
600 | delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour | ||||||
601 | wait_child => 1, | ||||||
602 | nocheck => 1, | ||||||
603 | from_handle => $self->get_filehandle(), | ||||||
604 | to_string => \$stdout, | ||||||
605 | error_to_string => \$stderr, | ||||||
606 | ); | ||||||
607 | 3 | 51 | if ($?) { | ||||
608 | 1 1 | 5 12 | print { *STDOUT } $stdout; | ||||
609 | 1 1 | 4 4 | print { *STDERR } $stderr; | ||||
610 | 1 1 | 4 10 | subprocerr("LC_ALL=C $Dpkg::PROGPATCH " . join(' ', @{$opts{options}}) . | ||||
611 | ' < ' . $self->get_filename()); | ||||||
612 | } | ||||||
613 | 2 | 54 | $self->close(); | ||||
614 | # Reset the timestamp of all the patched files | ||||||
615 | # and remove .dpkg-orig files | ||||||
616 | 2 2 | 2 8 | my @files = keys %{$analysis->{filepatched}}; | ||||
617 | 2 | 4 | my $now = $opts{timestamp}; | ||||
618 | 2 | 20 | $now //= fs_time($files[0]) if $opts{force_timestamp} && scalar @files; | ||||
619 | 2 | 4 | foreach my $fn (@files) { | ||||
620 | 2 | 2 | if ($opts{force_timestamp}) { | ||||
621 | 2 | 12 | utime($now, $now, $fn) or $! == ENOENT | ||||
622 | or syserr(g_('cannot change timestamp for %s'), $fn); | ||||||
623 | } | ||||||
624 | 2 | 2 | if ($opts{remove_backup}) { | ||||
625 | 2 | 2 | $fn .= '.dpkg-orig'; | ||||
626 | 2 | 34 | unlink($fn) or syserr(g_('remove patch backup file %s'), $fn); | ||||
627 | } | ||||||
628 | } | ||||||
629 | 2 | 26 | return $analysis; | ||||
630 | } | ||||||
631 | |||||||
632 | # Verify if check will work... | ||||||
633 | sub check_apply { | ||||||
634 | 0 | 0 | my ($self, $destdir, %opts) = @_; | ||||
635 | # Set default values to options | ||||||
636 | 0 | $opts{create_dirs} //= 1; | |||||
637 | 0 | $opts{options} ||= [ '--dry-run', '-s', '-t', '-F', '0', '-N', '-p1', '-u', | |||||
638 | '-V', 'never', '-b', '-z', '.dpkg-orig']; | ||||||
639 | 0 | $opts{add_options} //= []; | |||||
640 | 0 0 0 | push @{$opts{options}}, @{$opts{add_options}}; | |||||
641 | # Check the diff and create missing directories | ||||||
642 | 0 | my $analysis = $self->analyze($destdir, %opts); | |||||
643 | 0 | $self->prepare_apply($analysis, %opts); | |||||
644 | # Apply the patch | ||||||
645 | 0 | $self->ensure_open('r'); | |||||
646 | my $patch_pid = spawn( | ||||||
647 | 0 0 | exec => [ $Dpkg::PROGPATCH, @{$opts{options}} ], | |||||
648 | chdir => $destdir, | ||||||
649 | env => { LC_ALL => 'C', LANG => 'C', PATCH_GET => '0' }, | ||||||
650 | delete_env => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour | ||||||
651 | from_handle => $self->get_filehandle(), | ||||||
652 | to_file => '/dev/null', | ||||||
653 | error_to_file => '/dev/null', | ||||||
654 | ); | ||||||
655 | 0 | wait_child($patch_pid, nocheck => 1); | |||||
656 | 0 | my $exit = WEXITSTATUS($?); | |||||
657 | 0 | subprocerr("$Dpkg::PROGPATCH --dry-run") unless WIFEXITED($?); | |||||
658 | 0 | $self->close(); | |||||
659 | 0 | return ($exit == 0); | |||||
660 | } | ||||||
661 | |||||||
662 | # Helper functions | ||||||
663 | sub get_type { | ||||||
664 | 0 | 0 | my $file = shift; | ||||
665 | 0 | if (not lstat($file)) { | |||||
666 | 0 | return g_('nonexistent') if $! == ENOENT; | |||||
667 | 0 | syserr(g_('cannot stat %s'), $file); | |||||
668 | } else { | ||||||
669 | 0 | -f _ && return g_('plain file'); | |||||
670 | 0 | -d _ && return g_('directory'); | |||||
671 | 0 | -l _ && return sprintf(g_('symlink to %s'), readlink($file)); | |||||
672 | 0 | -b _ && return g_('block device'); | |||||
673 | 0 | -c _ && return g_('character device'); | |||||
674 | 0 | -p _ && return g_('named pipe'); | |||||
675 | 0 | -S _ && return g_('named socket'); | |||||
676 | } | ||||||
677 | } | ||||||
678 | |||||||
679 | 1; |