view release on metacpan or  search on metacpan

inc/bin/patch  view on Meta::CPAN

            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;

    # -c, -e, -n, -u
    $self->{$_} and $type eq $_ || $self->skip("Not a $_ diff!\n")
        for qw/context ed normal unified/;

    # Speculate to user.
    my $n = $type eq 'ed' ? 'n' : '';
    $self->note("Hmm...  Looks like a$n $type diff to me...\n");

    # Change directories.
    for ($self->{directory}) {
        defined or last;
        chdir $_ or $self->skip("Can't chdir '$_': $!\n");
    }

    # Get original file to patch...
    my $orig = $self->{origfile};                   # ...from -o

    unless (defined $orig) {
        $orig = $self->rummage($garbage);           # ...from leading garbage
        if (defined $orig) {
            $self->note(
                "The text leading up to this was:\n",
                "--------------------------\n",
                map("|$_", @$garbage),
                "--------------------------\n",
            );
        } else {
            $self->skip if $self->{force} || $self->{batch};
            $orig = prompt ('File to patch: ');     # ...from user
        }
    }

    # Make sure original file exists.
    if ($self->{force} || $self->{batch}) {
        -e $orig or $self->skip;
    } else {
        until (-e $orig) {
            $self->skip unless prompt (
                'No file found--skip this patch? [n] '
            ) =~ /^[yY]/;
            $orig = prompt (
                'File to patch: '
            );
        }
    }

    my ($in, $out);

    # Create backup file.  I have no clue what Plan A is really supposed to be.
    if ($self->{check}) {
        $self->note("Checking patch against file $orig using Plan C...\n");
        ($in, $out) = ($orig, '');
    } elsif (defined $self->{output}) {
        $self->note("Patching file $orig using Plan T...\n");
        local $_ = $self->{output};
        $self->skip if -e && not rename $_, $self->backup($_) and
            $self->{force} || $self->{batch} || prompt (
                'Failed to backup output file--skip this patch? [n] '
            ) =~ /^[yY]/;
        ($in, $out) = ($orig, $self->{output});
    } else {
        $self->note("Patching file $orig using Plan A...\n");
        my $back = $self->backup($orig);
        if (rename $orig, $back) {
            ($in, $out) = ($back, $orig);
        } else {
            $self->skip unless $self->{force} || $self->{batch} or prompt (
                'Failed to backup original file--skip this patch? [n] '
            ) !~ /^[yY]/;
            ($in, $out) = ($orig, $orig);
        }
    }

    # Open original file.
    local *IN;
    open IN, "< $in" or $self->skip("Couldn't open INFILE: $!\n");
    binmode IN;
    $self->{i_fh} = *IN;    # input filehandle
    $self->{i_file} = $in;  # input filename

    # Like /dev/null
    local *NULL;
    tie *NULL, 'Dev::Null';

    # Open output file.
    if ($self->{check}) {
        $self->{o_fh} = \*NULL;     # output filehandle
        $self->{d_fh} = \*NULL;     # ifdef filehandle
    } else {
        local *OUT;
        open OUT, "+> $out" or $self->skip("Couldn't open OUTFILE: $!\n");
        binmode OUT;
        $|++, select $_ for select OUT;
        $self->{o_fh}   = *OUT;
        $self->{o_file} = $out;
        $self->{d_fh}   = length $self->{ifdef} ? *OUT : \*NULL;
    }

    $self->{'reject-file'} = "$out.rej" unless defined $self->{'reject-file'};

    # Check for 'Prereq:' line.
    unless ($self->{force}) {
        my $prereq = (map /^Prereq:\s*(\S+)/, @$garbage)[-1];
        if (defined $prereq) {
            $prereq = qr/\b$prereq\b/;
            my $found;
            while (<IN>) {
                $found++, last if /$prereq/;
            }
            seek IN, 0, 0 or $self->skip("Couldn't seek INFILE: $!\n");
            $self->skip if not $found and $self->{batch} || prompt (
                'File does not match "Prereq: $1"--skip this patch? [n] '
            ) =~ /^[yY]/;
        }
    }

    SKIP:
    $_[0] = $self;
}

# Skip current patch.
sub skip {
    my $self = shift;
    $self->note(@_) if @_;
    $self->note("Skipping patch...\n");
    $self->{skip}++;
    goto SKIP;
}

# Let user know what's happening.
sub note {
    my $self = shift;
    print @_ unless $self->{silent} || $self->{skip};
}

# Add to lines of leading garbage.
sub garbage {
    push @{shift->{garbage}}, @_;
}

# Add to rejected hunks.
sub reject {
    push @{shift->{rejects}}, [@_];
}

# Total number of hunks rejected.
sub error {
    $ERROR;
}

# End of patch clean up.
sub end {
    my $self = shift;

    return if $self->{skip} || ref $self eq 'Patch';

    $self->print_tail;
    $self->print_rejects;
    $self->remove_empty_files;
}

# Output any lines left in input handle.
sub print_tail {
    my $self = shift;
    print {$self->{o_fh}} readline $self->{i_fh};
}

# Output rejected hunks to reject file.
sub print_rejects {
    my $self = shift;
    my @rej = @{$self->{rejects}};

inc/bin/patch  view on Meta::CPAN

            $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;