File Coverage

blib/lib/Parse/KeywordX.pm

Criterion	Covered	Total	%
statement	82	93	88.1
branch	14	36	38.8
condition	5	6	83.3
subroutine	14	15	93.3
pod	0	5	0.0
total	115	155	74.1

use 5.014;
use strict;
use warnings;

use Exporter::Tiny ();

package Parse::KeywordX;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.037';

use Text::Balanced qw( extract_bracketed );
use PadWalker qw( closed_over set_closed_over peek_my );
use Parse::Keyword {};

our @ISA    = qw( Exporter::Tiny );
our @EXPORT = qw( parse_name parse_variable parse_trait parse_block_or_match );

#### From p5-mop-redux
sub read_tokenish ()
{
	my $token = '';
	if ((my $next = lex_peek) =~ /[\$\@\%]/)
	{
		$token .= $next;
		lex_read;
	}
	while ((my $next = lex_peek) =~ /\S/)
	{
		$token .= $next;
		lex_read;
		last if ($next . lex_peek) =~ /^\S\b/;
	}
	return $token;
}

#### From p5-mop-redux
sub parse_name
{
	my ($what, $allow_package, $stop_at_single_colon) = @_;
	my $name = '';

	# XXX this isn't quite right, i think, but probably close enough for now?
	my $start_rx = qr/^[\p{ID_Start}_]$/;
	my $cont_rx  = qr/^\p{ID_Continue}$/;
	my $char_rx = $start_rx;

	while (1)
	{
		my $char = lex_peek;

		last unless length $char;
		if ($char =~ $char_rx)
		{
			$name .= $char;
			lex_read;
			$char_rx = $cont_rx;
		}
		elsif ($allow_package && $char eq ':')
		{
			if (lex_peek(3) !~ /^::(?:[^:]|$)/)
			{
				return $name if $stop_at_single_colon;
				die("Not a valid $what name: $name" . read_tokenish);
			}
			$name .= '::';
			lex_read(2);
		}
		else
		{
			last;
		}
	}

	die("Not a valid $what name: " . read_tokenish) unless length $name;

	($name =~ /\A::/) ? "main$name" : $name;
}

sub parse_variable
{
	my $allow_bare_sigil = $_[0];

	my $sigil = lex_peek(1);
	($sigil eq '$' or $sigil eq '@' or $sigil eq '%')
		? lex_read(1)
		: die("Not a valid variable name: " . read_tokenish);

	my $name = $sigil;

	my $escape_char = 0;
	if (lex_peek(2) eq '{^')
	{
		lex_read(2);
		$name .= '{^';
		$name .= parse_name('escape-char variable', 0);
		lex_peek(1) eq '}'
			? ( lex_read(1), ($name .= '}') )
			: die("Expected closing brace after escape-char variable");
		return $name;
	}

	if (lex_peek =~ /[\w:]/)
	{
		$name .= parse_name('variable', 1, 1);
		return $name;
	}

	if ($allow_bare_sigil)
	{
		return $name;
	}

	die "Expected variable name";
}

sub parse_trait
{
	my $name = parse_name('trait', 0);
	#lex_read_space;

	my $extracted;
	if (lex_peek eq '(')
	{
		my $peek = lex_peek(1000);
		$extracted = extract_bracketed($peek, '()');
		lex_read(length $extracted);
		lex_read_space;
		$extracted =~ s/(?: \A\( | \)\z )//xgsm;
	}

	my $evaled = 1;
	if (defined $extracted)
	{
		my $ccstash = compiling_package;
		$evaled = eval("package $ccstash; no warnings; no strict; local \$SIG{__WARN__}=sub{die}; [$extracted]");
	}

	($name, $extracted, $evaled);
}

sub parse_block_or_match
{
	lex_read_space;
	return parse_block(@_) if lex_peek eq '{';

	require match::simple;

	my $___term = parse_arithexpr(@_);

	eval <<"CODE" or die("could not eval implied match::simple comparison: $@");
		sub {
			local \$_ = \@_ ? \$_[0] : \$_;
			match::simple::match(\$_, \$___term->());
		};
CODE
}

1;