Alien-wxWidgets
view release on metacpan or search on metacpan
inc/bin/patch view on Meta::CPAN
# ED SCRIPT
my $space = qr/^$1/;
$patch->bless('ed') or next PATCH;
print PATCH;
my @cmd;
ED:
while (<PATCH>) {
unless (s/$space// && m!^\d+(?:,\d+)?([acd]|s\Q/^\.\././\E)$!) {
print PATCH;
last ED;
}
push @cmd, [$_];
$1 =~ /^[ac]$/ or next;
while (<PATCH>) {
unless (s/$space//) {
print PATCH;
last ED;
}
push @{$cmd[-1]}, $_;
last if /^\.$/;
}
}
$patch->apply(@cmd) or $patch->reject(map @$_, @cmd);
} else {
# GARBAGE
$patch->garbage($_);
}
}
close PATCH;
if (ref $patch eq 'Patch') {
$patch->note("Hmm... I can't seem to find a patch in there anywhere.\n");
} else {
$patch->end;
}
$patch->note("done\n");
exit $patch->error ? 1 : 0;
END {
close STDOUT || die "$0: can't close stdout: $!\n";
$? = 1 if $? == 255; # from die
}
package Patch;
use vars qw/$ERROR/;
# Class data.
BEGIN {
$ERROR = 0;
}
sub import {
no strict 'refs';
*{caller() . '::throw'} = \&throw;
@{caller() . '::ISA'} = 'Patch';
}
# Simple throw/catch error handling.
sub throw {
$@ = join '', @_;
$@ .= sprintf " at %s line %d\n", (caller)[1..2] unless $@ =~ /\n\z/;
goto CATCH;
}
# Prints a prompt message and returns response.
sub prompt {
print @_;
local $_ = <STDIN>;
chomp;
$_;
}
# Constructs a Patch object.
sub new {
my $class = shift;
my %copy = %{$_[0]} if ref $_[0];
bless {
%copy,
options => [@_],
garbage => [],
rejects => [],
}, $class;
}
# Blesses object into a subclass.
sub bless {
my $type = pop;
my $class = "Patch::\u$type";
my ($options, $garbage) = @{$_[0]}{'options', 'garbage'};
# New hunk, same patch.
$_[0]{hunk}++, return 1 if $_[0]->isa($class) && ! @$garbage;
# Clean up previous Patch object first.
$_[0]->end;
# Get options/switches for new patch.
my $self = @$options > 1 ? shift @$options :
@$options == 1 ? { %{$options->[0]} } :
{};
bless $self, $class;
# 'options' and 'garbage' are probably better off as class
# data. Why didn't I do that before? But it's not broken
# so I'm not fixing it.
$self->{options} = $options; # @options
$self->{garbage} = []; # garbage lines
$self->{i_pos} = 0; # current position in 'in' file
$self->{o_pos} = 0; # just for symmetry
$self->{i_lines} = 0; # lines read in 'in' file
$self->{o_lines} = 0; # lines written to 'out' file
$self->{hunk} = 1; # current hunk number
$self->{rejects} = []; # save rejected hunks here
$self->{fuzz} = 2 unless defined $self->{fuzz} && $self->{fuzz} >= 0;
$self->{ifdef} = '' unless defined $self->{ifdef};
# Skip patch?
$self->{skip} and $self->skip;
inc/bin/patch view on Meta::CPAN
$path;
}
# Create a backup file from options.
sub backup {
my ($self, $file) = @_;
$file =
$self->{prefix} ? "$self->{prefix}$file" :
$self->{'version-control'} ? $self->version_control_backup(
$file, $self->{'version-control'}) :
$self->{suffix} ? "$file$self->{suffix}" :
$ENV{VERSION_CONTROL} ? $self->version_control_backup(
$file, $ENV{VERSION_CONTROL}) :
$ENV{SIMPLE_BACKUP_SUFFIX} ? "$file$ENV{SIMPLE_BACKUP_SUFFIX}" :
"$file.orig"; # long filename
my ($name, $extension) = $file =~ /^(.+)(?:\.([^.]+))?$/;
my $ext = $extension;
while (-e $file) {
if ($ext !~ s/[a-z]/\U$1/) {
$ext = $extension;
$name =~ s/.// or die "Couldn't create a good backup filename.\n";
}
$file = $name . $ext;
}
$file;
}
# Create a backup file using version control.
sub version_control_backup {
my ($self, $file, $version) = @_;
if ($version =~ /^(?:ne|s)/) { # never|simple
$file .= $self->suffix_backup;
} else {
opendir DIR, '.' or die "Can't open dir '.': $!";
my $re = qr/^\Q$file\E\.~(\d+)~$/;
my @files = map /$re/, readdir DIR;
close DIR;
if (@files) { # version number already exists
my $next = 1 + (sort {$a <=> $b} @files)[-1];
$file .= ".~$next~";
} else { # t|numbered # nil|existing
$file .= $version =~ /^(?:t|nu)/ ? '.~1~' : $self->suffix_backup;
}
}
$file;
}
# Create a backup file using suffix.
sub suffix_backup {
my $self = shift;
return $self->{suffix} if $self->{suffix};
return $ENV{SIMPLE_BACKUP_SUFFIX} if $ENV{SIMPLE_BACKUP_SUFFIX};
return '.orig';
}
# Apply a patch hunk. The default assumes a unified diff.
sub apply {
my ($self, $i_start, $o_start, @hunk) = @_;
$self->{skip} and throw 'SKIP...ignore this patch';
if ($self->{reverse}) {
my $not = { qw/ + - - + / };
s/^([+-])/$not->{$1}/ for @hunk;
}
my @context = map /^[ -](.*)/s, @hunk;
my $position;
my $fuzz = 0;
if (@context) {
# Find a place to apply hunk where context matches.
for (0..$self->{fuzz}) {
my ($pos, $lines) = ($self->{i_pos}, 0);
while (1) {
($pos, $lines) = $self->index(\@context, $pos, $lines) or last;
my $line = $self->{i_lines} + $lines + 1;
if ($line >= $i_start) {
my $off = $line - $i_start;
$position = [$lines, $off]
unless $position && $position->[-1] < $off;
last;
}
$position = [$lines, $i_start - $line];
$pos++, $lines = 1;
}
last if $position;
last unless $hunk[0] =~ /^ / && shift @hunk
or $hunk[-1] =~ /^ / && pop @hunk;
@context = map /^[ -](.*)/s, @hunk or last;
$fuzz++;
}
# If there's nowhere to apply the first hunk, we check if it is
# a reversed patch.
if ($self->{hunk} == 1) {
if ($self->{reverse_check}) {
$self->{reverse_check} = 0;
if ($position) {
unless ($self->{batch}) {
local $_ = prompt (
'Reversed (or previously applied) patch detected!',
' Assume -R? [y] '
);
if (/^[nN]/) {
$self->{reverse} = 0;
$position = 0;
prompt ('Apply anyway? [n] ') =~ /^[yY]/
or throw 'SKIP...ignore this patch';
}
}
} else {
throw 'SKIP...ignore this patch' if $self->{forward};
}
} else {
unless ($position || $self->{reverse} || $self->{force}) {
$self->{reverse_check} = 1;
$self->{reverse} = 1;
shift;
return $self->apply(@_);
}
}
}
$position or throw "Couldn't find anywhere to put hunk.\n";
} else {
# No context. Use given position.
$position = [$i_start - $self->{i_lines} - 1]
}
my $in = $self->{i_fh};
my $out = $self->{o_fh};
my $def = $self->{d_fh};
my $ifdef = $self->{ifdef};
# Make sure we're where we left off.
seek $in, $self->{i_pos}, 0 or throw "Couldn't seek INFILE: $!";
my $line = $self->{o_lines} + $position->[0] + 1;
my $off = $line - $o_start;
# Set to new position.
$self->{i_lines} += $position->[0];
$self->{o_lines} += $position->[0];
print $out scalar <$in> while $position->[0]--;
# Apply hunk.
my $was = ' ';
for (@hunk) {
/^([ +-])(.*)/s;
my $cmd = substr $_, 0, 1, '';
if ($cmd eq '-') {
$cmd eq $was or print $def "#ifndef $ifdef\n";
print $def scalar <$in>;
$self->{i_lines}++;
} elsif ($cmd eq '+') {
$cmd eq $was or print $def $was eq ' ' ?
"#ifdef $ifdef\n" :
"#else\n";
print $out $_;
$self->{o_lines}++;
} else {
$cmd eq $was or print $def "#endif /* $ifdef */\n";
print $out scalar <$in>;
$self->{i_lines}++;
$self->{o_lines}++;
}
$was = $cmd;
}
$was eq ' ' or print $def "#endif /* $ifdef */\n";
# Keep track of where we leave off.
$self->{i_pos} = tell $in;
# Report success to user.
$self->note("Hunk #$self->{hunk} succeeded at $line.\n");
$self->note(" Offset: $off\n") if $off;
$self->note(" Fuzz: $fuzz\n") if $fuzz;
return 1;
# Or report failure.
CATCH:
$self->{skip}++ if $@ =~ /^SKIP/;
$self->note( $self->{skip}
? "Hunk #$self->{hunk} ignored at $o_start.\n"
: "Hunk #$self->{hunk} failed--$@"
);
return;
}
# Find where an array of lines matches in a file after a given position.
# $match => [array of lines]
# $pos => search after this position and...
# $lines => ...after this many lines after $pos
# Returns the position of the match and the number of lines between the
# starting and matching positions.
sub index {
my ($self, $match, $pos, $lines) = @_;
my $in = $self->{i_fh};
seek $in, $pos, 0 or throw "Couldn't seek INFILE [$in, 0, $pos]: $!";
<$in> while $lines--;
if ($self->{'ignore-whitespace'}) {
s/\s+/ /g for @$match;
}
my $tell = tell $in;
my $line = 0;
while (<$in>) {
s/\s+/ /g if $self->{'ignore-whitespace'};
if ($_ eq $match->[0]) {
my $fail;
for (1..$#$match) {
my $line = <$in>;
$line =~ s/\s+/ /g if $self->{'ignore-whitespace'};
$line eq $match->[$_] or $fail++, last;
}
if ($fail) {
seek $in, $tell, 0 or throw "Couldn't seek INFILE: $!";
<$in>;
} else {
return ($tell, $line);
}
}
$line++;
$tell = tell $in;
}
return;
CATCH: $self->note($@), return;
}
package Patch::Context;
BEGIN { Patch->import }
# Convert hunk to unified diff, then apply.
sub apply {
my ($self, $i_start, $o_start, $i_hunk, $o_hunk) = @_;
my @hunk;
my @i_hunk = @$i_hunk;
my @o_hunk = @$o_hunk;
s/^(.) /$1/ for @i_hunk, @o_hunk;
while (@i_hunk and @o_hunk) {
my ($i, $o) = (shift @i_hunk, shift @o_hunk);
if ($i eq $o) {
push @hunk, $i;
next;
}
while ($i =~ s/^[!-]/-/) {
push @hunk, $i;
$i = shift @i_hunk;
}
while ($o =~ s/^[!+]/+/) {
push @hunk, $o;
$o = shift @o_hunk;
}
push @hunk, $i;
}
push @hunk, @i_hunk, @o_hunk;
$self->SUPER::apply($i_start, $o_start, @hunk);
}
# Check for filename in diff header, then in 'Index:' line.
sub rummage {
my ($self, $garbage) = @_;
my @files = grep -e, map $self->strip,
map /^\s*(?:\*\*\*|---) (\S+)/, @$garbage[-1, -2];
my $file =
@files == 1 ? $files[0] :
@files == 2 ? $files[length $files[0] > length $files[1]] :
$self->SUPER::rummage($garbage);
return $file;
}
package Patch::Ed;
BEGIN { Patch->import }
# Pipe ed script to ed or try to manually process.
sub apply {
my ($self, @cmd) = @_;
$self->{skip} and throw 'SKIP...ignore this patch';
my $out = $self->{o_fh};
$self->{check} and goto PLAN_J;
# We start out by adding a magic line to our output. If this line
# is still there after piping to ed, then ed failed. We do this
# because win32 will silently fail if there is no ed program.
my $magic = "#!/i/want/a/moogle/stuffy\n";
print $out $magic;
# Pipe to ed.
eval {
local $SIG{PIPE} = sub { die 'Pipe broke...' };
local $SIG{CHLD} = sub { die 'Bad child...' };
open ED, "| ed - -s $self->{i_file}" or die "Couldn't fork ed: $!";
print ED map @$_, @cmd or die "Couldn't print ed: $!";
print ED "1,\$w $self->{o_file}" or die "Couldn't print ed: $!";
close ED or die "Couldn't close ed: $?";
};
# Did pipe to ed work?
unless ($@ or <$out> ne $magic) {
$self->note("Hunk #$self->{hunk} succeeded at 1.\n");
return 1;
}
# Erase any trace of magic line.
truncate $out, 0 or throw "Couldn't truncate OUT: $!";
seek $out, 0, 0 or throw "Couldn't seek OUT: $!";
# Try to apply ed script by hand.
$self->note("Pipe to ed failed. Switching to Plan J...\n");
PLAN_J:
# Pre-process each ed command. Ed diffs are reversed (so that each
# command doesn't end up changing the line numbers of subsequent
# commands). But we need to apply diffs in a forward direction because
# our filehandles are oriented that way. So we calculate the @offset
# in line number that this will cause as we go.
my @offset;
for (my $i = 0; $i < @cmd; $i++) {
my @hunk = @{$cmd[$i]};
shift(@hunk) =~ m!^(\d+)(?:,(\d+))?([acds])!
or throw "Unable to parse ed script.";
my ($start, $end, $cmd) = ($1, $2 || $1, $3);
# We don't parse substitution commands and assume they all mean
# s/\.\././ even if they really mean s/\s+// or such. And we
# blindly apply the command to the previous hunk.
if ($cmd eq 's') {
$cmd[$i] = '';
s/\.\././ for @{$cmd[$i-1][3]};
next;
}
# Remove '.' line used to terminate hunks.
pop @hunk if $cmd =~ /^[ac]/;
# Calculate where we actually start and end by removing any offsets.
my ($s, $e) = ($start, $end);
for (@offset) {
$start > $_->[0] or next;
$s -= $_->[1];
$e -= $_->[1];
}
# Add to the total offset.
push @offset, [$start, map {
/^c/ ? scalar @hunk - ($end + 1 - $start) :
/^a/ ? scalar @hunk :
/^d/ ? $end + 1 - $start :
0
} $cmd];
# Post-processed command.
$cmd[$i] = [$s, $e, $cmd, \@hunk, $i];
}
# Sort based on calculated start positions or on original order.
# Substitution commands have already been applied and are ignored.
@cmd = sort {
$a->[0] <=> $b->[0] || $a->[-1] <=> $b->[-1]
} grep ref, @cmd;
my $in = $self->{i_fh};
my $def = $self->{d_fh};
my $ifdef = $self->{ifdef};
# Apply each command.
for (@cmd) {
my ($start, $end, $cmd, $hunk) = @$_;
if ($cmd eq 'a') {
my $diff = $start - $self->{i_lines};
print $out scalar <$in> while $diff--;
print $def "#ifdef $ifdef\n";
print $out @$hunk;
$self->{i_lines} = $start;
} elsif ($cmd eq 'd') {
my $diff = $start - $self->{i_lines} - 1;
print $out scalar <$in> while $diff--;
print $def "#ifndef $ifdef\n";
print $def scalar <$in> for $start..$end;
$self->{i_lines} = $end;
( run in 0.572 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )