Sub::PatMat - call a version of subroutine depending on its arguments

Sub-PatMat documentation Contained in the Sub-PatMat distribution.

Index

Code Index:

NAME

Top

Sub::PatMat - call a version of subroutine depending on its arguments

VERSION

Top

This document describes Sub::PatMat version 0.01

SYNOPSIS

Top

  use Sub::PatMat;

  # basics:
  sub fact : when($_[0] <= 1) { 1 }
  sub fact                    { my ($n) = @_; $n*fact($n-1) }
  print fact(6);

  # referring to things other than @_:
  sub mysort : when($a < $b)  { -1 }
  sub mysort : when($a == $b) {  0 }
  sub mysort : when($a > $b)  {  1 }
  print join ", ", sort mysort (3,1,2);

  # intuiting parameter names:
  sub dispatch : when($ev eq "help") { my ($ev) = @_; print "help\n" }
  sub dispatch : when($ev eq "blah") { my ($ev) = @_; print "blah\n" }
  dispatch("help");
  dispatch("blah");
  # no fallback, this will die:
  dispatch("hest");  # dies with "Bad match"

  # silly
  sub do_something : when(full_moon()) { do_one_thing() }
  sub do_something                     { do_something_else() }

DESCRIPTION

Top

The Sub::PatMat module provides the programmer with the ability to define a subroutine multiple times and to specify what version of the subroutine should be called, depending on the parameters passed to it (or any other condition).

This is somewhat similar to argument pattern matching facility provided by many programming languages.

To use argument pattern matching on a sub, the programmer has to specify the when attribute. The parameter to the attribute must be a single Perl expression.

When the sub is called, those expressions are evaluated consequitively until one of them evaluates to a true value. When this happens, the corresponding version of a sub is called.

If none of the expressions evaluates to a true value, a Bad Match exception is thrown.

It is possible to specify a fall-back version of the function by doing one of the following:

specifying when without an expression
specifying when with an empty expression
not specifying the when attribute at all

Please note that it does not make sense to specify any non-fall-back version of the sub after the fall-back version, since such will never be called.

There is an additional limitation for the last form of the fall-back version (the one without the when attribute at all), namely, it must be the last version of the sub defined.

It is possible to specify named sub parameters in the when-expression. This facility is highly experimental and is currently limited to scalar parameters only. The named sub parameters are extracted from expressions of the form

  my (parameter list) = @_;

anywhere in the body of the sub.

BUGS AND LIMITATIONS

Top

The ability to intuit parameter names is very limited and without doubts buggy.

The when attribute condition is limited to a single Perl expression.

SEE ALSO

Top

Sub::PatternMatching, which does a more comprehensive job, but its syntax makes it difficult to use.

TODO

Top

support non-scalar named parameters
add positional parameter matching a la Erlang

AUTHOR

Top

Anton Berezin <tobez@tobez.org>

ACKNOWLEDGEMENTS

Top

Thanks to Dmitry Karasik for discussion.

LICENSE AND COPYRIGHT

Top

Copyright (c) 2007, Anton Berezin <tobez@tobez.org>. All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Sub-PatMat documentation Contained in the Sub-PatMat distribution. 
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__