view release on metacpan or  search on metacpan

lib/Getopt/Long/DescriptivePod.pm  view on Meta::CPAN

package Getopt::Long::DescriptivePod; ## no critic (TidyCode)

use strict;
use warnings;

our $VERSION = '0.06';

use Carp qw(confess);
use English qw(-no_match_vars $PROGRAM_NAME $OS_ERROR $INPUT_RECORD_SEPARATOR);
use Params::Validate qw(validate SCALAR SCALARREF CODEREF);
use Sub::Exporter -setup => {
    exports => [ qw( replace_pod trim_lines ) ],
    groups  => {
        default => [ qw( replace_pod trim_lines ) ],
    },
};

sub _on_verbose {
    my ($param_ref, $string) = @_;

    if ( $param_ref->{on_verbose} ) {
        $param_ref->{on_verbose}->($string);
    }

    return;
}

sub _close_data {
    # after __END__ this handle is open
    no warnings qw(once); ## no critic (ProhibitNoWarnings)

    return close ::DATA;
}

sub _format_block {
    my $block_ref = shift;

    for my $key ( keys %{$block_ref} ) {
        VALUE: for my $value ( $block_ref->{$key} ) { # alias only
            defined $value
                or next VALUE;
            $value =~ s{ \r\n | [\n\r]       }{\n}xmsg; # compatible \n
            $value =~ s{ \A \n* (.*?) \n* \z }{$1}xms;  # trim
            $value = [
                ( $key eq 'after' ? q{} : () ),
                ( split m{ \n }xms, $value ),
                ( $key eq 'before' ? q{} : () ),
            ];
        }
    }

    return;
}

sub _read_file {
    my $param_ref = shift;

    if ( ref $param_ref->{filename} ) {
        return ${ $param_ref->{filename} };
    }
    if ( open my $file, '< :raw', $param_ref->{filename} ) {
        local $INPUT_RECORD_SEPARATOR = ();
        my $content = <$file>;
        () = close $file;
        return $content;
    }
    _verbose( $param_ref, "Can not open file $param_ref->{filename} $OS_ERROR" );

    return;
}

sub _write_file {
    my ($param_ref, $content) = @_;

    if ( ref $param_ref->{filename} ) {
        ${ $param_ref->{filename} } = $content;
        return;
    }
    open my $file, '> :raw', $param_ref->{filename}
        or confess "Can not open file $param_ref->{filename} $OS_ERROR";
    print {$file} $content
        or confess "Can not write file $param_ref->{filename} $OS_ERROR";
    close $file
        or confess "Can not close file $param_ref->{filename} $OS_ERROR";

    return;
}

sub replace_pod { ## no critic (ArgUnpacking)
    my %param_of = validate(
        @_,
        {
            filename          => { type  => SCALAR | SCALARREF, default => $PROGRAM_NAME },
            tag               => { regex => qr{ \A = \w }xms },
            before_code_block => { type  => SCALAR, optional => 1 },
            code_block        => { type  => SCALAR },
            after_code_block  => { type  => SCALAR, optional => 1 },
            indent            => { regex => qr{ \A \d+ \z }xms, default => 1 },
            on_verbose        => { type  => CODEREF, optional => 1 },
        },
    );

    BLOCK: for my $block ( qw(before_code_block code_block after_code_block) ) {
        defined $param_of{$block}
            or next BLOCK;
        $param_of{$block} =~ m{ ^ = }xms
            and confess "A Pod tag is not allowed in $block";
    }

    _close_data;

    # clone
    my %block_of = (
        before => $param_of{before_code_block},
        code   => $param_of{code_block},
        after  => $param_of{after_code_block},
    );

    _format_block( \%block_of );

    for my $line ( @{ $block_of{code} } ) {
        $line = q{ } x $param_of{indent} . $line;
    }

    # \t to indent, trim EOL
    my @block = map { ## no critic (ComplexMappings)
        my $value = $_;
        $value =~ s{ \t }{ q{ } x $param_of{indent} }xmsge;
        $value =~ s{ \s+ \z }{}xms;
        $value;
    } (
        @{ $block_of{before} || [] },
        @{ $block_of{code} },
        @{ $block_of{after} || [] },
    );

    my $current_content = _read_file( \%param_of );
    if ( ! $current_content ) {
        _on_verbose( \%param_of, 'Empty file detected' );
        return;
    }
    my ($newline) = $current_content =~ m{ ( \r\n | [\n\r] ) }xms;
    $current_content =~ s{ \r\n | [\n\r] }{\n}xmsg;
    my ($newlines_at_eof) = $current_content =~ m{ ( \n+ ) \z }xms;
    $newlines_at_eof = length +( $newlines_at_eof || q{} );
    $current_content =~ s{ \n+ \z }{}xms;
    my @content = split m{ \n }xms, $current_content;

    # replace Pod
    my $is_found;
    my $index = 0;
    LINE: while ( $index < @content ) {
        my $line = $content[$index];
        if ( $is_found ) {
            if ( $line =~ m{ \A = \w }xms ) { # stop deleting on next tag
                $is_found = ();
                last LINE;
            }
            splice @content, $index, 1; # delete current line
            redo LINE;
        }
        if ( $line =~ m{ \A \Q$param_of{tag}\E \z }xms ) {
            $is_found++;
            splice @content, $index + 1, 0, q{}, @block, q{};
            $index += 1 + @block + 1;
        }
        $index++;
    }

    # check changes
    my $new_content = join "\n", @content;
    if ( $newlines_at_eof ) {
        # restore current_content too
        for my $content ( $current_content, $new_content ) {
            $content .= "\n" x $newlines_at_eof;
        }
        _on_verbose( \%param_of, "$newlines_at_eof newline(s) at EOF detected" );
    }
    else {
        _on_verbose( \%param_of, 'No newline at EOF detected' );
    }
    if ( $new_content eq $current_content ) {
        _on_verbose( \%param_of, 'Equal content - nothing to do' );
        return;
    }

    $new_content =~ s{ \n }{$newline}xmsg;
    _write_file( \%param_of, $new_content );

    return;
}

sub trim_lines {
    my ($text, $indent) = @_;

    if (! $indent) {
        $text =~ s{ \s+    }{ }xmsg;
        $text =~ s{ \A \s+ }{}xms;
        $text =~ s{ \s+ \z }{}xms;
        return $text;
    }
    $indent =~ m{ \A [1-9] \d* \z }xms
        or confess "Indent $indent is not a positive integer";

    # measure the first line
    ($indent) = $text =~ m{ \A ( (?: [ ]{$indent} )+ ) }xms;
    $indent = length $indent;