File Coverage

blib/lib/File/Mangle.pm

Criterion	Covered	Total	%
statement	58	61	95.0
branch	9	14	64.2
condition	11	20	55.0
subroutine	9	9	100.0
pod	4	4	100.0
total	91	108	84.2

package File::Mangle;

use 5.008001;
use strict;
use warnings;

require Exporter;
require File::Slurp;

our @ISA = qw(Exporter);

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

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

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(replace_block);

our $VERSION = '0.02';

sub fetch_block {
    my ($filename, $marker) = @_;

    my $data = File::Slurp::read_file($filename);

    my $start = _format_start_marker($marker);
    my $end = _format_end_marker($marker);

    return unless $data =~ m{ \Q$start\E }xms and $data =~ m{ \Q$end\E }xms;

    if ( $data =~ m{
        ^ .* \Q$start\E .* $   # start marker
        ((?s: .*? ))           # existing content
        ^ .* \Q$end\E .* $     # end marker
    }xm ) {
        return $1;
    }
    else {
        return;
    }
}

sub replace_block {
    my ($filename, $marker, $replacement, $line_comment_marker) = @_;

    $line_comment_marker ||= '#';
    $replacement ||= '';

    my $data = File::Slurp::read_file($filename);

    my $start = _format_start_marker($marker);
    my $end = _format_end_marker($marker);

    unless ( $data =~ /$start/ and $data =~ /$end/ ) {
        $data .= "\n$line_comment_marker $start\n$line_comment_marker $end\n";
    }

    chomp $replacement;

    $data =~ s{
        ^ ( .* \Q$start\E .* ) $   # start marker
        ((?s: .*? ))               # existing content
        ^ ( .* \Q$end\E .* ) $     # end marker
    }{$1\n$replacement\n$3\n}xm;

    File::Slurp::write_file($filename, $data);

    return $2;
}

sub insert_block_before {
    my ($filename, $marker, $placement, $line_comment_marker) = @_;

    $line_comment_marker ||= '#';

    my $data = File::Slurp::read_file($filename);

    my $start = _format_start_marker($marker);
    my $end = _format_end_marker($marker);

    return if $data =~ m{ \Q$start\E }xms and $data =~ m{ \Q$end\E }xms;

    if ( $data =~ m{
            (
                \A (?s: .* )
            )
            (
                ^ .* $placement .* $
                (?s: .* ) \z
            )
        }xm
    ) {
        $data = $1;
        $data .= $line_comment_marker . ' ' . $start . "\n";
        $data .= $line_comment_marker . ' ' . $end . "\n";
        $data .= $2;

        File::Slurp::write_file($filename, $data);

        return 1;
    }
    else {
        return;
    }
}

sub insert_block_after {
    my ($filename, $marker, $placement, $line_comment_marker) = @_;

    $line_comment_marker ||= '#';

    my $data = File::Slurp::read_file($filename);

    my $start = _format_start_marker($marker);
    my $end = _format_end_marker($marker);

    return if $data =~ m{ \Q$start\E }xms and $data =~ m{ \Q$end\E }xms;

    if ( $data =~ m{
            (
                \A (?s: .* )
                ^ .* $placement .* $
            )
            (
                (?s: .* ) \z
            )
        }xm
    ) {
        $data = $1;
        $data .= "\n" . $line_comment_marker . ' ' .  $start . "\n";
        $data .= $line_comment_marker . ' ' . $end . "\n";
        $data .= $2;

        File::Slurp::write_file($filename, $data);

        return 1;
    }
    else {
        return;
    }
}

sub _format_start_marker {
    my $marker = shift;
    return '###:START:' . $marker . ':###';
}
sub _format_end_marker {
    my $marker = shift;
    return '###:END:' . $marker . ':###';
}

1;
__END__