File Coverage

blib/lib/Text/Patch/Rred.pm

Criterion	Covered	Total	%
statement	52	130	40.0
branch	14	80	17.5
condition	1	3	33.3
subroutine	10	12	83.3
pod	6	6	100.0
total	83	231	35.9

#!/usr/bin/perl

# Copyright (C) 2006-2009 Jakob Bohm.  All Rights Reserved.
# See README in the distribution for the current license status of the
#    entire package, including this file.

=head1 NAME

Text::Patch::Rred - Safely apply diff --ed style patches

=head1 VERSION

This is version 0.06

=cut

package Text::Patch::Rred;

use 5.006;    # Even older might work, but are not supported
use strict;
use warnings;
use Carp qw(carp croak);
use base qw(Exporter);
our $VERSION = '0.06';

=head1 USAGE

=head2 Command Line:

S F F F [ F ... ]>

=head2 Functional Interface (preferred, faster, type checked)

    my @lines = ;
    my $edState = Text::Patch::Rred::Init(@lines);
            # or &Text::Patch::Rred::Init(\@lines);
    while () { Text::Patch::Rred::Do1($edState, $_); }
    @lines = Text::Patch::Rred::Result($edState);
    $edState = undef; # free memory
    print PATCHED @lines;

=head2 Object Interface:

    my @lines = ;
    my $edState = Text::Patch::Rred->new(\@lines);
    while () { $edState->Do1($_); }
    @lines = $edState->Result;
    $edState = undef; # free memory
    print PATCHED @lines;

=head2 Example:

    $ diff --ed file.v1 file.v2 >file.patch1
    $ diff --ed file.v2 file.v3 >file.patch2
    $ rred file.v1 file.new file.patch1 [ file.patch2 ... ]
    $ # Now file.new is the same as file.v3
    $ # Alternative:
    $ cat file.patch1 file.patch2 | rred file.v1 file.new -

=head1 DESCRIPTION

This module and program safely and securely applies one or more
S patches as produced by the command S
newfile>>.  It does exactly what you tell it to and no more, even
with wildly bad or evil input.

Unlike the traditional programs L|patch(1)>, L|ed(1)>,
L|red(1)> and L|sed(1)>, Rred does not allow the data
in the patch to run arbitrary commands, read or write files or
otherwise cause havoc.  Only the handful of safe "commands" actually
used by L|diff(1)> are recognized and processed.

Unlike the L|patch(1)> program and the perl modules
L|Text::Patch>, L|PatchReader> and
L|Meta::Development::Patch>, this module
does NOT try to doubleguess what kind of data it is given or which
file to process.

(Note that the other perl modules just mentioned cannot actually
apply an ed-style patch, though some can parse it).

The name B is short for "Really Restricted ED" (as compared to
L|red(1)>).  This is the name given to a similar utility used
inside the Debian projects apt facility.


=head1 REQUIRED ARGUMENTS

=over 4

=item F

Original file whose contents is to be patch.  This file should be identical
to the first file passed to I>> when the patches were made.  In
this implementation, perl magics are supported for this file name.

=item F

Output file where the fully patched contents is to be written.  This file
will become identical to the last file passed to I>> when the
patches were made.  This file can be the same file as any of the input
files.  In this implementation, perl magics are B supported for this
file name.

=item F [ F ... ]

One or more --ed style patch files to be applied (in sequence) to the
contents of F to produce F.  These files should be
identical to the output of one or more invocations of I>> on
F and F plus optionally any intermediary files. The
patch files may optionally be concatenated before being passed to B,
the result will be the same as passing them individually. In this
implementation, perl magics are supported for these file names.

=back

=head1 EXPORT

L|/Init @lines>, L|/Do1 $edState, $patchline>,
L|/Do $edState, @lines>, L|/Result $edState> and
L|/main @ARGV> can be exported.  B<:all> is short for
L|/Init @lines>, L|/Do1 $edState, $patchline> and
L|/Result $edState>. Nothing is exported by default.

=cut

# This allows declaration	use Text::Patch::Rred ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ('all' => [qw(Init Do1 Result)]);

our @EXPORT_OK = qw(Init Do1 Result Do main);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# Perl::Critic wrongly complains about this line: our @EXPORT = qw();

=begin comment

# Internal data format:
#    For efficiency, the state is an array with the following elements
#    $a[0]               1 in insert mode, 0 in command mode
#    $a[1]               index in $a of start of hole after current line
#                     == 1 + index in $a of current line
#                     == 1 + current line no + 3
#                     == current line no + 4
#                        (so current line = 0 is stored as 4)
#    $a[2]               index in $a storing first line after current
#                     == index in $a after end of hole after current line
#    $a[3]               index in $a after last line
#    $a[4    ..$a[1]-1]  lines up to and including current line
#    $a[$a[1]..$a[2]-1]  hole: free entries to make insertion easy
#    $a[$a[2]..$a[3]-1]  lines after current line
#    $a[$a[3]..$#a    ]  possibly unused entries
# Each of the 4 ranges can be empty (i..i-1) but not less than that
# Each line is stored as a reference to a string, not as a string, this is
#    done to avoid massive memory thrashing when patching large files.
#
# To allow the object oriented variant of the code to work too, the array
#    reference above is actually stored as the sole member of a returned
#    hash reference, to conform to normal subclassing behaviour.

=end comment

=cut

=head1 FUNCTIONS and METHODS

=over

=item B I<\@lines>

=cut

sub new($$)
{
    my ($class, $rlins) = @_;
    my $n = scalar @$rlins;
    ## no critic (ProhibitComplexMappings)
    my $ro = {
        RA => [
            0, $n + 4, $n + 1004, $n + 1004,
            (map { my $a = $_; \$a } @$rlins),
            (undef) x 1000
        ]
    };
    ## use critic (ProhibitComplexMappings)
    bless $ro, ((ref $class) or $class);
    return $ro;
}

=item B I<@lines>

Initializes a new patch state and sets the initial file content to a
copy of the lines of text (each a string) supplied.  Returns a new
B object if successful, undef on error (there
are no current error scenarios).

Lines in C<@lines> must use the same line endings (none or "\n") as
lines passed to L|/Do1 $edState, $patchline> and L|/Do
$edState, @lines>

=cut

sub Init(\@)
{
    my ($rlins) = @_;
    return new(__PACKAGE__, $rlins);
}

=item B I<$edState>

=item I<$edState>->B

Returns the lines of the patched file as a list of strings, does not
destroy C<$edState> so you can apply more patches later.

=cut

sub Result($)
{
    my $ra = shift->{RA};

    return
      map { $$_ }
      @{$ra}[ 4 .. ($ra->[1] - 1), ($ra->[2]) .. ($ra->[3] - 1) ];
}

# Internal function: Change current pos to line $n-1, deleting lines
#    $n .. $p inclusive
sub _GoPos($$$)
{
    my ($ra, $n, $p) = @_;
    my $i = $ra->[1];
    my $j = $ra->[2];

    $n = 1 if ($n <= 0);
    $n += 3;
    $p += 4;
    my $m = $j - $i + $p;

    # Change hole start to $n, delete first $p-$n lines after hole
    #    new hole size  is then      ($j-$i) + ($p-$n)
    #    new hole end+1 is then $n + ($j-$i) + ($p-$n)
    #                        ==      ($j-$i) + $p
    #                        == $m
    # In summary:
    # Now: $i..$j-1 is the old position and hole as indexes
    #      $n..$m-1 is the new position and hole as indexes
    #      $p == $m - ($j - $i)

    if ($m > $ra->[3]) {
        $m = $ra->[3];
        $p = $m - $j + $i;
    }

    $n = $p if ($n > $p);

    # Now: $i..$j-1 is the old position and hole as indexes
    #      $n..$m-1 is the new position and hole as indexes
    #      $p == $m - ($j - $i)
    # The new hole size is >= the old hole size
    # The new hole does not go outside the actual lines available
    $ra->[1] = $n;
    $ra->[2] = $m;
    if ($n != $m) {
        if ($m < $j) {    # The most common case, diff works backwards
            if ($j - $m < 1000) {
                @{$ra}[ $m .. ($j - 1) ] = @{$ra}[ $p .. ($i - 1) ];
            } else {
                splice @$ra, $i, ($j - $i);
                splice @$ra, $n, 0, ((undef) x ($m - $n));
            }
        } elsif ($n > $i) {    # This mostly happens when combining diffs
            if ($n - $i < 1000) {
                @{$ra}[ $i ..   ($n - 1) ] =
                  @{$ra}[ $j .. ($n + $j - $i - 1) ];
            } else {
                splice @$ra, $i, ($j - $i);
                splice @$ra, $n, 0, ((undef) x ($m - $n));
            }
        }    # If neither is true, the old hole touches/overlaps/is the
             #    the old hole, and no data needs to be moved
    }
    return;
}

=item B I<$edState>, I<$patchline>

=item I<$edState>->B(I<$patchline>)

Applies one line from a patch file to C<$edState>.  Returns a true
value if the line was understood.  Carps and returns C if an
unsupported command is input.

=cut

## no critic (ProhibitExcessComplexity, ProhibitCascadingIfElse)
sub Do1($$)
{
    my $ra = shift->{RA};
    local $_ = shift;
    my $i = $ra->[1];
    my $j = $ra->[2];

    if ($ra->[0]) {
        unless (/^\.$/) {
            my $v = $_;
            if ($i == $j) {
                splice @$ra, $i, 0, ((undef) x 1000);
                $ra->[2] += 1000;
                $ra->[3] += 1000;
            }
            $ra->[ $i++ ] = \$v;
            $ra->[1] = $i;
        } else {
            $ra->[0] = 0;
        }
    } elsif (/^a\s*$/) {
        $ra->[0] = 1;
    } elsif (/^([0-9]+)a/) {
        $ra->[0] = 1;
        _GoPos($ra, 1 + $1, $1);    # Delete nothing
    } elsif (/^d\s*$/) {
        if ($i > 4) {
            if ($j < $ra->[3]) {    # Set current line to line after
                                    #   Deleting current line in the process
                $ra->[ $i - 1 ] = $ra->[$j];
                $ra->[2] = ++$j;
            } else {                # delete last line and stay at last line
                $ra->[1] = --$i;
            }
        } elsif ($j < $ra->[3]) {

            # delete non-existant line 0 and advance to line 1
            $ra->[4] = $ra->[$j];
            $ra->[1] = 5;
            $ra->[2] = ++$j;
        }    # Last possibility is an empty file, do nothing
    } elsif (/^([0-9]+)d/) {
        _GoPos($ra, $1,     $1);
        _GoPos($ra, 1 + $1, $1);    # Set current line to line after
    } elsif (/^([0-9]+),([0-9]+)d/) {
        _GoPos($ra, $1,     $2);
        _GoPos($ra, 1 + $1, $1);    # Set current line to line after
    } elsif (/^c\s*$/) {
        $ra->[0] = 1;
        if ($i > 4) {
            $ra->[1] = --$i;   # delete cur line and append after the one bef
        }    # Otherwise delete nonexistent line 0 and append there
    } elsif (/^([0-9]+)c/) {
        $ra->[0] = 1;
        _GoPos($ra, $1, $1);
    } elsif (/^([0-9]+),([0-9]+)c/) {
        $ra->[0] = 1;
        _GoPos($ra, $1, $2);
    } elsif (m!^s/\^?\\?\.//\s*$!) {
        if ($i > 4) {

            # diff uses this to insert lines consisting of a single .
            $_ = $ra->[ --$i ];
            $$_ =~ s/^\.//;
            $ra->[$i] = $_;
        }
    } elsif (/^w/) {

        # ignore write command sometimes appended to patch files
    } elsif (/^\s*$/) {

        # ignore blank command lines (but not blank lines in added text)
    } else {
        carp "Unexpected non-patch ed command: '" . $_ . "'\n";
        return;
    }
    return 1;
}
## use critic (ProhibitExcessComplexity, ProhibitCascadingIfElse)

=item B I<$edState>, I<@lines>

=item I<$edState>->B(I<@lines>)

Simply calls L|/Do1 $edState, $patchline> for each element of
C<@lines>, returns a true value if all calls were successful or
C<@lines> was empty.  Otherwise returns C.

=cut

## no critic (RequireArgUnpacking)
sub Do($;)
{
    my $self = shift;
    local $_ = undef;
    my $ok = 1;
    for (@_) {
        unless (ref $_) {
            Do1($self, $_) or ($ok = undef);
        } else {
            for (@$_) {
                Do1($self, $_) or ($ok = undef);
            }
        }
    }
    return $ok;
}
## use critic (RequireArgUnpacking)

=item B I<@ARGV>

The main program code of rred as a function, accepting the command
line syntax in the L|/Command Line:> above.  Returns the
program exit code (0 ok, 1 error, 2 bad syntax).  Running C
args> is the same as running

    perl -MText::Patch::Rred \
        -e 'exit Text::Patch::Rred::main @ARGV' args

=cut

sub main(@)
{
    my (@args) = @_;

    if (@args < 3) {
        print STDERR <<'ENDUSAGE'
Copyright (C) 2006-2009 Jakob Bohm.  All Rights Reserved.
usage:   rred file.old file.new file.patch1 [ file.patch2 ... ]
    (perl open magics are supported in all file names)
Applies one or more diff --ed or diff -e patches to file.old, creating
    file.new . file.old and file.new can be the same file.  Perl open
    magics are supported in all input file names.  This help is displayed
    on stderr, use rred --help 2>file to capture it.
example:
    zcat Packages.diff/2006-04-23-1343.24.gz \
         Packages.diff/2006-04-24-1329.37.gz |
    rred Packages Packages -
ENDUSAGE
          or croak $0. ': Printing usage: ' . $!;
        return 2;
    }

    my $namIn  = shift @args;
    my $namOut = shift @args;

    ## no critic (ProhibitTwoArgOpen)

    open FH, $namIn or croak "Loading '" . $namIn . "': " . $!;
    my @lines =  or croak "Loading '" . $namIn . "': " . $!;
    close FH or croak "Loading '" . $namIn . "': " . $!;
    my $edState = Init(@lines);
    @lines = ();    # Release loading memory

    for my $fn (@args) {
        open FH, $fn or croak "Reading '" . $fn . "': " . $!;
        while () { Do1($edState, $_); }
        close FH or croak "Reading '" . $fn . "': " . $!;
    }

    @lines   = Result($edState);
    $edState = undef;              # free memory
    open FH, '>', $namOut or croak "Saving  '" . $namOut . "': " . $!;
    print FH @lines or croak "Saving  '" . $namOut . "': " . $!;
    close FH or croak "Saving  '" . $namOut . "': " . $!;

    ## use critic (ProhibitTwoArgOpen)

    return 0;
}

# Automatically run main if Rred.pm is invoked as a perl program, rather
#    than a script.
# Note: This line would be more readable with paranthesis, but Perl::Critic
#    complains about such clarity.
exit main(@ARGV) unless defined caller;

1;
__END__