File Coverage

blib/lib/Syntax/Feature/Qwa.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch			n/a
condition			n/a
subroutine	15	15	100.0
pod	0	1	0.0
total	71	72	98.6

package Syntax::Feature::Qwa;

use 5.010;
use strict;

BEGIN {
	$Syntax::Feature::Qwa::AUTHORITY = 'cpan:TOBYINK';
	$Syntax::Feature::Qwa::VERSION   = '0.001';
}

use Devel::Declare          0.006007    ();
use Devel::Declare::Context::Simple 0 ();
use B::Hooks::EndOfScope    0.09;
use Sub::Install            0.925       qw( install_sub );
use namespace::clean 0;

my @NewOps  = qw(qwa qwh qwk);
my %QuoteOp = (
	qwa  => q{  [%s] },
	qwh  => q{ +{%s} },
	qwk  => q{ do { my $i = 0; +{ map { $_=>++$i } %s } } },
	);

sub import
{
	my ($class) = @_;
	my $caller  = caller(0);
	@_ = ($class, 'into', $caller);
	goto \&install;
}

sub install
{
	my ($class, %args) = @_;

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

sub _run_callback { sub($){shift} }

sub _transform
{
	my ($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 $QuoteOp{$name}, join q[],
		q[qw],
		$spaced,
		substr($quoted, length($spaced), 1),
		$string,
		substr($quoted, -1, 1);
	substr($linestr, $ctx->offset, $length) = $new;
	$ctx->set_linestr($linestr);
#	my $s = $ctx->get_linestr;
#	warn ">>> $s\n";
	return 1;
}

__PACKAGE__
__END__