File Coverage

blib/lib/Syntax/Feature/Ql.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch			n/a
condition			n/a
subroutine	17	17	100.0
pod			n/a
total	79	79	100.0

use strictures 1;

# ABSTRACT: Turns a quoted string into a single line

package Syntax::Feature::Ql;
{
  $Syntax::Feature::Ql::VERSION = '0.001000';
}
BEGIN {
  $Syntax::Feature::Ql::AUTHORITY = 'cpan:PHAYLON';
}
use Devel::Declare          0.006007    ();
use B::Hooks::EndOfScope    0.09;
use Sub::Install            0.925       qw( install_sub );

use aliased 'Devel::Declare::Context::Simple', 'Context';

use syntax qw( simple/v2 );
use namespace::clean;

my @NewOps  = qw( ql qql );
my %QuoteOp = (ql => 'q', qql => 'qq');

method install ($class: %args) {
    my $target = $args{into};
    Devel::Declare->setup_for($target => {
        map {
            my $name = $_;
            ($name => {
                const => sub {
                    my $ctx = Context->new;
                    $ctx->init(@_);
                    return $class->_transform($name, $ctx);
                },
            });
        } @NewOps,
    });
    for my $name (@NewOps) {
        install_sub {
            into => $target,
            as   => $name,
            code => $class->_run_callback,
        };
    }
    on_scope_end {
        namespace::clean->clean_subroutines($target, @NewOps);
    };
    return 1;
}

method _run_callback {
    return sub ($) {
        my $string = shift;
        $string =~ s{(?:^\s+|\s+$)}{}gsm;
        return join ' ', split m{\s*\n\s*}, $string;
    };
}

method _transform ($class: $name, $ctx) {
    $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 '',
        $QuoteOp{$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__