1 # Copyright © 2008 Raphaël Hertzog <hertzog@debian.org>
2 # Copyright © 2008-2010, 2012-2015 Guillem Jover <guillem@debian.org>
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.
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.
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/>.
17 package Dpkg
::Source
::Patch
;
22 our $VERSION = '0.01';
24 use POSIX
qw(:errno_h
:sys_wait_h
);
28 use File
::Path
qw(make_path
);
31 use Time
::HiRes
qw(stat);
35 use Dpkg
::ErrorHandling
;
37 use Dpkg
::Source
::Functions
qw(fs_time
);
39 use parent
qw(Dpkg
::Compression
::FileHandle
);
42 my ($self, %opts) = @_;
43 $self->ensure_open('w'); # Creates the file
46 if ($opts{old
} and $opts{new
} and $opts{filename
}) {
47 $opts{old
} = '/dev/null' unless -e
$opts{old
};
48 $opts{new
} = '/dev/null' unless -e
$opts{new
};
49 if (-d
$opts{old
} and -d
$opts{new
}) {
50 $self->add_diff_directory($opts{old
}, $opts{new
}, %opts);
51 } elsif (-f
$opts{old
} and -f
$opts{new
}) {
52 $self->add_diff_file($opts{old
}, $opts{new
}, %opts);
54 $self->_fail_not_same_type($opts{old
}, $opts{new
}, $opts{filename
});
56 $self->finish() unless $opts{nofinish
};
61 my ($self, $header) = @_;
62 *$self->{header
} = $header;
66 my ($self, $old, $new, %opts) = @_;
67 $opts{include_timestamp
} //= 0;
68 my $handle_binary = $opts{handle_binary_func
} // sub {
69 my ($self, $old, $new, %opts) = @_;
70 my $file = $opts{filename
};
71 $self->_fail_with_msg($file, g_
('binary file contents changed'));
73 # Optimization to avoid forking diff if unnecessary
74 return 1 if compare
($old, $new, 4096) == 0;
75 # Default diff options
78 push @options, @
{$opts{options
}};
83 if ($opts{label_old
} and $opts{label_new
}) {
84 if ($opts{include_timestamp
}) {
85 my $ts = (stat($old))[9];
86 my $t = POSIX
::strftime
('%Y-%m-%d %H:%M:%S', gmtime($ts));
87 $opts{label_old
} .= sprintf("\t%s.%09d +0000", $t,
88 ($ts - int($ts)) * 1_000_000_000
);
89 $ts = (stat($new))[9];
90 $t = POSIX
::strftime
('%Y-%m-%d %H:%M:%S', gmtime($ts));
91 $opts{label_new
} .= sprintf("\t%s.%09d +0000", $t,
92 ($ts - int($ts)) * 1_000_000_000
);
94 # Space in filenames need special treatment
95 $opts{label_old
} .= "\t" if $opts{label_old
} =~ / /;
96 $opts{label_new
} .= "\t" if $opts{label_new
} =~ / /;
98 push @options, '-L', $opts{label_old
},
99 '-L', $opts{label_new
};
103 my $diff_pid = spawn
(
104 exec => [ 'diff', '-u', @options, '--', $old, $new ],
105 env
=> { LC_ALL
=> 'C', LANG
=> 'C', TZ
=> 'UTC0' },
106 to_pipe
=> \
$diffgen,
108 # Check diff and write it in patch file
109 my $difflinefound = 0;
114 if (m/^(?:binary|[^-+\@ ].*\bdiffer\b)/i) {
116 &$handle_binary($self, $old, $new, %opts);
118 } elsif (m/^[-+\@ ]/) {
121 warning
(g_
('file %s has no final newline (either ' .
122 'original or modified version)'), $new);
125 error
(g_
("unknown line from diff -u on %s: '%s'"), $new, $_);
127 if (*$self->{empty
} and defined(*$self->{header
})) {
128 $self->print(*$self->{header
}) or syserr
(g_
('failed to write'));
131 print { $self } $_ or syserr
(g_
('failed to write'));
133 close($diffgen) or syserr
('close on diff pipe');
134 wait_child
($diff_pid, nocheck
=> 1,
135 cmdline
=> "diff -u @options -- $old $new");
136 # Verify diff process ended successfully
137 # Exit code of diff: 0 => no difference, 1 => diff ok, 2 => error
138 # Ignore error if binary content detected
139 my $exit = WEXITSTATUS
($?
);
140 unless (WIFEXITED
($?
) && ($exit == 0 || $exit == 1 || $binary)) {
141 subprocerr
(g_
('diff on %s'), $new);
143 return ($exit == 0 || $exit == 1);
146 sub add_diff_directory
{
147 my ($self, $old, $new, %opts) = @_;
148 # TODO: make this function more configurable
149 # - offer to disable some checks
150 my $basedir = $opts{basedirname
} || basename
($new);
151 my $inc_removal = $opts{include_removal
} // 0;
153 if ($opts{diff_ignore_func
}) {
154 $diff_ignore = $opts{diff_ignore_func
};
155 } elsif ($opts{diff_ignore_regex
}) {
156 $diff_ignore = sub { return $_[0] =~ /$opts{diff_ignore_regex}/o };
158 $diff_ignore = sub { return 0 };
164 my $fn = (length > length($new)) ?
substr($_, length($new) + 1) : '.';
165 return if &$diff_ignore($fn);
166 $files_in_new{$fn} = 1;
167 lstat("$new/$fn") or syserr(g_('cannot stat file %s'), "$new/$fn");
168 my $mode = S_IMODE
((lstat(_
))[2]);
169 my $size = (lstat(_
))[7];
171 unless (-l
"$old/$fn") {
172 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
175 my $n = readlink("$new/$fn");
176 unless (defined $n) {
177 syserr
(g_
('cannot read link %s'), "$new/$fn");
179 my $n2 = readlink("$old/$fn");
180 unless (defined $n2) {
181 syserr
(g_
('cannot read link %s'), "$old/$fn");
184 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
187 my $old_file = "$old/$fn";
188 if (not lstat("$old/$fn")) {
190 syserr
(g_
('cannot stat file %s'), "$old/$fn");
192 $old_file = '/dev/null';
194 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
198 my $label_old = "$basedir.orig/$fn";
199 if ($opts{use_dev_null
}) {
200 $label_old = $old_file if $old_file eq '/dev/null';
202 push @diff_files, [$fn, $mode, $size, $old_file, "$new/$fn",
203 $label_old, "$basedir/$fn"];
205 unless (-p
"$old/$fn") {
206 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
208 } elsif (-b _
|| -c _
|| -S _
) {
209 $self->_fail_with_msg("$new/$fn",
210 g_
('device or socket is not allowed'));
212 if (not lstat("$old/$fn")) {
214 syserr
(g_
('cannot stat file %s'), "$old/$fn");
217 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
220 $self->_fail_with_msg("$new/$fn", g_
('unknown file type'));
224 my $fn = (length > length($old)) ?
substr($_, length($old) + 1) : '.';
225 return if &$diff_ignore($fn);
226 return if $files_in_new{$fn};
227 lstat("$old/$fn") or syserr(g_('cannot stat file %s'), "$old/$fn");
230 push @diff_files, [$fn, 0, 0, "$old/$fn", '/dev/null',
231 "$basedir.orig
/$fn", '/dev
/null
'];
233 warning(g_('ignoring deletion of file
%s, use --include
-removal to override
'), $fn);
236 warning(g_('ignoring deletion of directory
%s'), $fn);
238 warning(g_('ignoring deletion of
symlink %s'), $fn);
240 $self->_fail_not_same_type("$old/$fn", "$new/$fn", $fn);
244 find({ wanted => $scan_new, no_chdir => 1 }, $new);
245 find({ wanted => $scan_old, no_chdir => 1 }, $old);
247 if ($opts{order_from} and -e $opts{order_from}) {
248 my $order_from = Dpkg::Source::Patch->new(
249 filename => $opts{order_from});
250 my $analysis = $order_from->analyze($basedir, verbose => 0);
253 foreach my $fn (@{$analysis->{patchorder}}) {
255 $patchorder{$fn} = $i++;
257 # 'quilt refresh
' sorts files as follows:
258 # - Any files in the existing patch come first, in the order in
259 # which they appear in the existing patch.
260 # - New files follow, sorted lexicographically.
261 # This seems a reasonable policy to follow, and avoids autopatches
262 # being shuffled when they are regenerated.
263 foreach my $diff_file (sort { $a->[0] cmp $b->[0] } @diff_files) {
264 my $fn = $diff_file->[0];
265 $patchorder{$fn} //= $i++;
267 @diff_files = sort { $patchorder{$a->[0]} <=> $patchorder{$b->[0]} }
270 @diff_files = sort { $a->[0] cmp $b->[0] } @diff_files;
273 foreach my $diff_file (@diff_files) {
274 my ($fn, $mode, $size,
275 $old_file, $new_file, $label_old, $label_new) = @$diff_file;
276 my $success = $self->add_diff_file($old_file, $new_file,
278 label_old => $label_old,
279 label_new => $label_new, %opts);
281 $old_file eq '/dev/null
' and $new_file ne '/dev/null
') {
283 warning(g_("newly created empty file '%s' will not " .
284 'be represented in diff
'), $fn);
286 if ($mode & (S_IXUSR | S_IXGRP | S_IXOTH)) {
287 warning(g_("executable mode %04o of '%s' will " .
288 'not be represented in diff
'), $mode, $fn)
289 unless $fn eq 'debian
/rules
';
291 if ($mode & (S_ISUID | S_ISGID | S_ISVTX)) {
292 warning(g_("special mode %04o of '%s' will not " .
293 'be represented in diff
'), $mode, $fn);
302 close($self) or syserr(g_('cannot
close %s'), $self->get_filename());
303 return not *$self->{errors};
311 my ($self, $file, $msg) = @_;
312 errormsg(g_('cannot represent change to
%s: %s'), $file, $msg);
313 $self->register_error();
315 sub _fail_not_same_type {
316 my ($self, $old, $new, $file) = @_;
317 my $old_type = get_type($old);
318 my $new_type = get_type($new);
319 errormsg(g_('cannot represent change to
%s:'), $file);
320 errormsg(g_(' new version is
%s'), $new_type);
321 errormsg(g_(' old version is
%s'), $old_type);
322 $self->register_error();
328 my $line = <$handle>;
330 # Strip end-of-line chars
337 # Fetch the header filename ignoring the optional timestamp
338 sub _fetch_filename {
339 my ($diff, $header) = @_;
341 # Strip any leading spaces.
344 # Is it a C-style string?
345 if ($header =~ m/^"/) {
346 error(g_('diff
%s patches file with C
-style encoded filename
'), $diff);
348 # Tab is the official separator, it's always used
when
349 # filename contain spaces. Try it first, otherwise strip on space
351 $header =~ s/\s.*// unless $header =~ s/\t.*//;
357 sub _intuit_file_patched
{
358 my ($old, $new) = @_;
360 return $new unless defined $old;
361 return $old unless defined $new;
362 return $new if -e
$new and not -e
$old;
363 return $old if -e
$old and not -e
$new;
365 # We don't consider the case where both files are non-existent and
366 # where patch picks the one with the fewest directories to create
367 # since dpkg-source will pre-create the required directories
369 # Precalculate metrics used by patch
370 my ($tmp_o, $tmp_n) = ($old, $new);
371 my ($len_o, $len_n) = (length($old), length($new));
372 $tmp_o =~ s{[/\\]+}{/}g;
373 $tmp_n =~ s{[/\\]+}{/}g;
374 my $nb_comp_o = ($tmp_o =~ tr{/}{/});
375 my $nb_comp_n = ($tmp_n =~ tr{/}{/});
378 my ($blen_o, $blen_n) = (length($tmp_o), length($tmp_n));
380 # Decide like patch would
381 if ($nb_comp_o != $nb_comp_n) {
382 return ($nb_comp_o < $nb_comp_n) ?
$old : $new;
383 } elsif ($blen_o != $blen_n) {
384 return ($blen_o < $blen_n) ?
$old : $new;
385 } elsif ($len_o != $len_n) {
386 return ($len_o < $len_n) ?
$old : $new;
391 # check diff for sanity, find directories to create as a side effect
393 my ($self, $destdir, %opts) = @_;
395 $opts{verbose
} //= 1;
396 my $diff = $self->get_filename();
400 my $patch_header = '';
403 my $line = _getline
($self);
406 while (defined $line or not eof $self) {
409 # Skip comments leading up to the patch (if any). Although we do not
410 # look for an Index: pseudo-header in the comments, because we would
411 # not use it anyway, as we require both ---/+++ filename headers.
413 if ($line =~ /^(?:--- |\+\+\+ |@@ -)/) {
416 $patch_header .= "$line\n";
418 $line = _getline
($self);
419 last HUNK
if not defined $line;
422 # read file header (---/+++ pair)
423 unless ($line =~ s/^--- //) {
424 error
(g_
("expected ^--- in line %d of diff '%s'"), $., $diff);
426 $path{old
} = $line = _fetch_filename
($diff, $line);
427 if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) {
430 if ($line =~ /\.dpkg-orig$/) {
431 error
(g_
("diff '%s' patches file with name ending in .dpkg-orig"),
435 $line = _getline
($self);
436 unless (defined $line) {
437 error
(g_
("diff '%s' finishes in middle of ---/+++ (line %d)"),
440 unless ($line =~ s/^\+\+\+ //) {
441 error
(g_
("line after --- isn't as expected in diff '%s' (line %d)"),
444 $path{new
} = $line = _fetch_filename
($diff, $line);
445 if ($line ne '/dev/null' and $line =~ s{^[^/]*/+}{$destdir/}) {
449 unless (defined $fn{old
} or defined $fn{new
}) {
450 error
(g_
("none of the filenames in ---/+++ are valid in diff '%s' (line %d)"),
454 # Safety checks on both filenames that patch could use
455 foreach my $key ('old', 'new') {
456 next unless defined $fn{$key};
457 if ($path{$key} =~ m{/\.\./}) {
458 error
(g_
('%s contains an insecure path: %s'), $diff, $path{$key});
460 my $path = $fn{$key};
463 error
(g_
('diff %s modifies file %s through a symlink: %s'),
464 $diff, $fn{$key}, $path);
466 last unless $path =~ s{/+[^/]*$}{};
467 last if length($path) <= length($destdir); # $destdir is assumed safe
471 if ($path{old
} eq '/dev/null' and $path{new
} eq '/dev/null') {
472 error
(g_
("original and modified files are /dev/null in diff '%s' (line %d)"),
474 } elsif ($path{new
} eq '/dev/null') {
475 error
(g_
("file removal without proper filename in diff '%s' (line %d)"),
476 $diff, $. - 1) unless defined $fn{old
};
477 if ($opts{verbose
}) {
478 warning
(g_
('diff %s removes a non-existing file %s (line %d)'),
479 $diff, $fn{old
}, $.) unless -e
$fn{old
};
482 my $fn = _intuit_file_patched
($fn{old
}, $fn{new
});
485 if ($dirname =~ s{/[^/]+$}{} and not -d
$dirname) {
486 $dirtocreate{$dirname} = 1;
489 if (-e
$fn and not -f _
) {
490 error
(g_
("diff '%s' patches something which is not a plain file"),
494 if ($filepatched{$fn}) {
497 if ($opts{fatal_dupes
}) {
498 error
(g_
("diff '%s' patches files multiple times; split the " .
499 'diff in multiple files or merge the hunks into a ' .
500 'single one'), $diff);
501 } elsif ($opts{verbose
} and $filepatched{$fn} == 2) {
502 warning
(g_
("diff '%s' patches file %s more than once"), $diff, $fn)
505 $filepatched{$fn} = 1;
506 push @patchorder, $fn;
511 while (defined($line = _getline
($self))) {
512 # read hunk header (@@)
513 next if $line =~ /^\\ /;
514 last unless $line =~ /^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@(?: .*)?$/;
515 my ($olines, $nlines) = ($1 ?
$2 : 1, $3 ?
$4 : 1);
517 while ($olines || $nlines) {
518 unless (defined($line = _getline
($self))) {
519 if (($olines == $nlines) and ($olines < 3)) {
520 warning
(g_
("unexpected end of diff '%s'"), $diff)
524 error
(g_
("unexpected end of diff '%s'"), $diff);
527 next if $line =~ /^\\ /;
529 if ($line =~ /^ / or length $line == 0) {
532 } elsif ($line =~ /^-/) {
534 } elsif ($line =~ /^\+/) {
537 error
(g_
("expected [ +-] at start of line %d of diff '%s'"),
544 error
(g_
("expected ^\@\@ at line %d of diff '%s'"), $., $diff);
548 unless ($diff_count) {
549 warning
(g_
("diff '%s' doesn't contain any patch"), $diff)
552 *$self->{analysis
}{$destdir}{dirtocreate
} = \
%dirtocreate;
553 *$self->{analysis
}{$destdir}{filepatched
} = \
%filepatched;
554 *$self->{analysis
}{$destdir}{patchorder
} = \
@patchorder;
555 *$self->{analysis
}{$destdir}{patchheader
} = $patch_header;
556 return *$self->{analysis
}{$destdir};
560 my ($self, $analysis, %opts) = @_;
561 if ($opts{create_dirs
}) {
562 foreach my $dir (keys %{$analysis->{dirtocreate
}}) {
563 eval { make_path
($dir, { mode
=> 0777 }) };
564 syserr
(g_
('cannot create directory %s'), $dir) if $@
;
570 my ($self, $destdir, %opts) = @_;
571 # Set default values to options
572 $opts{force_timestamp
} //= 1;
573 $opts{remove_backup
} //= 1;
574 $opts{create_dirs
} //= 1;
575 $opts{options
} ||= [ '-t', '-F', '0', '-N', '-p1', '-u',
576 '-V', 'never', '-b', '-z', '.dpkg-orig'];
577 $opts{add_options
} //= [];
578 push @
{$opts{options
}}, @
{$opts{add_options
}};
579 # Check the diff and create missing directories
580 my $analysis = $self->analyze($destdir, %opts);
581 $self->prepare_apply($analysis, %opts);
583 $self->ensure_open('r');
584 my ($stdout, $stderr) = ('', '');
586 exec => [ $Dpkg::PROGPATCH
, @
{$opts{options
}} ],
588 env
=> { LC_ALL
=> 'C', LANG
=> 'C', PATCH_GET
=> '0' },
589 delete_env
=> [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour
592 from_handle
=> $self->get_filehandle(),
593 to_string
=> \
$stdout,
594 error_to_string
=> \
$stderr,
597 print { *STDOUT
} $stdout;
598 print { *STDERR
} $stderr;
599 subprocerr
("LC_ALL=C $Dpkg::PROGPATCH " . join(' ', @
{$opts{options
}}) .
600 ' < ' . $self->get_filename());
603 # Reset the timestamp of all the patched files
604 # and remove .dpkg-orig files
605 my @files = keys %{$analysis->{filepatched
}};
606 my $now = $opts{timestamp
};
607 $now //= fs_time
($files[0]) if $opts{force_timestamp
} && scalar @files;
608 foreach my $fn (@files) {
609 if ($opts{force_timestamp
}) {
610 utime($now, $now, $fn) or $! == ENOENT
611 or syserr
(g_
('cannot change timestamp for %s'), $fn);
613 if ($opts{remove_backup
}) {
615 unlink($fn) or syserr
(g_
('remove patch backup file %s'), $fn);
621 # Verify if check will work...
623 my ($self, $destdir, %opts) = @_;
624 # Set default values to options
625 $opts{create_dirs
} //= 1;
626 $opts{options
} ||= [ '--dry-run', '-s', '-t', '-F', '0', '-N', '-p1', '-u',
627 '-V', 'never', '-b', '-z', '.dpkg-orig'];
628 $opts{add_options
} //= [];
629 push @
{$opts{options
}}, @
{$opts{add_options
}};
630 # Check the diff and create missing directories
631 my $analysis = $self->analyze($destdir, %opts);
632 $self->prepare_apply($analysis, %opts);
634 $self->ensure_open('r');
635 my $patch_pid = spawn
(
636 exec => [ $Dpkg::PROGPATCH
, @
{$opts{options
}} ],
638 env
=> { LC_ALL
=> 'C', LANG
=> 'C', PATCH_GET
=> '0' },
639 delete_env
=> [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour
640 from_handle
=> $self->get_filehandle(),
641 to_file
=> '/dev/null',
642 error_to_file
=> '/dev/null',
644 wait_child
($patch_pid, nocheck
=> 1);
645 my $exit = WEXITSTATUS
($?
);
646 subprocerr
("$Dpkg::PROGPATCH --dry-run") unless WIFEXITED
($?
);
654 if (not lstat($file)) {
655 return g_
('nonexistent') if $! == ENOENT
;
656 syserr
(g_
('cannot stat %s'), $file);
658 -f _
&& return g_
('plain file');
659 -d _
&& return g_
('directory');
660 -l _
&& return sprintf(g_
('symlink to %s'), readlink($file));
661 -b _
&& return g_
('block device');
662 -c _
&& return g_
('character device');
663 -p _
&& return g_
('named pipe');
664 -S _
&& return g_
('named socket');