File Coverage

blib/lib/Switcheroo.pm

Criterion	Covered	Total	%
statement	142	151	94.0
branch	14	50	28.0
condition	1	2	50.0
subroutine	17	17	100.0
pod	1	1	100.0
total	175	221	79.1

use 5.014;
use strict;
use warnings;

package Switcheroo;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.008';
our @EXPORT    = qw( switch );
our @EXPORT_OK = qw( match );
our @ISA       = qw( Exporter::Tiny );

use Exporter::Tiny qw( );
use match::simple qw( match );
use PadWalker qw( peek_my set_closed_over );
use Parse::Keyword { switch => \&_parse_switch };

sub import
{
	my $pkg = caller;
	eval qq[ package $pkg; our \$a; our \$b; ];
	goto \&Exporter::Tiny::import;
}

sub switch
{
	my ($pkg, $expr, $comparator, $cases, $default) = @_;

	my @args = @_ = do {
		package # replaces Devel::Caller::caller_args(1)
		DB; my @x = caller(1); our @args;
	};

	my $pad = peek_my(1);
	my $var = defined($expr)
		? do {
			set_closed_over($expr, $pad);
			$expr->(@args);
		}
		: $_;
	Internals::SvREADONLY($var, 1);
	local *_ = \$var;

	my $match = \&match::simple::match;
	if ($comparator)
	{
		$match = sub {
			no strict 'refs';
			local *{"$pkg\::a"} = \ $_[0];
			local *{"$pkg\::b"} = \ $_[1];
			$comparator->(@args);
		};
	}

	CASE: for my $case ( @$cases )
	{
		my ($type, $condition, $block) = @$case;

		my $matched = 0;
		if ($type eq 'block')
		{
			set_closed_over($condition, $pad);
			$matched = !!$condition->(@args);
		}
		else
		{
			TERM: for my $termexpr (@$condition)
			{
				set_closed_over($termexpr, $pad);
				my $term = $termexpr->(@args);
				$match->($var, $term) ? (++$matched && last TERM) : next TERM;
			}
		}

		set_closed_over($block, $pad);
		goto $block if $matched;
	}

	if ($default)
	{
		set_closed_over($default, $pad);
		goto $default;
	}
	return;
}

sub _parse_switch
{
	my ($expr, $comparator, @cases, $default);
	my $is_statement = 1;

	lex_read_space;

	if (lex_peek eq '(')
	{
		lex_read(1);
		lex_read_space;
		$expr = parse_fullexpr;
		lex_read_space;
		die "syntax error; expected close parenthesis" unless lex_peek eq ')';
		lex_read(1);
		lex_read_space;
	}

	if (lex_peek(4) eq 'mode')
	{
		lex_read(4);
		lex_read_space;
		die "syntax error; expected open parenthesis" unless lex_peek eq '(';
		lex_read(1);
		lex_read_space;
		$comparator = parse_fullexpr;
		lex_read_space;
		die "syntax error; expected close parenthesis" unless lex_peek eq ')';
		lex_read(1);
		lex_read_space;
	}

	if (lex_peek(2) eq 'do')
	{
		lex_read(2);
		lex_read_space;
		$is_statement = 0;
	}

	die "syntax error; expected block" unless lex_peek eq '{';
	lex_read(1);
	lex_read_space;

	while ( lex_peek(4) eq 'case' )
	{
		lex_read(4);
		push @cases, _parse_case();
		lex_read_space;
	}

	if ( lex_peek(7) eq 'default' )
	{
		lex_read(7);
		lex_read_space;
		if (lex_peek eq ':')
		{
			lex_read(1);
			lex_read_space;
		}
		$default = _parse_consequence();
		lex_read_space;
	}

	die "syntax error; expected end of switch block" unless lex_peek eq '}';
	lex_read(1);

	my $pkg = compiling_package;

	return (
		sub { ($pkg, $expr, $comparator, \@cases, $default) },
		$is_statement,
	);
}

sub _munge_term
{
	if (lex_peek(1) eq '/')
	{
		lex_stuff('qr');
	}
	elsif (lex_peek(2) =~ /m\W/)
	{
		lex_read(1);
		lex_stuff('qr');
	}
}

sub _parse_case
{
	my ($expr, $type);
	lex_read_space;

	if (lex_peek eq '(')
	{
		lex_read(1);
		$type = 'term';
		$expr = _parse_list_of_terms(\&_munge_term);
		lex_read_space;
		die "syntax error; expected close parenthesis" unless lex_peek eq ')';
		lex_read(1);
		lex_read_space;
	}

	elsif (lex_peek eq '{')
	{
		$type = 'block';
		$expr = parse_block;
		lex_read_space;
	}

	else
	{
		$type = 'simple-term';
		$expr = _parse_list_of_terms(\&_munge_term);
		lex_read_space;
	}

	die "syntax error; expected colon" unless lex_peek eq ':';
	lex_read(1);
	lex_read_space;

	my $block = _parse_consequence();
	return [ $type, $expr, $block ];
}

sub _parse_list_of_terms
{
	my $munge = shift;

	my @expr;
	lex_read_space;
	$munge->() if $munge;
	push @expr, parse_termexpr;
	lex_read_space;

	while (lex_peek eq ',')
	{
		lex_read(1);
		lex_read_space;
		$munge->() if $munge;
		push @expr, parse_termexpr;
		lex_read_space;
	}

	return \@expr;
}

sub _parse_consequence
{
	my ($expr, $type);
	lex_read_space;

	my $block = (lex_peek eq '{') ? parse_block() : parse_fullstmt();
	lex_read_space;
	(lex_read(1), lex_read_space) while lex_peek eq ';';

	return $block;
}


1;

__END__