File Coverage

blib/lib/Sub/PatMat.pm

Criterion	Covered	Total	%
statement	92	136	67.6
branch	10	46	21.7
condition	7	33	21.2
subroutine	20	22	90.9
pod	0	7	0.0
total	129	244	52.8

package Sub::PatMat;
use 5.8.2;
use strict;
use warnings;
use B;
use B::Utils qw/walkoptree_filtered opgrep/;
use Carp;

use vars qw($VERSION);
$VERSION = 0.01;

my %whens;
my %names;
my $redefine_bitch;
my @redefinitions;

sub import
{
	no strict 'refs';
	my $pkg = caller(0);
	*{$pkg."::MODIFY_CODE_ATTRIBUTES"} = \&modify_code_attributes;
	eval "package $pkg; CHECK { Sub::PatMat::do_check(\"\Q$pkg\E\") }";
	eval "package $pkg; INIT { Sub::PatMat::do_init() }";
}

sub modify_code_attributes {
	my ($pkg, $sub, @attr) = @_;
	my @rest;
	my $when;
	for (@attr) {
		if (/^when(.*)$/) {
			$when = $1;
		} else {
			push @rest, $_;
		}
	}
	if (defined $when) {
		push @{$whens{$pkg}}, {
			func => $sub,
			when => $when,
		};
	}
	return @rest;
}

BEGIN {
my $old_warn_handler = $SIG{__WARN__};
$SIG{__WARN__} = sub {
	return if $_[0] =~ /package attribute may clash with future reserved word: when/;
	if (!$redefine_bitch && $_[0] =~ /^Subroutine (.*) redefined/) {
		push @redefinitions, { func => $1, bitch => $_[0] };
		return;
	}
	goto &$old_warn_handler if $old_warn_handler;
	warn(@_);
};
}

sub create_pat_mat
{
	my ($pkg, $name, $info) = @_;
	my $code = "package $pkg; \*$name = sub {\n";
	my $op = "if";
	my $n = 0;
	my $cv = eval "*$pkg\::$name\{CODE}";
	if ($cv && @$info && $info->[-1]{func} ne $cv) {
		# print "fallback for $name: $cv\n";
		push @$info, { func => $cv, when => "()" };
	}
	for my $i (@$info) {
		my $cond = $i->{when};
		$cond = "(1)" if $cond eq "()";
		$cond = replace_aliases($cond, $info->[$n]{func});
		$code .= "$op $cond { &{\$info->[$n]{func}} }\n";
		$op = "elsif";
		$n++;
	}
	$code .= "else { use Carp; local \$Carp::CarpLevel = 1; croak \"Bad match calling \Q$name\E\" } }\n";
	# print $code;
	eval $code or die $@;
}

sub padname
{
	my ($padlist, $op) = @_;

	my $padname = $padlist->[0]->ARRAYelt($op->targ);
	if ($padname && !$padname->isa("B::SPECIAL")) {
		return if $padname->FLAGS & B::SVf_FAKE;
		return $padname->PVX;
	}
	return;
}

sub get_gv_name
{
	my ($padlist, $op) = @_;

	my ($gv_on_pad, $gv_idx);
	if ($op->isa("B::SVOP")) {
		$gv_idx = $op->targ;
	} elsif ($op->isa("B::PADOP")) {
		$gv_idx = $op->padix;
		$gv_on_pad = 1;
	} else {
		return "";
	}

	my $gv = $gv_on_pad ? "" : $op->sv;
	if (!$gv || !$$gv) {
		$gv = $padlist->[1]->ARRAYelt($gv_idx);
	}
	return "" unless $gv->isa("B::GV");
	$gv->NAME;
}

sub replace_aliases
{
	my ($cond, $sub) = @_;
	my $cv = B::svref_2object($sub);
	my $root = $cv->ROOT;
	my $padlist = [$cv->PADLIST->ARRAY];
	my %vars;
	walkoptree_filtered($root,
		sub { opgrep({ name => "aassign"}, @_) },
		sub {
			my ($op) = (@_);
			return unless
				$op->first->name eq "null" &&
				$op->first->first->name eq "pushmark" &&
				$op->first->first->sibling->name eq "rv2av" &&
				$op->first->first->sibling->first->name eq "gv" &&
				get_gv_name($padlist, $op->first->first->sibling->first) eq "_" &&
				$op->last->name eq "null" &&
				$op->last->first->name eq "pushmark";
			my %v;
			$op = $op->last->first->sibling;
			my $n = 0;
			my $ok = 1;
			while (1) {
				if ($op->name eq "padsv") {
					my $name = padname($padlist, $op);
					last unless $name;
					$v{$name} = "\$_[$n]";
					$n++;
				} elsif ($op->name eq "padav") {
					last;
				} elsif ($op->name eq "padhv") {
					last;
				} else {
					$ok = 0;  last;
				}
				$op = $op->sibling;
				last if $op->isa("B::NULL");
			}
			return unless $ok;
			%vars = %v;
		});
	for my $name (keys %vars) {
		$cond =~ s/\Q$name\E(?![\[\{])/$vars{$name}/g;
	}
	$cond;
}

sub do_check {
	my ($pkg) = @_;
	my %byname;
	for my $info (@{$whens{$pkg}}) {
		my $sub = $info->{func};
		my $cv = B::svref_2object($sub);
		my $gv = $cv->GV;
		my $name = $gv->NAME;
		$names{$name} = 1;
		$names{"$pkg\::$name"} = 1;
		push @{$byname{$name}}, $info;
	}
	for my $name (keys %byname) {
		create_pat_mat($pkg, $name, $byname{$name});
	}
}

sub do_init {
	for my $r (@redefinitions) {
		unless ($names{$r->{func}}) {
			$redefine_bitch = 1;
			warn $r->{bitch};
			$redefine_bitch = 0;
		}
	}
	@redefinitions = ();
}

1;
__END__