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