view release on metacpan or  search on metacpan

bin/patch  view on Meta::CPAN

        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') {
    die "Hmm...  I can't seem to find a patch in there anywhere.\n";
} else {
    $patch->end;
}

exit(EX_REJECTS) if $patch->error;
$patch->note("done\n");
exit EX_SUCCESS;

END {
    close STDOUT || die "$0: can't close stdout: $!\n";
    $? = EX_FAILURE if $? == 255;  # from die
}





package
	Patch; # hide from PAUSE

use vars qw/$ERROR/;

# Class data.
BEGIN {
    $ERROR = 0;
}

# Simple throw/catch error handling.
sub throw {
    my $self = shift;
    $@ = join '', @_;
    $@ .= sprintf " at %s line %d\n", (caller)[1..2] unless $@ =~ /\n\z/;
    goto CATCH;
}

# Prints a prompt message and returns response.
{
    my $TERM;
    sub prompt {
        unless ($TERM) {
            # From commit 5c9f32cb374a034c1ad4b9e02a9b9ee2014b9b5c:
            #
            # with strawberry perl under windows 7 (and likely elsewhere)
            # the default tends to be to use Term::ReadLine::Perl, which
            # doesn't work well on windows. Force it to T::RL::Stub instead
            local $ENV{PERL_RL} = $ENV{PERL_RL} || 'stub' if $^O eq 'MSWin32';
            require Term::ReadLine;
            $TERM = Term::ReadLine->new('patch');
        }

        $TERM->readline(join '', @_);
    }
}

# 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'};
	$options //= [];

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

    # Item 'garbage' is probably better off as class data
    $self->{garbage} = [];          # garbage lines
    $self->{i_pos}   = 0;           # current position in 'in' file
    $self->{i_lines} = 0;           # lines read in 'in' file
    $self->{o_lines} = 0;           # lines written to 'out' file
    $self->{hunk}    = 1;           # current hunk number