libtext-patch-perl 1.8-1 / usr / share / perl5 / Text / Patch.pm

package Text::Patch;
use Exporter;
our @ISA = qw( Exporter );
our @EXPORT = qw( patch );
our $VERSION = '1.8';
use strict;
use warnings;
use Carp;

use constant NO_NEWLINE => '\\ No newline at end of file';

sub patch
{
  my $text = shift;
  my $diff = shift;
  my %options = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;

  my %handler = ('unified'  => \&patch_unified,
                 'context'  => \&patch_context,
                 'oldstyle' => \&patch_oldstyle,
                 );
  my $style = $options{STYLE};
  croak "required STYLE option is missing" unless $style;
  croak "source required" unless defined $text;
  croak "diff required" unless defined $diff;
  my $code = $handler{lc($style)} || croak "unrecognised STYLE '$style'";

  my @text = split /^/m, $text;
  my @diff = split /^/m, $diff;

  # analyse source/diff to determine line ending used.
  # (if source is only 1 line, can't use it to determine line endings)
  my $line1 = @text > 1 ? $text[0] : $diff[0];
  my($line1c, $sep) = _chomp($line1);
  $sep ||= "\n";  # default to unix line ending

  # apply patch
  DUMP("got patch", \@diff);
  my $out = $code->(\@text, \@diff, $sep);

  my $lastline = _chomp($diff[-1], $sep);
  $out = _chomp($out, $sep) if $lastline eq NO_NEWLINE;
  return $out;
}

sub patch_unified
{
  my($text, $diff, $sep) = @_;
  my @hunks;
  my %hunk;

  for( @$diff )
    {
    #print STDERR ">>> ... [$_]";
    if( /^\@\@\s*-([\d,]+)/ )
      {
      #print STDERR ">>> *** HUNK!\n";
      my($pos1, $count1) = split /,/, $1;
      push @hunks, { %hunk };
      %hunk = ();
      $hunk{ FROM } = $pos1 - 1; # diff is 1-based
      # Modification by Ben L., patches may have @@ -0,0 if the source is empty.
      $hunk{ FROM } = 0 if $hunk{ FROM } < 0;
      $hunk{ LEN  } = defined $count1 ? $count1 : $pos1 == 0 ? 0 : 1;
      $hunk{ DATA } = [];
      }
    push @{ $hunk{ DATA } }, $_;
    }
  push @hunks, { %hunk }; # push last hunk
  shift @hunks; # first is always empty

  return _patch($text, \@hunks, $sep);
}

sub patch_oldstyle {
    my($text, $diff, $sep) = @_;
    my @hunks;
    my $i = 0;

    my $hunk_head = qr/^([\d,]+)([acd])([\d,]+)$/;
    while($i < @$diff) {
        my $l = $diff->[$i];
        my($r1, $type, $r2) = $l =~ $hunk_head;
        die "Malformed patch at line ".($i + 1)."\n"
            unless defined $r1 && $type && defined $r2;
        my($pos1, $count1) = _range($r1);
        my($pos2, $count2) = _range($r2);

        # parse chunk data
        my @data;
        my $j = $i + 1;
        for(; $j < @$diff; $j++) {
            $l = $diff->[$j];
            last if $l =~ $hunk_head;
            next if $l =~ /^---/;  # separator
            push @data, $l;
        }
        my $datalen = $j - $i - 1;

        if($type eq 'a') { # add
            $count1 = 0;   # don't remove any lines
            $pos1++;       # add to line after pos1
        }

        # convert data to a format _patch() will understand
        for(@data) {
            $_ =~ s/^< /-/;
            $_ =~ s/^> /+/;
        }

        push @hunks, { FROM => $pos1 - 1,
                       LEN  => $count1,
                       DATA => \@data,
                     };
        $i += $datalen + 1;
    }
    return _patch($text, \@hunks, $sep);
}

# NB: this works by converting hunks into a kind of unified format
sub patch_context {
    my($text, $diff, $sep) = @_;
    my $i = 0;
    my @hunks;

    # skip past header
    for(@$diff) {
        $i++;
        last if /^\Q***************\E$/;  # end header marker
    }

    # this sub reads one half of a hunk (from/to part)
    my $read_part = sub {
        my $l = $diff->[$i++];
        TRACE("got line: $l");
        die "Malformed patch at line $i\n"
            unless $l =~ /^(?:\*\*\*|---)\s+([\d,]+)\s+(?:\*\*\*|---)/;
        my($pos, $count) = _range($1);
        my @part;
        while($i < @$diff) {
            my $l = $diff->[$i];
            last if $l =~ /^(\*\*\*|---)/;
            push @part, $l;
            $i++;
        }
        DUMP("got part", \@part);
        return (\@part, $pos, $count);
    };

    while($i < @$diff) {
        # read the from and to part of this hunk
        my($part1, $pos1, $count1) = $read_part->();
        my($part2, $pos2, $count2) = $read_part->();
        $i++;  # skip chunk separator

        # convert operations to unified style ones
        $_ =~ s/^(.)\s/$1/ for @$part1, @$part2;
        $_ =~ s/^\!/-/ for @$part1;  # remove
        $_ =~ s/^\!/+/ for @$part2;  # add

        # merge the parts to create a unified style chunk
        my @data;
        for(;;) {
            my $c1 = $part1->[0];
            my $c2 = $part2->[0];
            last unless defined $c1 || defined $c2;

            if(defined $c1 && $c1 =~ /^-/) {
                push @data, shift @$part1;  # remove line
            } elsif(defined $c2 && $c2 =~ /^\+/) {
                push @data, shift @$part2;  # add line
            } else {                        # context
                my($x1, $x2) = (shift @$part1, shift @$part2);
                push @data, defined $x1 ? $x1 : $x2;
            }
        }
        push @hunks, { FROM => $pos1 - 1,
                       LEN  => $count1,
                       DATA => \@data,
                     };
        DUMP("merged data", \@data);
    }
    return _patch($text, \@hunks, $sep);
}

######################################################################
# private

# returns (start line, line count)
sub _range {
    my($range) = @_;
    my($pos1, $pos2) = split /,/, $range;
    return ($pos1, defined $pos2 ? $pos2 - $pos1 + 1 : 1);
}

sub _patch {
  my($text, $hunks, $sep) = @_;
  my $hunknum = scalar @$hunks + 1;
  die "No hunks found\n" unless @$hunks;
  for my $hunk ( reverse @$hunks )
    {
    $hunknum--;
    DUMP("hunk", $hunk);
    my @pdata;
    my $num = $hunk->{FROM};
    for( @{ $hunk->{ DATA } } )
      {
      next unless s/^([ \-\+])//;
      #print STDERR ">>> ($1) $_";
      if($1 ne '+') {
          # not an addition, check line for match against existing text.
          # ignore line endings for comparison
          my $orig   = _chomp($text->[$num++], $sep); # num 0 based here
          my $expect = _chomp($_, $sep);
          TRACE("checking >>$orig<<");
          TRACE(" against >>$expect<<");
          die "Hunk #$hunknum failed at line $num.\n" # actual line number
              unless $orig eq $expect;
      }
      next if $1 eq '-';  # removals
      push @pdata, $_;    # add/replace line
      }
    splice @$text, $hunk->{ FROM }, $hunk->{ LEN }, @pdata;
    }

  return join '', @$text;
}

# chomp $sep from the end of line
# if $sep is not given, chomp unix or dos line ending
sub _chomp {
    my($text, $sep) = @_;
    if($sep) {
        $text =~ s/($sep)$//;
    } else {
        $text =~ s/(\r\n|\n)$//;
    }
    return wantarray ? ($text, $1) : $text;
}

sub DUMP {}
sub TRACE {}

#sub DUMP {
#use Data::Dumper;
#print STDERR Dumper(@_);
#}
#sub TRACE {
#use Data::Dumper;
#print STDERR Dumper(@_);
#}


=pod

=head1 NAME

Text::Patch - Patches text with given patch

=head1 SYNOPSIS

    use Text::Patch;

    $output = patch( $source, $diff, STYLE => "Unified" );

    use Text::Diff;

    $src  = ...
    $dst  = ...

    $diff = diff( \$src, \$dst, { STYLE => 'Unified' } );

    $out  = patch( $src, $diff, { STYLE => 'Unified' } );

    print "Patch successful" if $out eq $dst;

=head1 DESCRIPTION

Text::Patch combines source text with given diff (difference) data.
Diff data is produced by Text::Diff module or by the standard diff
utility (man diff, see -u option).

=over 4

=item patch( $source, $diff, options... )

First argument is source (original) text. Second is the diff data.
Third argument can be either hash reference with options or all the
rest arguments will be considered patch options:

    $output = patch( $source, $diff, STYLE => "Unified", ... );

    $output = patch( $source, $diff, { STYLE => "Unified", ... } );

Options are:

  STYLE => 'Unified'

STYLE can be "Unified", "Context" or "OldStyle".

The 'Unified' diff format looks like this:

  @@ -1,7 +1,6 @@
  -The Way that can be told of is not the eternal Way;
  -The name that can be named is not the eternal name.
   The Nameless is the origin of Heaven and Earth;
  -The Named is the mother of all things.
  +The named is the mother of all things.
  +
   Therefore let there always be non-being,
     so we may see their subtlety,
   And let there always be being,
  @@ -9,3 +8,6 @@
   The two are the same,
   But after they are produced,
     they have different names.
  +They both may be called deep and profound.
  +Deeper and more profound,
  +The door of all subtleties!


=back

=head1 TODO

  Interfaces with files, arrays, etc.

=head1 AUTHOR

  Vladi Belperchinov-Shabanski "Cade"

  <cade@biscom.net> <cade@datamax.bg> <cade@cpan.org>

  http://cade.datamax.bg

=head1 VERSION

  $Id: Patch.pm,v 1.6 2007/04/07 19:57:41 cade Exp $

=cut