File Coverage

blib/lib/Sub/SmartMatch.pm

Criterion	Covered	Total	%
statement	84	89	94.3
branch	21	32	65.6
condition	11	21	52.3
subroutine	17	17	100.0
pod	4	6	66.6
total	137	165	83.0

#!/usr/bin/perl

package Sub::SmartMatch;

use strict;
use warnings;

use 5.010;

use Carp qw(croak);
use Scalar::Util qw(reftype);

our $VERSION = "0.02";

use base qw(Exporter);

our @EXPORT = our @EXPORT_OK = qw(multi multi_default def_multi exactly);



BEGIN {
	# If we have Sub::Name, great. If not, nevermoose

	local $@;

	eval {
		require Sub::Name;
		no warnings 'redefine';
		*subname = \&Sub::Name::subname;
	};

	*subname = sub { $_[1] } unless defined &subname;
}

sub exactly ($) {
	my $value = shift;

	if ( ref($value) and ref($value) eq 'ARRAY' ) {
		bless \$value, __PACKAGE__ . "::Exact";
	} else {
		return $value;
	}
}

# guess the fully qualified name for a sub using caller()
sub full_name ($) {
	my $name = shift;

	croak "A subroutine name is required"
		unless defined($name) and length($name);

	return $name if $name =~ /::/;

	foreach my $level ( 0 .. 2 ) {
		my $pkg = caller($level);
		next if $pkg eq __PACKAGE__;
		return join "::", $pkg, $name;
	}
}


our ( %variants, %default );

sub multi ($$$) {
	my ( $name, $case, $body ) = @_;

	$name = full_name($name);


	unless ( ref($body) and reftype($body) eq 'CODE' ) {
		my $body_str = defined($body)
			? ( ref($body) ? $body : "'$body'" )
			: "undef";

		croak "$body_str is not a code reference";
	}

	def_multi($name);

	my $exact = ref($case) && ref($case) eq __PACKAGE__ . "::Exact";
	$case = $$case if $exact;

	my $partial_match = not($exact) && ref($case) && ref($case) eq 'ARRAY' && @$case;

	push @{ $variants{$name} }, [ $partial_match, $case, $body ];

	return $body;
}

sub multi_default ($$) {
	my ( $name, $body ) = @_;

	croak "$body is not a code reference"
		unless ref($body) and reftype($body) eq 'CODE';

	$name = full_name($name);

	def_multi($name);

	$default{$name} = $body;
}

sub def_multi ($;@) {
	my ( $name, @args ) = @_;
	$name = full_name($name);

	unless ( exists $variants{$name} ) {
		my @variants;

		my $sub = sub {
			given ( \@_ ) {
				foreach my $variant ( @variants ) {
					my ( $partial, $case, $body ) = @$variant;

					if ( $partial ) {
						given ( [ @_[0 .. $#$case] ] ) {
							when ( $case ) { goto $body }
						}
					} else {
						when ( $case ) { goto $body }
					}
				}

				default {
					if ( my $default = $default{$name} ) {
						goto $default;
					} else {
						croak "No variant found for arguments";
					}
				}
			}
		};

		{
			no strict 'refs';
			*$name = subname $name, $sub;
		}

		$variants{$name} = \@variants;
	}

	def_variants($name, @args) if @args;
}

sub def_variants ($;) {
	my ( $name, @variants ) = @_;

	$name = full_name($name);

	def_multi($name);

	croak "The variant list is not even sized"
		unless @variants % 2 == 0;

	while ( @variants ) {
	   	my ( $case, $body ) = splice(@variants, 0, 2);

		if ( not ref($case) and $case ~~ 'default' ) {
			multi_default $name, $body;
		} else{
			multi $name, $case, $body;
		}
	}
}

__PACKAGE__

__END__