File Coverage

blib/lib/Class/Multimethods.pm

Criterion	Covered	Total	%
statement	216	637	33.9
branch	57	302	18.8
condition	55	195	28.2
subroutine	22	35	62.8
pod	1	17	5.8
total	351	1186	29.6

package Class::Multimethods;

use strict;
use vars qw($VERSION @ISA @EXPORT);
use Carp;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( multimethod resolve_ambiguous resolve_no_match superclass
	      multimethod_wrapper );
$VERSION = '1.70';

use vars qw(%dispatch %cached %hasgeneric
	    %ambiguous_handler %no_match_handler
	    %max_args %min_args);

%dispatch = ();	          # THE DISPATCH TABLE
%cached   = ();	          # THE CACHE OF PREVIOUS RESOLUTIONS OF EMPTY SLOTS
%hasgeneric  = ();	  # WHETHER A GIVEN MULTIMETHOD HAS ANY GENERIC VARIANTS
%ambiguous_handler = ();  # HANDLERS FOR AMBIGUOUS CALLS
%no_match_handler = ();   # HANDLERS FOR AMBIGUOUS CALLS
%max_args = ();   	  # RECORDS MAX NUM OF ARGS IN ANY VARIANT
%min_args = ();		  # RECORDS MIN NUM OF ARGS IN ANY VARIANT


# THIS IS INTERPOSED BETWEEN THE CALLING PACKAGE AND Exporter TO SUPPORT THE
# use Class:Multimethods @methodnames SYNTAX

sub import
{
	my $package = (caller)[0];
	install_dispatch($package,pop @_) while $#_;
	Class::Multimethods->export_to_level(1);
}


# INSTALL A DISPATCHING SUB FOR THE NAMED MULTIMETHOD IN THE CALLING PACKAGE

sub install_dispatch
{
	my ($pkg, $name) = @_;
	# eval "sub ${pkg}::$name { Class::Multimethods::dispatch('$name',\@_) }"
	eval(make_dispatch($pkg,$name)) || croak "internal error: $@"
		unless eval "defined \&${pkg}::$name";
}

# REGISTER RESOLUTION FUNCTIONS FOR AMBIGUOUS AND NO-MATCH CALLS

sub resolve_ambiguous
{
	my $name = shift;
	if (@_ == 1 && ref($_[0]) eq 'CODE')
		{ $ambiguous_handler{$name} = $_[0] }
	else
		{ $ambiguous_handler{$name} = join ',', @_ }
}

sub resolve_no_match
{
	my $name = shift;
	if (@_ == 1 && ref($_[0]) eq 'CODE')
		{ $no_match_handler{$name} = $_[0] }
	else
		{ $no_match_handler{$name} = join ',', @_ }
}

# GENERATE A SPECIAL PROXY OBJECT TO INDICATE THAT THE ANCESTOR OF AN OBJECT'S
# CLASS IS REQUIRED

sub superclass
{
	my ($obj, $super) = @_;
	$super = ref($obj) || ( (~$obj&$obj) eq 0 ? '#' : '$' ) if @_ <= 1;
	bless \$obj, (@_ > 1 )
		? "Class::Multimethods::SUPERCLASS_IS::$super"
		: "Class::Multimethods::SUPERCLASS_OF::$super";
}

sub _prettify
{
	   $_[0] =~ s/Class::Multimethods::SUPERCLASS_IS:://
	or $_[0] =~ s/Class::Multimethods::SUPERCLASS_OF::(.*)/superclass($1)/;
}

# SQUIRREL AWAY THE PROFFERED SUB REF INDEXED BY THE MULTIMETHOD NAME
# AND THE TYPE NAMES SUPPLIED. CAN ALSO BE USED WITH JUST THE MULTIMETHOD
# NAME IN ORDER TO INSTALL A SUITABLE DISPATCH SUB INTO THE CALLING PACKAGE

sub multimethod
{
	my $package = (caller)[0];
	my $name  = shift;
	install_dispatch($package,$name);

	if (@_)	  # NOT JUST INSTALLING A DISPATCH SUB...
	{
		my $code = pop;
		croak "multimethod: last arg must be a code reference"
			unless ref($code) eq 'CODE';

		my @types = @_;

		for ($Class::Multimethods::max_args{$name})
			{ $_ = @types if !defined || @types > $_ }
		for ($Class::Multimethods::min_args{$name})
			{ $_ = @types if !defined || @types < $_ }

		my $sig = join ',', @types;

		$Class::Multimethods::hasgeneric{$name} ||= $sig =~ /\*/;

		carp "Multimethod $name($sig) redefined"
			if $^W && exists $dispatch{$name}{$sig};
		$dispatch{$name}{$sig} = $code;

		# NOTE: ADDING A MULTIMETHOD COMPROMISES CACHING
		# THIS IS A DUMB, BUT FAST, FIX...
		$cached{$name} = {};
	}
}


# THIS IS THE ACTUAL MEAT OF THE PACKAGE -- A GENERIC DISPATCHING SUB
# WHICH EXPLORES THE %dispatch AND %cache HASHES LOOKING FOR A UNIQUE
# BEST MATCH...

sub make_dispatch # ($name)
{
	my ($pkg,$name) = @_;
	my $code = q{

	sub PACKAGE::NAME
	{
	# MAP THE ARGS TO TYPE NAMES, MAP VALUES TO '#' (FOR NUMBERS)
	# OR '$' (OTHERWISE). THEN BUILD A FUNCTION TYPE SIGNATURE
	# (LIKE A "PATH" INTO THE VARIOUS TABLES)

		my $sig = "";
		my $nexttype;
		foreach ( @_ )
		{
			$nexttype = ref || ( (~$_&$_) eq 0 ? '#' : '$' );
			# $_ = $$_ if index($nexttype,'Class::Multimethods::SUPERCLASS')==0;
			$sig .= $nexttype;
			$sig .= ",";
		}
		chop $sig;

		my $code = $Class::Multimethods::dispatch{'NAME'}{$sig}
			|| $Class::Multimethods::cached{'NAME'}{$sig};

		return $code->(@_) if ($code);

		my @types = split /,/, $sig;
		for (my $i=1; $i<@types; $i++)
		{
			$_[$i] = ${$_[$i]}
				if index($types[$i],'Class::Multimethods::SUPERCLASS')==0;
		}
		my %tried = ();	   # USED TO AVOID MULTIPLE MATCHES ON SAME SIG
		my @code;          # STORES LIST OF EQUALLY-CLOSE MATCHING SUBS
		my @candidates = ( [@types] );	# STORES POSSIBLE MATCHING SIGS

	# TRY AND RESOLVE TO AN TYPE-EXPLICIT SIGNATURE (USING INHERITANCE)

		1 until (Class::Multimethods::resolve('NAME',\@candidates,\@code,\%tried) || !@candidates);

	# IF THAT DOESN'T WORK, TRY A GENERIC SIGNATURE (IF THERE ARE ANY)
	# THE NESTED LOOPS GENERATE ALL POSSIBLE PERMUTATIONS OF GENERIC
	# SIGNATURES IN SUCH A WAY THAT, EACH TIME resolve IS CALLED, ALL
	# THE CANDIDATES ARE EQUALLY GENERIC (HAVE AN EQUAL NUMBER OF GENERIC
	# PLACEHOLDERS)

		if ( @code == 0 && $Class::Multimethods::hasgeneric{'NAME'} )
		{
			# TRY GENERIC VERSIONS
			my @gencandidates = ([@types]);
			GENERIC: for (0..$#types)
			{
				@candidates = ();
				for (my $gci=0; $gci<@gencandidates; $gci++)
				{
					for (my $i=0; $i<@types; $i++)
					{
						push @candidates,
						     [@{$gencandidates[$gci]}];
						$candidates[-1][$i] = "*";
					}
				}
				@gencandidates = @candidates;
				1 until (Class::Multimethods::resolve('NAME',\@candidates,\@code,\%tried) || !@candidates);
				last GENERIC if @code;
			}
		}

	# RESOLUTION PROCESS COMPLETED...
	# IF EXACTLY ONE BEST MATCH, CALL IT...

		if ( @code == 1 )
		{
			$Class::Multimethods::cached{'NAME'}{$sig} = $code[0];
			return $code[0]->(@_);
		}

	# TWO OR MORE EQUALLY LIKELY CANDIDATES IS AMBIGUOUS...
		elsif ( @code > 1)
		{
			my $handler = $Class::Multimethods::ambiguous_handler{'NAME'};
			if (defined $handler)
			{
				return $handler->(@_)
					if ref $handler;
				return $Class::Multimethods::dispatch{'NAME'}{$handler}->(@_)
					if defined $Class::Multimethods::dispatch{'NAME'}{$handler};
			}
			_prettify($sig);
			croak "Cannot resolve call to multimethod NAME($sig). " .
			      "The multimethods:\n" .
				join("\n",
				 map { "\tNAME(" . join(',',@$_) . ")" }
				  @candidates) .
				"\nare equally viable";
		}

	# IF *NO* CANDIDATE, NO WAY TO DISPATCH THE CALL
		else
		{
			my $handler = $Class::Multimethods::no_match_handler{'NAME'};
			if (defined $handler)
			{
				return $handler->(@_)
					if ref $handler;
				return $Class::Multimethods::dispatch{'NAME'}{$handler}->(@_)
					if defined $Class::Multimethods::dispatch{'NAME'}{$handler};
			}
			_prettify($sig);
			croak "No viable candidate for call to multimethod NAME($sig)";
		}
	}
	1;

	};
	$code =~ s/PACKAGE/$pkg/g;
	$code =~ s/NAME/$name/g;
	return $code;
}


# THIS SUB TAKES A LIST OF EQUALLY LIKELY CANDIDATES (I.E. THE SAME NUMBER OF
# INHERITANCE STEPS AWAY FROM THE ACTUAL ARG TYPES) AND BUILDS A LIST OF
# MATCHING ONES. IF THERE AREN'T ANY MATCHES, IT BUILDS A NEW LIST OF
# CANDIDATES, BY GENERATING PERMUTATIONS OF THE SET OF PARENT TYPES FOR
# EACH ARG TYPE.

sub resolve
{
	my ($name, $candidates, $matches, $tried) = @_;
	my %newcandidates = ();
	foreach my $candidate ( @$candidates )
	{
		# print "trying @$candidate...\n";

	# BUILD THE TYPE SIGNATURE AND ENSURE IT HASN'T ALREADY BEEN CHECKED

     	 	my $sig = join ',', @$candidate;
		next if $tried->{$sig};
		$tried->{$sig} = 1;

	# LOOK FOR A MATCHING SUB REF IN THE DISPATCH TABLE AND REMEMBER IT...

		my $match = $Class::Multimethods::dispatch{$name}{$sig};
		if ($match && ref($match) eq 'CODE')
		{
			push @$matches, $match;
			next;
		}

	# OTHERWISE, GENERATE A NEW SET OF CANDIDATES BY REPLACING EACH
	# ARGUMENT TYPE IN TURN BY EACH OF ITS IMMEDIATE PARENTS. EACH SUCH
	# NEW CANDIDATE MUST BE EXACTLY 1 DERIVATION MORE EXPENSIVE THAN
	# THE CURRENT GENERATION OF CANDIDATES. NOTE, THAT IF A MATCH HAS
	# BEEN FOUND AT THE CURRENT GENERATION, THERE IS NO NEED TO LOOK
	# ANY DEEPER...

		if (!@$matches)
		{
			for (my $i = 0; $i<@$candidate ; $i++)
			{
				next if $candidate->[$i] =~ /[^\w:#]/;
				no strict 'refs';
				my @parents;
				if ($candidate->[$i] eq '#')
					{ @parents = ('$') }
				elsif ($candidate->[$i] =~ /\AClass::Multimethods::SUPERCLASS_IS::(.+)/)
					{ @parents = ($1) }
				elsif ($candidate->[$i] =~ /\AClass::Multimethods::SUPERCLASS_OF::(.+)/)
					{ @parents = ($1 eq '#') ? '$' : @{$1."::ISA"} }
				else
					{ @parents = @{$candidate->[$i]."::ISA"} }
				foreach my $parent ( @parents )
				{
					my @newcandidate = @$candidate;
					$newcandidate[$i] = $parent;
					$newcandidates{join ',', @newcandidate} = [@newcandidate];
				}
			}

		}
	}

# IF NO MATCHES AT THE CURRENT LEVEL, RESET THE CANDIDATES TO THOSE AT
# THE NEXT LEVEL...

	@$candidates = values %newcandidates unless @$matches;

	return scalar @$matches;
}

# SUPPORT FOR analyse

my %children;
my %parents;

sub build_relationships
{
	no strict "refs";
	%children = ( '$' => [ '#' ] );
	%parents  = ( '#' => [ '$' ] );
	my (@packages) = @_;
	foreach my $package (@packages)
	{
		foreach my $parent ( @{$package."::ISA"} )
		{
			push @{$children{$parent}}, $package;
			push @{$parents{$package}}, $parent;
		}
	}
}


sub list_packages
{
	no strict "refs";
	my $self = $_[0]||"main::";
	my @children = ( $self );
	foreach ( keys %{$self} )
	{
		next unless /::$/ && $_ ne $self;
		push @children, list_packages("$self$_")
	}
	@children = map { s/^main::(.+)$/$1/; s/::$//; $_ } @children
		unless $_[0];
	return @children;
}

sub list_ancestors
{
	my ($class) = @_;
	my @ancestors = ();
	foreach my $parent ( @{$parents{$class}} )
	{
		push @ancestors, list_ancestors($parent), $parent;
	}
	return @ancestors;
}

sub list_descendents
{
	my ($class) = @_;
	my @descendents = ();
	foreach my $child ( @{$children{$class}} )
	{
		push @descendents, $child, list_descendents($child);
	}
	return @descendents;
}

sub list_hierarchy
{
	my ($class) = @_;
	my @hierarchy = list_ancestors($class);
	push @hierarchy, $class;
	push @hierarchy, list_descendents($class);
	return @hierarchy;
}

@Class::Multimethods::dont_analyse = qw
(
	Exporter
	DynaLoader
	AutoLoader
);

sub generate_argsets
{
	my ($multimethod) = @_;

	my %ignore;
	@ignore{@Class::Multimethods::dont_analyse} = ();


	return unless $min_args{$multimethod};

	my @paramlists = ();

	foreach my $typeset ( keys %{$Class::Multimethods::dispatch{$multimethod}} )
	{
		next if $typeset =~ /\Q*/;
		my @nexttypes = split /,/, $typeset;
		for my $i (0..$#nexttypes)
		{
			for my $ancestor ( list_hierarchy $nexttypes[$i] )
			{
				$paramlists[$i]{$ancestor} = 1
					unless exists $ignore{$ancestor};
			}
		}
	}

	my @argsets = ();

	foreach (@paramlists) { $_ = [keys %{$_}] }

	use Data::Dumper;
	# print Data::Dumper->Dump([@paramlists]);

	foreach my $argcount ($min_args{$multimethod}..$max_args{$multimethod})
	{
		push @argsets, combinations(@paramlists[0..$argcount-1]);
	}

	# print STDERR Data::Dumper->Dump([@argsets]);

	return @argsets;
}

sub combinations
{
	my (@paramlists) = @_;
	return map { [$_] } @{$paramlists[0]} if (@paramlists==1);
	my @combs = ();
	my @subcombs = combinations(@paramlists[1..$#paramlists]);
	foreach my $firstparam (@{$paramlists[0]})
	{
		foreach my $subcomb ( @subcombs )
		{
			push @combs, [$firstparam, @{$subcomb}];
		}
	}
	return @combs;
}

sub analyse
{
	my ($multimethod, @argsets) = @_;
	my ($package,$file,$line) = caller(0);
	my ($sub) = (caller(1))[3] || "main code";
	my $case_count = @argsets;
	my $ambiguous_handler = $ambiguous_handler{$multimethod};
	my $no_match_handler = $no_match_handler{$multimethod};
	$ambiguous_handler = "$multimethod($ambiguous_handler)"
		if $ambiguous_handler && ref($ambiguous_handler) ne "CODE";
	$no_match_handler = "$multimethod($no_match_handler)"
		if $no_match_handler && ref($no_match_handler) ne "CODE";
	build_relationships list_packages;
	if ($case_count)
	{
		my @newargsets;
		foreach my $argset ( @argsets )
		{
			my @argset = map { ref eq 'ARRAY' ? $_ : [$_] } @$argset;
			push @newargsets, combinations(@argset);
		}
		@argsets = @newargsets;
		$case_count = @argsets;
	}
	else
	{
		@argsets = generate_argsets($multimethod);
		$case_count = @argsets;
		unless ($case_count)
		{
			print STDERR "[No variants found for $multimethod. No analysis possible.]\n\n";
	print STDERR "="x72, "\n\n";
			return;

		}
		print STDERR "[Generated $case_count test cases for $multimethod]\n\n"
	}

	print STDERR "Analysing calls to $multimethod from $sub ($file, line $line):\n";
	my $case = 1;

	my $successes = 0;
	my @fails = ();
	my @ambigs = ();

	foreach my $argset ( @argsets )
	{
		my $callsig = "${multimethod}(".join(",",@$argset).")";
		print STDERR "\n\t[$case/$case_count] For call to $callsig:\n\n";
		$case++;
		my @ordered = sort {
			     $a->{wrong_length} - $b->{wrong_length}
					       ||
				@{$a->{incomp}} - @{$b->{incomp}}
					       ||
				  $a->{generic} - $b->{generic}
					       ||
				$a->{sum_dist} <=> $b->{sum_dist}
					       }
				evaluate($multimethod, $argset);


		if ($ordered[0] && !@{$ordered[0]->{incomp}})
		{
			my $i;
			for ($i=1; $i<@ordered; $i++)
			{
				last if @{$ordered[$i]->{incomp}} ||
					$ordered[$i]->{wrong_length} ||
				        $ordered[$i]->{sum_dist} >
				        	$ordered[0]->{sum_dist} ||
				        $ordered[$i]->{generic} !=
				        	$ordered[0]->{generic};
			}
			$ordered[$_]->{less_viable} = 1 for ($i..$#ordered);
			if ($i>1)
			{
				$ordered[$i]->{ambig} = 1 while ($i-->0)
			}
		}

		my $first = 1;
		my $min_dist = 0;
		push @fails, "\t\t$callsig\n";  # ASSUME THE WORST

		# CHECK FOR REOLUTION IF DISPATCH FAILS

		my $winner = $ordered[0];
		if ($winner && $winner->{ambig} && $ambiguous_handler)
		{
			print STDERR "\t\t(+) $ambiguous_handler\n\t\t\t>>> Ambiguous dispatch handler invoked.\n\n";
			$first = 0;
			$successes++;
			pop @fails;
		}
		elsif ($winner
			    && (@{$winner->{incomp}} || $winner->{wrong_length})
			    && $no_match_handler )
		{
			print STDERR "\t\t(+) $no_match_handler\n\t\t\t>>> Dispatch failure handler invoked.\n\n";
			$first = 0;
			$successes++;
			pop @fails;
		}
		foreach my $variant (@ordered)
		{
			if ($variant->{ambig})
			{
				print STDERR "\t\t(?) $variant->{sig}\n\t\t\t>>> Ambiguous. Distance: $variant->{sum_dist}\n";
				push @ambigs, pop @fails if $first;
			}
			elsif (@{$variant->{incomp}} == 1)
			{
				print STDERR "\t\t(-) $variant->{sig}\n\t\t\t>>> Not viable. Incompatible argument: ", @{$variant->{incomp}}, "\n";
			}
			elsif (@{$variant->{incomp}})
			{
				print STDERR "\t\t(-) $variant->{sig}\n\t\t\t>>> Not viable. Incompatible arguments: ", join(",",@{$variant->{incomp}}), "\n";
			}
			elsif ($variant->{wrong_length})
			{
				print STDERR "\t\t(-) $variant->{sig}\n\t\t\t>>> Not viable. Wrong number of arguments\n";
			}
			elsif ($first)
			{
				print STDERR "\t\t(+) $variant->{sig}\n\t\t\t>>> Target. Distance: $variant->{sum_dist}\n\n";
				$min_dist = $variant->{sum_dist};
				$successes++;
				pop @fails;
			}
			elsif ($variant->{generic} && $variant->{sum_dist} < $min_dist)
			{
				print STDERR "\t\t(*) $variant->{sig}\n\t\t\t>>> Viable, but generic. Distance: $variant->{sum_dist} (generic)\n";
			}
			elsif ($variant->{generic})
			{
				print STDERR "\t\t(*) $variant->{sig}\n\t\t\t>>> Viable. Distance: $variant->{sum_dist} (generic)\n";
			}
			else
			{
				print STDERR "\t\t(x) $variant->{sig}\n\t\t\t>>> Viable. Distance: $variant->{sum_dist}\n";
			}
			$first = 0;
		}
		print STDERR "\n";
	}
	print STDERR "\n", "-"x72, "\nSummary for calls to $multimethod from $sub ($file, line $line):\n\n";

	printf STDERR "\tSuccessful dispatch in %2.0f%% of calls\n",
			$successes/$case_count*100;
	printf STDERR "\tDispatch ambiguous for %2.0f%% of calls\n",
			@ambigs/$case_count*100;
	printf STDERR "\tWas unable to dispatch %2.0f%% of calls\n",
			@fails/$case_count*100;

	print STDERR "\nAmbiguous calls:\n", @ambigs if @ambigs;
	print STDERR "\nUndispatchable:\n", @fails if @fails;

	print STDERR "\n", "="x72, "\n\n";

}

my %distance;
sub distance
{
	my ($from, $to) = @_;

	return 0 if $from eq $to;
	return -1 if $to eq '*';
	return $distance{$from}{$to} if defined $distance{$from}{$to};

	if ($parents{$from})
	{
		foreach my $parent ( @{$parents{$from}} )
		{
			my $distance = distance($parent,$to);
			if (defined $distance)
			{
				$distance{$from}{$to} = $distance+1;
				return $distance+1;
			}
		}
	}
	return undef;
}

sub evaluate
{
	my ($name, $types) = @_;
	my @results = ();
	my $sig = join ',', @$types;

	SET: foreach my $typeset ( keys %{$Class::Multimethods::dispatch{$name}} )
	{

		push @results, { sig      	=> "$name($typeset)",
				 incomp   	=> [],
				 sum_dist	=> 0,
				 wrong_length	=> 0,
				 generic	=> 0,
			       };
		my @nexttypes = split /,/, $typeset;
		if (@nexttypes != @$types)
		{
			$results[-1]->{wrong_length} = 1;
			next SET;
		}

		my @dist;
		PARAM: for (my $i=0; $i<@$types; $i++)
		{
			my $nextdist = distance($types->[$i], $nexttypes[$i]);
			push @{$results[-1]->{dist}}, $nextdist;
			if (!defined $nextdist)
			{
				push @{$results[-1]->{incomp}}, $i;
			}
			elsif ($nextdist < 0)
			{
				$results[-1]->{generic} = 1;
			}
			else
			{
				$results[-1]->{sum_dist} += $nextdist
			}
		}
	}
	return @results;
}


1;
__END__