view release on metacpan or  search on metacpan

inc/bin/patch  view on Meta::CPAN

#
# mail tgy@chocobo.org < bug_reports
#
# Copyright (c) 1999 Moogle Stuffy Software.  All rights reserved.
#
# You may play with this software in accordance with the Perl Artistic License.

use strict;

my $VERSION = '0.25';

$|++;

if (@ARGV && $ARGV[0] eq '-v') {
    print split /^    /m, qq[
        This is patch $VERSION written in Perl.

        Copyright (c) 1999 Moogle Stuffy Software.  All rights reserved.

        You may play with this software in accordance with the
        Perl Artistic License.
    ];
    exit;
}

my ($patchfile, @options);

if (@ARGV) {
    require Getopt::Long;
    Getopt::Long::Configure(qw/
        bundling
        no_ignore_case
    /);

    # List of supported options and acceptable arguments.
    my @desc = qw/
        suffix|b=s              force|f                 reject-file|r=s
        prefix|B=s              batch|t                 reverse|R
        context|c               fuzz|F=i                silent|quiet|s
        check|C                 ignore-whitespace|l     skip|S
        directory|d=s           normal|n                unified|u
        ifdef|D=s               forward|N               version|v
        ed|e                    output|o=s              version-control|V=s
        remove-empty-files|E    strip|p=i               debug|x=i
    /;

    # Each patch may have its own set of options.  These are separated by
    # a '+' on the command line.
    my @opts;
    for (@ARGV, '+') {  # Now '+' terminated instead of separated...
        if ($_ eq '+') {
            push @options, [splice @opts, 0];
        } else {
            push @opts, $_;
        }
    }

    # Parse each set of options into a hash.
    my $next = 0;
    for (@options) {
        local @ARGV = @$_;
        Getopt::Long::GetOptions(\my %opts, @desc);
        $opts{origfile} = shift;
        $_ = \%opts;
        $patchfile = shift unless $next++;
    }
}

$patchfile = '-' unless defined $patchfile;

my $patch = Patch->new(@options);

tie *PATCH, Pushback => $patchfile or die "Can't open '$patchfile': $!";

# Extract patches from patchfile.  We unread/pushback lines by printing to
# the PATCH filehandle:  'print PATCH'
PATCH:
while (<PATCH>) {
    if (/^(\s*)(\@\@ -(\d+)(?:,(\d+))? \+(\d+)(?:,(\d+))? \@\@\n)/) {
        # UNIFIED DIFF
        my ($space, $range, $i_start, $i_lines, $o_start, $o_lines) =
           ($1,     $2,     $3,       $4 || 1,  $5,       $6 || 1);
        $patch->bless('unified') or next PATCH;
        my @hunk;
        my %saw = map {$_, 0} split //, ' +-';
        my $re = qr/^$space([ +-])/;
        while (<PATCH>) {
            unless (s/$re/$1/) {
                $patch->note("Short hunk ignored.\n");
                $patch->reject($range, @hunk);
                print PATCH;
                next  PATCH;
            }
            push @hunk, $_;
            $saw{$1}++;
            last if $saw{'-'} + $saw{' '} == $i_lines
                 && $saw{'+'} + $saw{' '} == $o_lines;
        }
        $patch->apply($i_start, $o_start, @hunk)
            or $patch->reject($range, @hunk);
    } elsif (/^(\s*)\*{15}$/) {
        # CONTEXT DIFF
        my $space = $1;
        $_ = <PATCH>;
        unless (/^$space(\*\*\* (\d+)(?:,(\d+))? \*\*\*\*\n)/) {
            print PATCH;
            next  PATCH;
        }
        my ($i_range, $i_start, $i_end, @i_hunk) = ($1, $2, $3 || $2);
        my ($o_range, $o_start, $o_end, @o_hunk);
        $patch->bless('context') or next PATCH;
        my $o_hunk = qr/^$space(--- (\d+)(?:,(\d+))? ----\n)/;
        my $re = qr/^$space([ !-] )/;
        $_ = <PATCH>;
        if (/$o_hunk/) {
            ($o_range, $o_start, $o_end) = ($1, $2, $3 || $2);
        } else {
            print PATCH;
            for ($i_start..$i_end) {
                $_ = <PATCH>;
                unless (s/$re/$1/) {