File Coverage

blib/lib/Syntax/Feature/Qi.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	5	6	83.3
condition			n/a
subroutine	14	14	100.0
pod	0	1	0.0
total	78	80	97.5

use 5.10.0;
use strict;
use warnings;

package Syntax::Feature::Qi;

# ABSTRACT: Remove the same indendation from all lines in a string
our $AUTHORITY = 'cpan:CSSON'; # AUTHORITY
our $VERSION = '1.0000';

use Devel::Declare();
use B::Hooks::EndOfScope;
use Sub::Install qw/install_sub/;
use Devel::Declare::Context::Simple;
use namespace::clean;

my %quote_op = qw(qi q qqi qq);
my @new_ops = keys %quote_op;

sub install {
    my $class = shift;
    my %args = @_;

    my $target = $args{'into'};

    Devel::Declare->setup_for($target => {
        map {
            my $name = $_;
            ($name => {
                const => sub {
                    my $context = Devel::Declare::Context::Simple->new;
                    $context->init(@_);
                    return $class->_transform($name, $context);
                },
            });
        } @new_ops
    });
    foreach my $name (@new_ops) {
        install_sub {
            into => $target,
            as => $name,
            code => $class->_run_callback,
        };
    }
    on_scope_end {
        namespace::clean->clean_subroutines($target, @new_ops);
    };
    return 1;
}

sub _run_callback {

    return sub ($) {
        my $string = shift;
        return $string if $string =~ m{\A\s*\Z}ms;

        my $remove_indent = $string =~ m{\A(\h*)\S}      ? $1
                          : $string =~ m{\A\s*\n(\h*)\S} ? $1
                          :                                ''
                          ;
        $string =~ s{^$remove_indent}{}gms;
        return $string;
    };
}

sub _transform {
    my $class = shift;
    my $name = shift;
    my $ctx = shift;

    $ctx->skip_declarator;
    my $length = Devel::Declare::toke_scan_str($ctx->offset);
    my $string = Devel::Declare::get_lex_stuff;
    Devel::Declare::clear_lex_stuff;
    my $linestr = $ctx->get_linestr;
    my $quoted = substr $linestr, $ctx->offset, $length;
    my $spaced = '';
    $quoted =~ m{^(\s*)}sm;
    $spaced = $1;
    my $new = sprintf '(%s)', join '',
        $quote_op{$name},
        $spaced,
        substr($quoted, length($spaced), 1),
        $string,
        substr($quoted, -1, 1);
    substr($linestr, $ctx->offset, $length) = $new;
    $ctx->set_linestr($linestr);
    return 1;
}

1;

__END__