File Coverage

blib/lib/match/simple/sugar.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	8	10	80.0
condition	9	17	52.9
subroutine	17	17	100.0
pod	3	3	100.0
total	94	104	90.3

package match::simple::sugar;

use 5.006001;
use strict;
use warnings;

use Exporter::Tiny;
use Carp qw( croak );
use Scalar::Util qw( blessed );
use match::simple qw( match );

BEGIN {
	$match::simple::sugar::AUTHORITY = 'cpan:TOBYINK';
	$match::simple::sugar::VERSION   = '0.012';
	my $strict = 0;
	$ENV{$_} && $strict++ for qw(
		EXTENDED_TESTING
		AUTHOR_TESTING
		RELEASE_TESTING
		PERL_STRICT
	);
	eval qq{
		sub STRICT () { !! $strict }
		sub LAX    () {  ! $strict }
	};
}

our @ISA       = qw( Exporter::Tiny );
our @EXPORT    = qw( when then numeric match );

my $then_class    = __PACKAGE__ . '::then';
my $numeric_class = __PACKAGE__ . '::numeric';

sub when {
	my @things = @_;
	my $then = pop @things;
	if ( blessed $then and $then->isa( $then_class ) ) {
		if ( match $_, \@things ) {
			no warnings 'exiting';
			$then->();
			next;
		}
	}
	else {
		croak "when: expects then";
	}
	return;
}

sub _check_coderef {
	my $coderef = shift;
	require B;
	local *B::OP::__match_simple_sugar_callback = sub {
		my $name = $_[0]->name;
		croak "Block appears to contain a `$name` statement; not suitable for use with when/then"
			if match $name, [ qw/ wantarray return redo last next / ];
		return;
	};
	B::svref_2object( $coderef )->ROOT->B::walkoptree( '__match_simple_sugar_callback' );
}

sub then (&) {
	my $coderef = shift;
	_check_coderef $coderef if STRICT;
	bless $coderef, $then_class;
}

sub numeric ($) {
	my $n = shift;
	bless \$n, $numeric_class;
}

{
	my $check = sub {
		my ( $x, $y ) = map {
			( blessed $_ and $_->isa( $numeric_class ) )
				? $$_
				: $_;
		} @_[0, 1];
		no warnings qw( numeric );
		defined $x and defined $y and !ref $x and !ref $y and $x == $y;
	};
	no strict 'refs';
	*{"$numeric_class\::MATCH"} = $check;
}

1;

__END__