File Coverage

blib/lib/Config/Patch.pm

Criterion	Covered	Total	%
statement	341	396	86.1
branch	108	166	65.0
condition	22	28	78.5
subroutine	47	49	95.9
pod	12	26	46.1
total	530	665	79.7

##################################################
package Config::Patcher::Util;
##################################################

##################################################
# Poor man's Class::Struct
##################################################
sub make_accessor {
##################################################
    my($package, $name) = @_;

    no strict qw(refs);

    my $code = <
        *{"$package\\::$name"} = sub {
            my(\$self, \$value) = \@_;

            if(defined \$value) {
                \$self->{$name} = \$value;
            }
            if(exists \$self->{$name}) {
                return (\$self->{$name});
            } else {
                return "";
            }
        }
EOT
    if(! defined *{"$package\::$name"}) {
        eval $code or die "$@";
    }
}

###########################################
package Config::Patch::Hunk;
###########################################
use MIME::Base64;

our @accessors = qw(
  mode key text pos_from pos_to header
  content_pos_from content_pos_to regex method
  as_string
);
Config::Patcher::Util::make_accessor( __PACKAGE__, $_ ) for @accessors;

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        comment_char => '#',
        mode         => "append",
        key          => undef,
        text         => undef,
        %options,
    };

    bless $self, $class;
}

###########################################
sub patch_marker {
###########################################
    my($self) = @_;

    return $self->{comment_char} .
           "(Config::Patch-" .
           "$self->{key}-" .
           $self->mode() .
           ")" .
           "\n";
}

###########################################
sub string_generate {
###########################################
    my($self) = @_;

    return $self->patch_marker() .
           $self->text() .
           $self->patch_marker();
}

###########################################
sub freeze {
###########################################
    my($self, $string) = @_;

    # Hide an arbitrary string in a comment
    my $encoded = encode_base64($string);

    $encoded =~ s/^/$self->{comment_char} /gm;
    return $encoded;
}

###########################################
sub thaw {
###########################################
    my($self, $string) = @_;

    # Decode a hidden string
    $string =~ s/^$self->{comment_char} //gm;
    my $decoded = decode_base64($string);
    return $decoded;
}

###########################################
sub replstring_extract {
###########################################
    my($self) = @_;

    my $text = $self->text();

    # Find the replace string in a patch
    my $replace_marker = $self->replace_marker();
    $replace_marker = quotemeta($replace_marker);
    if($text =~ /^$replace_marker\n(.*?)
                  ^$replace_marker/xms) {
        my $repl = $1;
        $text =~ s/^$replace_marker.*?
                    ^$replace_marker\n//xms;

        return($self->thaw($repl), $text);
    }

    return undef;
}

###########################################
sub replstring_hide {
###########################################
    my($self, $replstring) = @_;

    # Add a replace string to a patch
    my $replace_marker = $self->replace_marker();
    my $encoded = $replace_marker . "\n" .
                  $self->freeze($replstring) .
                  $replace_marker .
                  "\n";

    return $encoded;
}

###########################################
sub replace_marker {
###########################################
    my($self) = @_;

    return $self->{comment_char} .
           "(Config::Patch::replace)";
}

###########################################
package Config::Patch;
###########################################
use strict;
use warnings;
use Set::IntSpan;
use Fcntl qw(:flock);
use Log::Log4perl qw(:easy);

our $VERSION     = "0.09";

our @accessors = qw(data file comment_char key);
Config::Patcher::Util::make_accessor( __PACKAGE__, $_ ) for @accessors;

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        comment_char => '#',
        key          => undef,
        file         => undef,
        parsed       => 0,
        read         => 0,
        %options,
    };

    my $package = __PACKAGE__;

    $self->{patch_regex} =
        qr{^$self->{comment_char}\($package-(.*)-(.*?)\)}m;

    bless $self, $class;
}

###########################################
sub read {
###########################################
    my($self, $file) = @_;

    if(defined $file) {
        $self->{file} = $file;
    }

    $self->{data} = $self->slurp( $self->{file} );

      # fix trailing newline if it's missing
    $self->{data} .= "\n" unless substr($self->{data}, -1, 1) eq "\n";

    $self->{parsed} = 0;
    $self->{read}   = 1;

    return $self->{data};
}

###########################################
sub error {
###########################################
    my($self, @text) = @_;

    if(defined $text[0]) {
        $self->{error} = join "", @text;
        ERROR $self->{error};
    }

    return $self->{error};
}

###########################################
sub patch_by_stretch {
###########################################
    my($self, $text, $mode) = @_;

    LOGDIE "No key defined" unless
        defined $self->{key};

    LOGDIE "No mode defined" unless
        defined $mode;

    my $patch = Config::Patch::Hunk->new(
        comment_char => $self->{comment_char},
        key          => $self->{key},
        text         => $text,
        mode         => $mode,
    );

    return $self->apply( $patch );
}

###########################################
sub apply {
###########################################
    my($self, $patch) = @_;

    $self->read() unless $self->{read};

    $patch->{comment_char} = $self->{comment_char};

    my $key = $patch->key();

      # TODO: Lower-level functions expect it there, but probably should
      # be carried as an argument.
    $self->{key} = $key;

    my $patchtext = $patch->string_generate();

    if ($patch->{mode} eq "prepend") {
        $self->{data} = $patchtext . $self->{data};

    } elsif ($patch->{mode} eq "append") {
        $self->{data} .= $patchtext;

    } elsif ($patch->{mode} eq "replace") {
        $self->patch_by_wedge($patch->regex(), $patch->text(), "replace");

    } elsif ($patch->{mode} eq "insert-before") {
        $self->patch_by_wedge($patch->regex(), $patch->text(), "insert");

    } elsif ($patch->{mode} eq "insert-after") {
        $self->patch_by_wedge($patch->regex(), $patch->text(), "insert", 1);

    } elsif ($patch->{mode} eq "update") {
        $self->patch_update( $patch->key(), $patch->text() );

    } elsif ($patch->{mode} eq "comment_out") {
        $self->patch_comment_out( $patch->key(), $patch->regex() );

    } else {
        LOGDIE "Unknown mode '$patch->{mode}'";
    }

    return 1;
}

###########################################
sub save {
###########################################
    my($self) = @_;

    $self->blurt($self->{data}, $self->{file});
}

###########################################
sub save_as {
###########################################
    my($self, $file) = @_;

    LOGDIE "No file defined" unless defined $file;
    $self->{file} = $file;

    return $self->save();
}

###########################################
sub patched {
###########################################
    my($self, $key) = @_;

    my @patches = $self->parse();

    if( grep { $key eq $_->key() } @patches ) {
        return 1;
    }

    return 0;
}

###########################################
sub parse {
###########################################
    my($self) = @_;

    my @patches = ();

    $self->{forbidden_zones} = Set::IntSpan->new();

    $self->data_traverse( sub {
        my($patcher, $patch) = @_;

        $patcher->{forbidden_zones} =
          Set::IntSpan::union( $patcher->{forbidden_zones},
            ($patch->pos_from() . "-" . $patch->pos_to()));

        push @patches, $patch;
    }, sub {
    });

    $self->{parsed} = 1;

    return @patches;
}

###########################################
sub patch_update {
###########################################
    my($self, $key, $newvalue) = @_;

    if(length $newvalue and
       substr($newvalue, -1, 1) ne "\n") {
        $newvalue .= "\n";
    }

    my $skew = 0;

    for my $hunk ( $self->parse() ) {
        next if $hunk->key() ne $key;

        substr($self->{data}, $hunk->content_pos_from + $skew,
               $hunk->content_pos_to - $hunk->content_pos_from)
            = $newvalue;

        $skew += length($newvalue) - length($hunk->text());
    }
}

###########################################
sub patches_only {
###########################################
    my($self) = @_;

    my $new_content = "";

    for my $hunk ( $self->parse() ) {
        $new_content .= $hunk->as_string();
    }

    $self->{data} = $new_content;
}

###########################################
sub patch_by_wedge {
###########################################
    my($self, $search, $replace, $mode, $after) = @_;

    if($self->patched( $self->{key} )) {
        INFO "$mode cancelled: File already patched with key $self->{key}";
        return undef;
    }

    if(ref($search) ne "Regexp") {
        LOGDIE "$mode search parameter not a regex {$search}";
    }

    if(length $replace and
       substr($replace, -1, 1) ne "\n") {
        $replace .= "\n";
    }

    my $data = $self->{data};

    my $positions = $self->full_line_match($data, $search);
    my @pieces    = ();
    my $rest      = $data;
    my $offset    = 0;

    my $patch = Config::Patch::Hunk->new(
        comment_char => $self->{comment_char},
        key          => $self->{key},
        mode         => $mode,
    );

    for my $pos (@$positions) {
        my($from, $to) = @$pos;
        my($before, $trail);
        my $hide;
        if ($mode eq "insert" ) {
            if ($after) {
                $before = substr($data, $offset, $to+1);
                $rest   = substr($data, $to+1);
                $hide   = "";
                $trail  = "";
            } else {
                $before = substr($data, $offset, $from-$offset);
                $rest   = substr($data, $to+1);
                $hide   = "";
                $trail  = substr($data, $from, $to - $from + 1);
            }
        } elsif ($mode eq "replace") {
            $before = substr($data, $offset, $from-$offset);
            $rest   = substr($data, $to+1);

            $hide   = $patch->replstring_hide(
                        substr($data, $from, $to - $from + 1));
            $trail  = "";
        }

        $patch->text( $replace . $hide );
        push @pieces, $before, $patch->string_generate(), $trail;
        $offset = $to + 1;
    }

    push @pieces, $rest;

    $self->{data} = join '', @pieces;

    return 1;
}

###########################################
sub full_line_match {
###########################################
    my($self, $string, $rex) = @_;

    DEBUG "Trying to match '$string' with /$rex/";

    # Try a regex match and if it succeeds, extend the match
    # to cover the full first and last line. Return a ref to
    # an array of from-to offsets of all (extended) matching
    # regions.
    my @positions = ();

    while($string =~ /($rex)/g) {
        my $first = pos($string) - length($1);
        my $last  = pos($string) - 1;

        DEBUG "Found match at pos $first-$last ($1) pos=", pos($string);

            # Is this match located in any of the forbidden zones?
        my $intersect = Set::IntSpan::intersect(
                            $self->{forbidden_zones}, "$first-$last");
        unless(Set::IntSpan::empty($intersect)) {
            DEBUG "Match was in forbidden zone - skipped";
            next;
        }

            # Go back to the start of the line
        while($first and
              substr($string, $first, 1) ne "\n") {
            $first--;
        }
        $first += 1 if $first;

            # Proceed until the end of the line
        while($last < length($string) and
              substr($string, $last, 1) ne "\n") {
            $last++;
        }

        DEBUG "Match positions corrected to $first-$last (line start/end)";

            # Ignore overlapping matches
        if(@positions and $positions[-1]->[1] > $first) {
            DEBUG "Detected overlap (two matches in same line) - skipped";
            next;
        }

        push @positions, [$first, $last];
    }

    return \@positions;
}

###########################################
sub comment_out {
###########################################
    my($self, $search) = @_;

        # Same as "replace by nothing"
    return $self->replace($search, "");
}

###########################################
sub eject {
###########################################
    my($self, $key) = @_;

    $self->read() unless $self->{read};

      # We accept a hunk instead of a key as well
    if(ref $key eq __PACKAGE__ . "::Hunk") {
        $key = $key->key();
    }

    $key = $self->{key} unless defined $key;

    my $new_content = "";

    $self->data_traverse( sub {
        my($patcher, $patch) = @_;

        DEBUG "Remove: '", $patch->text(), "' (",
              $patch->pos_from(), "-", $patch->pos_to();

        if($patch->key() eq $key) {
            if($patch->mode() eq "replace") {
                  # We've got a replace section, extract its
                  # hidden content and re-establish it
                my($hidden, $stripped) = $patch->replstring_extract();
                $new_content .= $hidden;
            } else {
                # Replace by nothing
            }
        } else {
                # This isn't our patch
            $new_content .= $patch->header() .
                            $patch->text() .
                            $patch->header();
        }
    }, sub {
        my($patcher, $text) = @_;
        $new_content .= $text;
    });

    $self->{data} = $new_content;
}

###########################################
sub data_traverse {
###########################################
    my($self, $patch_cb, $text_cb) = @_;

    my $in_patch  = 0;
    my $patch_text     = "";
    my $text      = "";
    my $start_pos;
    my $end_pos;
    my $pos       = 0;
    my $header;

    for my $line (split /\n/, $self->{data}) {
        $_ = "$line\n";

        $pos += length($_);
        $patch_text .= $_ if $in_patch and $_ !~ $self->{patch_regex};

            # text line?
        if($_ !~ $self->{patch_regex} and !$in_patch) {
            $text .= $_;
        }

            # closing line of patch
        if($_ =~ $self->{patch_regex} and
           $in_patch) {
            $end_pos = $pos - 1;

            my $patch_obj = Config::Patch::Hunk->new(
                comment_char      => $self->{comment_char},
                key               => $1,
                mode              => $2,
                text              => $patch_text,
                pos_from          => $start_pos,
                pos_to            => $end_pos,
                header            => $header,
                content_pos_from  => $start_pos + length($&) + 1,
                content_pos_to    => $end_pos   - length($&),
                as_string         => substr( $self->{data}, $start_pos,
                                             $end_pos - $start_pos + 1 ),
            );

            $patch_cb->($self, $patch_obj);
            $patch_text = "";
        }

            # toggle flag
        if($_ =~ $self->{patch_regex}) {
            if($in_patch) {
                # End line
            } else {
                # Start Line
                $text_cb->($self, $text);
                $start_pos = $pos - length $_;
                $header = $_;
            }
            $text = "";
            $in_patch = ($in_patch xor 1);
        }
    }

    $text_cb->($self, $text) if length $text;

    return 1;
}

###############################################
sub blurt {
###############################################
    my($self, $data, $file) = @_;

    open FILE, ">$file" or LOGDIE "Cannot open $file ($!)";
    print FILE $data;
    close FILE;
}

###############################################
sub slurp {
###############################################
    my($self, $file) = @_;

    local $/ = undef;
    open FILE, "<$file" or LOGDIE "Cannot open $file ($!)";
    my $data = ;
    close FILE;

    return $data;
}

###########################################
sub lock {
###########################################
    my($self) = @_;

        # Ignore if locking wasn't requested
    return if ! $self->{flock};

        # Already locked?
    if($self->{locked}) {
        $self->{locked}++;
        return 1;
    }

    open my $fh, "+<$self->{file}" or
        LOGDIE "Cannot open $self->{file} ($!)";

    flock($fh, LOCK_EX);

    $self->{fh} = $fh;

    $self->{locked} = 1;
}

###########################################
sub unlock {
###########################################
    my($self) = @_;

        # Ignore if locking wasn't requested
    return if ! $self->{flock};

    if(! $self->{locked}) {
            # Not locked?
        return 1;
    }

    if($self->{locked} > 1) {
            # Multiple lock released?
        $self->{locked}--;
        return 1;
    }

        # Release the last lock
    flock($self->{fh}, LOCK_UN);
    $self->{locked} = undef;
    1;
}

# LEGACY METHODS

###########################################
sub patches {
###########################################
    my($self) = @_;

    # LEGACY METHOD, DON'T USE

    my @patches = ();
    my %patches = ();

    $self->data_traverse(
        sub { my($patcher, $patch) = @_;
              push @patches,
                   [$patch->key(),
                    $patch->mode(),
                    $patch->text(),
                    $patch->pos_from(),
                    $patch->pos_to(),
                    $patch->header(),
                    $patch->content_pos_from(),
                    $patch->content_pos_to(),
                   ];
              $patches{ $patch->key() }++;
            },
        sub { },
    );

    return \@patches, \%patches;
}

###########################################
sub prepend {
###########################################
    my($self, $text) = @_;

    # LEGACY METHOD, DON'T USE

    $self->lock();
    $self->read() unless $self->{read};

    $self->patch_by_stretch( $text, "prepend" );

    $self->save();
    $self->unlock();
    return 1;
}

###########################################
sub append {
###########################################
    my($self, $text) = @_;

    # LEGACY METHOD, DON'T USE

    $self->lock();
    $self->read() unless $self->{read};

    $self->patch_by_stretch( $text, "append" );

    $self->save();
    $self->unlock();
    return 1;
}

###########################################
sub replace {
###########################################
    my($self, $search, $patchtext) = @_;

    # LEGACY METHOD, DON'T USE

    $self->lock();
    $self->read() unless $self->{read};

    $self->patch_by_wedge($search, $patchtext, "replace");

    $self->save();
    $self->unlock();
}

###########################################
sub insert {
###########################################
    my($self, $search, $data, $after) = @_;

    # LEGACY METHOD, DON'T USE

    $self->lock();
    $self->read() unless $self->{read};

    $self->patch_by_wedge($search, $data, "insert", $after);

    $self->save();
    $self->unlock();
}

###########################################
sub remove {
###########################################
    my($self, $key) = @_;

    # LEGACY METHOD, DON'T USE

    $self->lock();
    $self->read() unless $self->{read};

    $self->eject( $key );

    $self->save();
    $self->unlock();
}

1;

__END__