view release on metacpan or  search on metacpan

lib/Switcheroo.pm  view on Meta::CPAN

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);