Class-Multimethods-1.700/ 000755 000765 000024 00000000000 13015677726 015654 5 ustar 00damian staff 000000 000000 Class-Multimethods-1.700/Changes 000755 000765 000024 00000003464 13015677725 017160 0 ustar 00damian staff 000000 000000 Revision history for Perl extension Class::Multimethods.
0.01 Tue Oct 27 13:33:29 1998
- original version; created by h2xs 1.18
1.00 Wed Feb 17 09:28:29 1999
- Now supports '#', '$', and '*' pseudo-types in parameter lists
1.10 Fri Feb 19 11:55:37 1999
- Fixed a nasty bug in the import method (thanks Larry)
- Added constraints to indicate that the module
doesn't run on Perls earlier than 5.005
- Added &resolve_ambiguous to allow handlers to be
registered for multimethod calls which could be
equally well be disptched to two or more variants
- Added &resolve_no_match to allow handlers to be
registered for multimethod calls which cannot be
dispatched to any variant.
- Documented the syntactic vinegar needed to run under
'use strict'
1.12 Tue Jul 6 17:09:04 1999
- Removed subroutine call in generated multimethod dispatcher,
made dispatch table a package var, and optimized most common cases.
Produced a 38% improvement in raw dispatch speed (around 22%
faster dispatch in real applications).
- Added &analyse subroutine to assist debugging
- Moved test.pl to t/multimethods.t
(thanks Lupe)
- Added superclass method (thanks Gareth)
1.69 Sun Sep 12 07:29:06 1999
- Fixed absolute path snafu in MANIFEST (thanks Gareth and Michael)
- moved demos to demo subdirectory
1.70 Sun Apr 9 12:43:55 2000
- moved .pod file to installable directory (/lib)
- Added TPC3 paper as tutorial.html (thanks Tom)
1.071 Fri Nov 25 10:54:12 2016
- Added handler registration code to clean up installation
(thanks Robert)
- Changed demo shebang lines for Debian compatibility
(thanks Florian and Jay)
1.701 Fri Nov 25 11:03:33 2016
- Fixed release number
Class-Multimethods-1.700/demo/ 000755 000765 000024 00000000000 13015677726 016600 5 ustar 00damian staff 000000 000000 Class-Multimethods-1.700/lib/ 000755 000765 000024 00000000000 13015677726 016422 5 ustar 00damian staff 000000 000000 Class-Multimethods-1.700/Makefile.PL 000755 000765 000024 00000000162 13015677312 017617 0 ustar 00damian staff 000000 000000
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Class::Multimethods',
VERSION => '1.700',
);
Class-Multimethods-1.700/MANIFEST 000755 000765 000024 00000001022 13015677726 017003 0 ustar 00damian staff 000000 000000 README
Changes
MANIFEST
Makefile.PL
lib/Class/Multimethods.pm
t/multimethods.t
tutorial.html
demo/demo.ambig.pl
demo/demo.analyse.pl
demo/demo.baseline.pl
demo/demo.dump.pl
demo/demo.extendtable.pl
demo/demo.global.pl
demo/demo.inittable.pl
demo/demo.multi.pl
demo/demo.newmulti.pl
demo/demo.nonmulti.pl
demo/demo.numstr.pl
demo/demo.super.pl
demo/demo.table.pl
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
Class-Multimethods-1.700/META.json 000644 000765 000024 00000001435 13015677726 017300 0 ustar 00damian staff 000000 000000 {
"abstract" : "unknown",
"author" : [
"unknown"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "Class-Multimethods",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {}
}
},
"release_status" : "stable",
"version" : "1.700"
}
Class-Multimethods-1.700/META.yml 000644 000765 000024 00000000673 13015677726 017133 0 ustar 00damian staff 000000 000000 ---
abstract: unknown
author:
- unknown
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Class-Multimethods
no_index:
directory:
- t
- inc
requires: {}
version: '1.700'
Class-Multimethods-1.700/README 000755 000765 000024 00000006342 13015677725 016543 0 ustar 00damian staff 000000 000000 Class::Multimethods version 1.701
Class::Multimethods - Support multimethods and subroutine overloading in Perl
SYNOPSIS
# ONLY WORKS UNDER 5.005 OR LATER (NEEDS qr//)
use 5.005;
# IMPORT THE multimethod DECLARATION SUB...
use Class::Multimethods;
# DECLARE VARIOUS MULTIMETHODS CALLED find...
# 1. DO THIS IF find IS CALLED WITH A Container REF AND A Query REF...
multimethod find => (Container, Query)
=> sub { $_[0]->findquery($_[1]) };
# 2. DO THIS IF find IS CALLED WITH A Container REF AND A Sample REF...
multimethod find => (Container, Sample)
=> sub { $_[0]->findlike($_[1]) };
# 3. DO THIS IF find IS CALLED WITH AN Index REF AND A Word REF...
multimethod find => (Index, Word)
=> sub { $_[0]->lookup_word($_[1]) };
# 4. DO THIS IF find IS CALLED WITH AN Index REF AND A qr// PATTERN
multimethod find => (Index, Regexp)
=> sub { $_[0]->lookup_rx($_[1]) };
# 5. DO THIS IF find IS CALLED WITH AN Index REF AND A NUMERIC SCALAR
multimethod find => (Index, '#')
=> sub { $_[0]->lookup_elem($_[1]) };
# 6. DO THIS IF find IS CALLED WITH AN Index REF AND
# A NON-NUMERIC SCALAR
multimethod find => (Index, '$')
=> sub { $_[0]->lookup_str($_[1]) };
# 7. DO THIS IF find IS CALLED WITH AN Index REF AND AN UNBLESSED
# ARRAY REF (NOTE THE RECURSIVE CALL TO THE find MULTIMETHOD)
multimethod find => (Index, ARRAY)
=> sub { map { find($_[0],$_) } @{$_[1]} };
# SET UP SOME OBJECTS...
my $cntr = new Container ('./datafile');
my $indx = $cntr->get_index();
# ...AND SOME INHERITANCE...
@BadWord::ISA = qw( Word );
my $badword = new BadWord("fubar");
# ...AND EXERCISE THEM...
print find($cntr, new Query('cpan OR Perl')); # CALLS 1.
print find($cntr, new Example('by a committee')); # CALLS 2.
print find($indx, new Word('sugar')); # CALLS 3.
print find($indx, $badword); # CALLS 3.
print find($indx, qr/another brick in the Wall/); # CALLS 4.
print find($indx, 7); # CALLS 5.
print find($indx, 'But don't do that.'); # CALLS 6.
print find($indx, [1,"one"]); # CALLS 7,
# THEN 5,
# THEN 6.
INSTALLATION
It's all pure Perl, so just put the .pm file in its appropriate
local Perl subdirectory.
AUTHOR
Damian Conway (damian@cs.monash.edu.au)
COPYRIGHT
Copyright (c) 1999-2000, Damian Conway. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.
Class-Multimethods-1.700/t/ 000755 000765 000024 00000000000 13015677726 016117 5 ustar 00damian staff 000000 000000 Class-Multimethods-1.700/tutorial.html 000755 000765 000024 00000115252 07073766531 020416 0 ustar 00damian staff 000000 000000
Multiple Dispatch and Subroutine Overloading in Perl
Multiple Dispatch and Subroutine Overloading in Perl
Damian Conway
School of Computer Science and Software Engineering
Monash University
Clayton 3168, Australia
Abstract
Sometimes Perl's standard polymorphic
method dispatch mechanism isn't sophisticated enough to cope with the complexities
of finding the right method to handle a given situation. For example, in
a graphical user interface, objects representing events may be passed to
objects representing windows. What happen next depends on the type of window,
but also on the type of event. It's not enough to invoke a receive_event
method on the window object, since that won't distinguish between the various
possible kinds of event. Nor is it sufficient to invoke a send_to_window
method on the event object, since that won't distinguish between the various
possible kinds of window. What's needed is the ability to polymorphically
select a suitable method for the appropriate combination of window and
event types. This paper describes a new CPAN module--Class::Multimethods--that
provides such a mechanism.
What is multiple dispatch?
In object-oriented Perl, the selection
of which subroutine to call in response to a method invocation (e.g. $objref->method(@args))
is performed polymorphically. That means the subroutine that's invoked
is the one defined in the class that the invoking object belongs to. So
a call such as $objref->method(@args)
invokes the method CLASSNAME::method,
where "CLASSNAME"
is the class name returned by ref($objref).
If the class in question doesn't have
a suitable method, then the dispatch procedure searches upwards through
the various ancestors of the original class, looking for an appropriate
subroutine. If that search fails, the dispatch procedure attempts to invoke
an AUTOLOAD subroutine
somewhere in the invoking object's inheritance hierarchy.
The important point is that, whichever
subroutine the method dispatcher eventually selects, it was all determined
by the class of the original invoking object (i.e. according to the class
of the first argument).
For most applications, the ability
to select behaviour based on the type of a single argument is sufficient.
However, some applications, such as the GUI event handler mentioned above,
need to select the most applicable polymorphic method on the basis of more
than one argument. This behaviour is known as multiple dispatch.
Generally speaking, multiple dispatch
is needed whenever two or more objects belonging to different class hierarchies
are going to interact, and we need to do different things depending on
the combination of actual types of those objects. Typical applications
that need this kind of ability include graphical user interfaces, image
processing libraries, mixed-precision numerical computation systems, and
most types of simulations.
It's possible to build "hand-crafted"
multiply dispatched methods that look at the types of each of their arguments
and react accordingly. For example, a normal (singly-dispatched)
method could use ref
or isa to determine
the types of its other arguments and then select the correct behaviour
in a cascaded if
statement. Alternatively, it's possible to use hashes of hashes to set
up a multidimensional table of subroutine references, then use the class
names of the arguments (again found with ref)
to index into it. Both these approaches are described in detail in [1,2].
The problem is that such hand-crafted
mechanisms are complicated to construct and even harder to debug. And because
every hand-built method is structurally similar, they're also tedious to
code and maintain. Life would be very much easier if it were possible to
define a set of identically named methods with distinct parameter lists,
and then the program would "automagically" find the right one. Such a set
of multiply dispatched methods is known as a multimethod, and each
alternative method in the set is known as a variant.
But Perl has no mechanism for specifying
parameter types, or for overloading subroutine names. And certainly there's
no mechanism for automatically selecting between several (hypothetical)
overloaded subroutines on the basis of the inheritance relationships of
those (unspecifiable) parameter types.
Until now.
The Class::Multimethods module
The Class:Multimethod module[3]
exports a subroutine (named multimethod)
that can be used to declare other subroutines that are to be multiply dispatched.
The new dispatch mechanism looks at
the classes or types of each argument to the multimethod (by calling ref
on each) and determines the "closest" matching variant of the multimethod,
according to the parameter types specified in the variants' definitions
(see below for a definition of "closest").
The result is something akin to C++'s
function overloading but more sophisticated, since multimethods take the
inheritance relationships of each argument into account. Another way of
thinking of the mechanism is that it performs polymorphic dispatch on every
argument of a method, not just on the first.
Defining multimethods
Class::Multimethods::multimethod
can be used to specify multimethod variants with the dispatch behaviour
described above. It takes the name of the desired multimethod, a list of
class names, and a subroutine reference, and uses this information to generate
a corresponding multimethod variant within the current package.
For example:
package LargeInt; @ISA = (LargeNum);
package LargeFloat; @ISA = (LargeNum);
package LargeNum;
use Class::Multimethods;
multimethod
divide => (LargeInt, LargeInt) =>
sub {
LargeInt::divide($_[0],$_[1])
};
multimethod
divide => (LargeInt, LargeFloat),
sub {
LargeFloat::divide($_[0]->AsLargeFloat(), $_[1]);
};
This creates a (single) multimethod called
LargeNum::divide
with two variants. If the multimethod is called with two references to
LargeInt objects
as arguments, the first variant is invoked. If the multimethod is called
with a LargeInt reference
and a LargeFloat
reference, the second variant is called.
Calling the multimethod with any other
combination of LargeNum
reference arguments (e.g. a reference to a LargeFloat
and a reference to a LargeInt,
or two LargeFloat
references) results in an exception being thrown, with the message:
No viable candidate for call to multimethod LargeNum::divide
To avoid this, a "catch-all" variant could
be specified:
multimethod
divide => (LargeNum, LargeNum) =>
sub {
LargeFloat::divide($_[0]->AsLargeFloat(), $_[1]->AsLargeFloat());
};
Now, calling LargeNum::divide
with (for example) a LargeFloat
reference and a LargeInt
reference causes this third variant to be invoked. That's because a LargeFloat
is-a LargeNum
(so the first argument is compatible with the first parameter), and a LargeInt
is-a LargeNum
too (so the second argument is compatible with the second parameter). Note
that adding this third variant doesn't affect calls to the other two, since
Class::Multimethods always selects the nearest match (see the next section
for details of what nearest means).
This general "best fit" behaviour is
extremely useful, because it means you can code the specific cases you
want to handle (e.g. (LargeInt, LargeFloat)),
and then provide one or more "catch-all" cases (e.g. (LargeNum,
LargeNum)) to deal with any other combination
of arguments. The multimethod automatically picks the most suitable variant
to handle each actual argument list.
Finding the "nearest" multimethod
Of course, the usefulness of the entire
system depends on how intelligently Class::Multimethods decides which version
of a multimethod is "nearest" to a given set of arguments. That decision
process is called dispatch resolution, and Class::Multimethods does
it like this:
-
If the types of the arguments given (as
determined by applying ref
to each in turn) exactly match the set of parameter types specified in
any variant of the multimethod, that variant is immediately called.
-
Otherwise, Class::Multimethods compiles
a list of viable targets. A viable target is a variant of the multimethod
with the same number of parameters as there were arguments passed. In addition,
for each parameter the specified parameter type must be a base class of
the actual type of the corresponding argument in the actual call (i.e.
each argument must belong to a subclass of the corresponding parameter
type).
-
If there is only one viable target, it
is called immediately. If there are no viable targets, an exception is
thrown indicating that the multimethod can't handle the specific set of
arguments.
-
Otherwise, Class::Multimethod examines
each viable target and computes its inheritance distance from the
actual set of arguments. The inheritance distance from a single argument
to the corresponding parameter is the number of inheritance steps between
their respective classes (working up the tree from argument to parameter).
If there's no inheritance path between them, the distance is infinite.
The inheritance distance for a set of arguments is just the sum of their
individual inheritance distances.
-
Class::Multimethod then chooses the viable
target with the smallest inheritance distance as the actual target. If
more than one viable target has the same smallest distance, the call is
ambiguous. In that case, the dispatch process fails and an exception is
thrown. If there's only a single actual target, Class::Multimethod records
its identity in a special cache, so the distance computations don't have
to be repeated next time the same set of argument types is used . The actual
target is then called and the dispatch process is complete.
Declaring multimethods
Class::Multimethods doesn't care which
packages the individual variants of a multimethod are defined in. Every
variant of a multimethod is visible to the underlying multimethod dispatcher,
no matter where it was defined. In other words, all multimethod variants
share a common namespace that is independent of their individual package
namespaces.
For example, the three variants for
the divide multimethod
shown above could all be defined in the LargeNum
package, or the LargeFloat
package or the LargeInt
package, or in the main package, or anywhere else. They don't even have
to be declared in the same package.
Of course, to enable a specific multimethod
to be called within a given package, the package must know about
it. That can be achieved by specifying just the name of the multimethod
(i.e. with no argument list or variant code), much like a standard Perl
subroutine declaration:
package Some::Other::Package;
use Class::Multimethods;
# import "divide" multimethod
multimethod "divide";
For convenience, the two steps can be
consolidated, and the declaration abbreviated to:
package Some::Other::Package;
use Class::Multimethods "divide";
Subroutine overloading
Class::Multimethod also doesn't care whether
multimethods are called as methods or as regular subroutines. This is quite
different from the behaviour of normal Perl methods and subroutines, where
how you call them determines how they're dispatched.
With multimethods, since all arguments
participate in the polymorphic resolution of a call (instead of just the
first), it make no difference whether a multimethod is called as a method:
$num3 = $num1->divide($num2);
or a subroutine:
$num3 = divide($num1, $num2);
That means that Class::Multimethods also
provides general subroutine overloading. For example:
package main;
use IO;
use Class::Multimethods;
multimethod
test => (IO::File, DataSource) =>
sub {
$_[0]->print( $_[1]->data() )
};
multimethod
test => (IO::Pipe, Queue) =>
sub {
$_[0]->print( $_[1]->next() )
while $_[1]->count();
};
multimethod
test => (IO::Socket, Stack) =>
sub {
$_[0]->print( $_[1]->pop() )
};
# and later...
test($some_handle, $some_data_ref);
Non-class types as parameters
Yet another thing Class::Multimethods
doesn't care about is whether the parameter types for each multimethod
variant are the names of "real" classes, or just the identifiers returned
when raw Perl data types are passed to the built-in ref
function. That means multimethod variants can also be defined like this:
multimethod stringify => (ARRAY) =>
sub {
my @arg = @{$_[0]};
return "[" . join(", ",@arg) . "]";
};
multimethod stringify => (HASH) =>
sub {
my %arg = %{$_[0]};
return "{" . join(", ", map( "$_=>$arg{$_}", keys %arg) ) . "}";
};
multimethod stringify => (CODE) =>
sub { return "sub {???}" };
# and later...
print stringify([1,2,3]);
print stringify({a=>1,b=>2,c=>3});
print stringify($array_or_hash_ref);
In other words, the names of built-in
types (i.e. those returned by ref)
are perfectly acceptable as multimethod parameters. That's a nice bonus,
but there's a problem. Because ref
returns undef when
given any literal string or numeric value, the following code:
$str = "a multiple dispatch oddity";
print stringify( 2001 );
print stringify( $str );
will produce a nasty surprise:
No viable candidate for call to multimethod stringify() at line 1
That's because the dispatch resolution
process first calls ref(2001)
to get the class name for the first argument, and therefore thinks it's
of class undef. Since
there's no stringify
variant with undef
as its parameter type, there are no viable targets for the multimethod
call. Hence the exception.
To overcome this limitation, Class::Multimethods
allows three special pseudo-type names within the parameter lists of multimethod
variants. The first pseudo-type--'$'--is
the class Class::Multimethods pretends any scalar value (except a reference)
belongs to. Hence, the following definition makes the two recalcitrant
stringifications of scalars work correctly:
multimethod stringify => ('$') =>
sub { return qq("$_[0]") };
With that definition in place, the two
calls:
print stringify( 2001 );
print stringify( $str );
would produce:
"2001"
"a multiple dispatch oddity"
That solves the problem, but not as elegantly
as it might. It would be better if numeric values were left unquoted. To
this end, Class::Multimethods offers a second pseudo-type--"#"--which
is the class it pretends numeric scalar values belong to. Hence, the following
additional variant removes the quotes from stringified numbers:
multimethod stringify => ('#') =>
sub { return $_[0] };
The final pseudo-type--"*"--is
a wild-card or "don't care" type specifier, which matches any argument
type exactly. For example, we could provide a "catch-all" stringify variant
(to handle "GLOB"
or "IO" references,
for example):
multimethod stringify => ('*') =>
sub {
croak "can't stringify a " . ref($_[0]);
}
Note that, even though the "*"
variant matches any possible argument type, it does so with a greater inheritance
distance than any other possible match. In other words, a "*"
variant is a last resort, used only if every other variant is unviable.
Recursive multiple dispatch
As defined above, the stringify
multimethod still fails rather badly on nested data structures. For example:
print stringify(
{ a => [1,2,3],
b => {b1=>4,b2=>5},
c => sub{3}
}
);
will print out something like:
{a=>ARRAY(0x1001c23e), b=>HASH(0x10023ae6), c=>CODE(0x10027698)}
because when the hash reference is passed
to the HASH variant
of stringify, each
of its keys and values is interpolated directly into the returned string,
rather than being individually stringified.
Fortunately a small tweak to the ARRAY
and HASH variants
solves the problem:
multimethod stringify => (ARRAY) =>
sub {
my @arg = map { stringify($_) } @{$_[0]};
return "[" . join(", ",@arg) . "]";
};
multimethod stringify => (HASH) =>
sub {
my %arg = map { stringify($_) } %{$_[0]};
return "{" . join(", ", map("$_=>$arg{$_}", keys %arg)) . "}";
};
The difference here is that each element
in the array or hash is recursively stringified (within the map
operation) before the container itself is processed. And because stringify
is a multimethod, there's no need for any special logic inside the map
block to distinguish the various possible nested data types. Instead, the
recursive calls automatically select the appropriate variant for each element,
so nested references and values are correctly processed. So now the call:
print stringify(
{ a => [1,2,3],
b => {b1=>4,b2=>5},
c => sub{3}
}
);
prints:
{"a"=>[1, 2, 3], "b"=>{"b1"=>4, "b2"=>5}, "c"=>sub{???}}
Resolving ambiguities and non-dispatchable calls
It's relatively easy to set up a multimethod
such that particular combinations of argument types cannot be correctly
dispatched. For example, consider the following variants of a multimethod
called put_peg:
class RoundPeg; @ISA = ( 'Peg' );
class SquareHole; @ISA = ( 'Hole' );
multimethod
put_peg => (RoundPeg,Hole) =>
sub {
print "round peg in hole\n"
};
multimethod
put_peg => (Peg,SquareHole) =>
sub {
print "peg in square hole\n"
};
multimethod
put_peg => (Peg,Hole) =>
sub {
print "a peg in a hole\n"
};
If put_peg
is called like this:
my $peg = RoundPeg->new();
my $hole = SquareHole->new();
put_peg($peg, $hole);
then Class::Multimethods can't dispatch
the call, because it cannot decide between the variants
(RoundPeg,Hole) and (Peg,SquareHole),
each of which is the same inheritance distance (i.e. 1 derivation) from
the actual arguments.
The default behaviour is to throw an
exception like this:
Cannot resolve call to multimethod put_peg(RoundPeg,SquareHole).
The multimethods:
put_peg(RoundPeg,Hole)
put_peg(Peg,SquareHole)
are equally viable
Sometimes, however, the more specialized
variants are only optimizations, and a more general variant (in this case,
the (Peg,Hole) variant)
would suffice as a default where such an ambiguity exists. In such situations,
it's possible to tell Class::Multimethods to resolve the ambiguity by calling
that general variant.
The resolve_ambiguous
subroutine is automatically exported by Class::Multimethods and is used
like this:
resolve_ambiguous
put_peg => (Peg,Hole);
That is, it takes the name of the multimethod
being "disambiguated", and the parameter list of the variant that is to
be the default for ambiguous cases. Of course, the specified variant must
actually exist at the time of the call. If it doesn't, Class::Multimethod
ignores it and throws the usual exception.
Alternatively, if no variant is suitable
as a default, some other (non-multimethod) subroutine can be registered
instead:
resolve_ambiguous
put_peg => \&disambiguator;
Now, whenever put_peg
can't dispatch a call because it's ambiguous, disambiguator
will be called instead, with the same argument list as put_peg
was given.
Of course, resolve_ambiguous
doesn't care what kind of subroutine it's given a reference to, so you
can also use an anonymous subroutine:
resolve_ambiguous
put_peg => sub {
print "can't put a ", ref($_[0]), " into a ", ref($_[1]), "\n";
};
Dispatch can also fail if there are no
suitable variants available to handle a particular call. For example:
my $peg = JPEG->new();
my $hole = Loophole->new();
put_peg($peg, $hole);
which would normally produce the exception:
No viable candidate for call to multimethod put_peg(JPEG,Loophole)
since classes JPEG
and Loophole aren't
in the Peg and Hole
hierarchies, so there's no inheritance path back to a more general variant.
The resolve_no_match
subroutine, which is also exported from Class::Multimethods, can be used
to set up a handler for such cases. For example:
resolve_no_match
put_peg => sub {
my ($p, $h) = map {ref} @_;
$_[0]->display($_[1])
if $p =~ /[JM]PEG/;
call_plumber()
if $p eq 'ClothesPeg' && $h eq 'DrainHole';
# etc.
};
As with resolve_ambiguous,
the variant or subroutine registered with resolve_no_match
is called with the same set of arguments that were passed to the original
multimethod call.
Debugging a multimethod
Class::Multimethods provides a (non-exported)
subroutine called analyse,
which takes the name of a multimethod and generates a report (to STDERR)
listing the behaviour of that multimethod under all feasible combinations
of its various potential arguments. For example, given the definitions
of the test multimethod
shown earlier, a call to:
Class::Multimethods::analyse("test");
will print out an analysis of the dispatch
behaviour for all possible combinations of an IO::File,
IO::Pipe, or IO::Socket
object (as the first argument), and a DataSource,
Queue, or Stack
object (as the second argument). Furthermore analyse
will examine the class hierarchies of which these classes are a part, and
generate test cases for any ancestral or descendant classes as well. For
instance, for the first argument it will also test objects of the classes
IO::Handle, and IO::Seekable,
(since these are both ancestral classes of IO::File),
and for the second argument it might also test objects of the classes PriorityQueue
and FixedLengthQueue,
if these where derived from the Queue
class.
The analyse
method iterates through every possible combination of argument types and
reports which variant (if any) would have been called for that set of arguments.
Combinations that result in ambiguities or failure to dispatch are reported
separately. Even more usefully, for argument sets where a single variant
would be successfully dispatched, analyse
also reports any other viable candidates (i.e. other variants that could
handle the call, but which were at a greater inheritance distance from
the argument list, and so not selected). This can be especially useful
in determining why a particular variant was not called as expected.
Conclusion
Multiple dispatch is a specialized technique
that handles a small but important class of problems where two or more
objects drawn from different hierarchies must interact polymorphically.
Although Perl doesn't provide an built-in multiple dispatch mechanism,
one can be added to it.
The Class::Multimethods module enables
variants of a multimethod to be declared and used, either as object methods
or as independent, overloaded subroutines. It provides a sophisticated
breadth-first dispatch resolution mechanism and allows the implementor
to dictate resolution strategies when dispatch would normally fail.
The module is available from the CPAN.
References
-
Conway, D., Object
Oriented Perl, Chapter 13, Manning Publications, 1999.
-
Conway, D., Multiple Dispatch in Perl,
The Perl Journal (to appear).
-
http://www.perl.com/CPAN/authors/id/DCONWAY/
Class-Multimethods-1.700/t/multimethods.t 000755 000765 000024 00000023530 06704323173 021017 0 ustar 00damian staff 000000 000000 use 5.005;
use strict;
# SAMPLE HIERARCHY TO TEST...
package Base1;
sub new { bless {}, ref($_[0])||$_[0] }
package Base2;
sub new { bless {}, ref($_[0])||$_[0] }
package Der1; @Der1::ISA = qw( Base1 );
package Der2; @Der2::ISA = qw( Base1 );
package Der3; @Der3::ISA = qw( Base2 );
package DerDer1; @DerDer1::ISA = qw( Der1 );
package DerDer2; @DerDer2::ISA = qw( Der2 );
package DerDer3; @DerDer3::ISA = qw( Der3 );
package DerDer4; @DerDer4::ISA = qw( Der3 );
# LOAD AND SHOOT...
package main;
BEGIN { $| = 1; print "1..350\n"; }
END {print "not ok 1\n" unless $::loaded;}
use Class::Multimethods;
$::loaded = 1;
print "ok 1\n";
# DEFINE SOME MULTIMETHODS ON THE ABOVE HIERARCHY...
multimethod mm => ('Base1', 'Base2') => sub { 1 };
multimethod mm => ('Base1', 'Der3') => sub { 2 };
multimethod mm => ('Base1', 'DerDer3') => sub { 3 };
multimethod mm => ('Der1', 'Base2') => sub { 4 };
multimethod mm => ('Base1', 'Base2', 'Base2') => sub { 11 };
multimethod mm => ('Base1', 'Der3', 'Der3') => sub { 12 };
# RESET EXPECTATIONS FOR EVERY POSSIBLE COMBINATION...
my @type1 = qw{Base1 Der1 Der2 DerDer1 DerDer2};
my @type2 = qw{Base2 Der3 DerDer3 DerDer4};
foreach my $type1 ( @type1, @type2 )
{
foreach my $type2 ( @type2, @type1 )
{
$::expect{$type1}{$type2} = 0;
}
}
# GIVEN THE ABOVE MULTIMETHODS, ONLY THESE TYPE COMBINATIONS SHOULD BE VIABLE...
$::expect{Base1}{Base2} = 1;
$::expect{Base1}{Der3} = 2;
$::expect{Base1}{DerDer3} = 3;
$::expect{Base1}{DerDer4} = 2;
$::expect{Der1}{Base2} = 4;
$::expect{Der1}{DerDer3} = 3;
$::expect{Der2}{Base2} = 1;
$::expect{Der2}{Der3} = 2;
$::expect{Der2}{DerDer3} = 3;
$::expect{Der2}{DerDer4} = 2;
$::expect{DerDer1}{Base2} = 4;
$::expect{DerDer1}{DerDer3} = 3;
$::expect{DerDer2}{Base2} = 1;
$::expect{DerDer2}{Der3} = 2;
$::expect{DerDer2}{DerDer3} = 3;
$::expect{DerDer2}{DerDer4} = 2;
# LOOP AND TEST EVERY COMBINATION (3 TIMES)...
$::n = 1;
for my $rep (1..3)
{
foreach my $type1 ( @type1, @type2 )
{
foreach my $type2 ( @type2, @type1 )
{
$::n++;
try($type1,$type2, $::expect{$type1}{$type2})
or print "not ";
print "ok $::n\n"
}
}
# ON THE LAST TIME THROUGH, ADD A NEW CASE THAT CHANGES SOME EXPECTATIONS...
if ($rep == 2)
{
multimethod mm => ('Der2', 'DerDer4') => sub { 5 };
$::expect{Der2}{DerDer4} = 5;
$::expect{DerDer2}{DerDer4} = 5;
# mm(new DerDer2, new DerDer4);
}
}
# TEST MULTIMETHODS ON NON-CLASS TYPES
multimethod mm => ('Der2', 'ARRAY') => sub { 6 };
multimethod mm => ('Der2', 'Regexp') => sub { 7 };
multimethod mm => ('Der2', '#') => sub { 8 };
multimethod mm => ('Der2', '$') => sub { 9 };
$::n++;
eval { mm(new Der2, [1,2,3]) == 6 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Der2, qr/\w*/) == 7 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Der2, 3) == 8 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Der2, "three") == 9 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Der2, "1a") == 9 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Base1, new Base2, new Base2) == 11 }
or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new DerDer1, new Der3, new Base2) == 11 }
or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Base1, new Der3, new Der3) == 12 }
or print "\n$@\n" and print "not ";
print "ok $::n\n";
$::n++;
eval { mm(new Base1, new DerDer3, new DerDer3) == 12 }
or print "\n$@\n" and print "not ";
print "ok $::n\n";
# HERE'S THE SUBROUTINE THAT POWERS THE DOUBLE LOOP ABOVE
sub try
{
# print "for: $_[0], $_[1]\n";
my $obj1 = eval "new $_[0]";
my $obj2 = eval "new $_[1]";
my $err = '';
my $res = 0;
eval { $res = mm($obj1, $obj2) } or $err = $@;
# print "\texpecting: $_[2], got: $res\n";
return $res == $_[2] || do {print "\n$err\n"; 0};
}
# TRY "CROSS-PACKAGE" MULTIMETHODS...
package elsewhere;
use Class::Multimethods;
multimethod 'mm';
$::n++;
eval { mm(new Der2, 1) == 8 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
multimethod mm => ('Der2', 'HASH') => sub { 10 };
$::n++;
eval { mm(new Der2, {a=>1}) == 10 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
# TEST ALTERNATE NAME INTRODUCING SYNTAX...
package otherwhere;
use Class::Multimethods 'mm';
$::n++;
eval { mm(new Der2, 1) == 8 } or print "\n$@\n" and print "not ";
print "ok $::n\n";
# TRY MULTIMETHODS AS CLASS METHODS...
package OtherClass;
use Class::Multimethods;
multimethod new => ('$','#') => sub { bless { num=>$_[1] }, $_[0] };
multimethod new => ('$','$') => sub { bless { str=>$_[1] }, $_[0] };
multimethod set => ('OtherClass','#') => sub { $_[0]->{num} = $_[1] };
multimethod set => ('OtherClass','$') => sub { $_[0]->{str} = $_[1] };
sub hasvals
{
for (keys %{$_[1]})
{
return undef unless $_[0]->{$_} eq $_[1]->{$_};
}
return 1;
return $_[0]
}
sub print
{
print "=====\n";
print "num: $_[0]->{num}\n" if $_[0]->{num};
print "str: $_[0]->{str}\n" if $_[0]->{str};
print "=====\n";
}
package main;
my $obj;
$obj = new OtherClass (42);
# $obj->print();
$::n++;
$obj->hasvals({num=>42}) or print "not ";
print "ok $::n\n";
$obj = new OtherClass ("cat");
# $obj->print();
$::n++;
$obj->hasvals({str=>"cat"}) or print "not ";
print "ok $::n\n";
$obj->set("dog");
# $obj->print();
$::n++;
$obj->hasvals({str=>"dog"}) or print "not ";
print "ok $::n\n";
$obj->set(99);
# $obj->print();
$::n++;
$obj->hasvals({num=>99, str=>"dog"}) or print "not ";
print "ok $::n\n";
# TEST INHERITANCE OF MULTIMETHOD CLASS METHODS...
package SonOfOtherClass;
@SonOfOtherClass::ISA = qw(OtherClass);
use Class::Multimethods;
multimethod set => ('OtherClass','ARRAY')
=> sub { $_[0]->{nums} = $_[1] };
sub print
{
print "=========\n";
$_[0]->SUPER::print();
print "nums: ", join(',', @{$_[0]->{nums}}), "\n"
if $_[0]->{nums};
print "=========\n";
}
package main;
$obj = new SonOfOtherClass (42);
# $obj->print();
$::n++;
$obj->hasvals({num=>42}) or print "not ";
print "ok $::n\n";
$obj = new SonOfOtherClass ("cat");
# $obj->print();
$::n++;
$obj->hasvals({str=>"cat"}) or print "not ";
print "ok $::n\n";
$obj->set("dog");
# $obj->print();
$::n++;
$obj->hasvals({str=>"dog"}) or print "not ";
print "ok $::n\n";
$obj->set(99);
# $obj->print();
$::n++;
$obj->hasvals({num=>99, str=>"dog"}) or print "not ";
print "ok $::n\n";
my $arr = [1,2,3,4,5];
$obj->set($arr);
# $obj->print();
$::n++;
$obj->hasvals({num=>99, str=>"dog", nums=>"$arr"}) or print "not ";
print "ok $::n\n";
# TEST WILDCARDS...
multimethod wild => ('Base1', 'Base2') => sub { 1 };
multimethod wild => ('Der1', 'Der3' ) => sub { 2 };
multimethod wild => ('Base1', '*' ) => sub { 3 };
multimethod wild => ('Base2', '*' ) => sub { 4 };
multimethod wild => ('*', 'Der3' ) => sub { 5 };
multimethod wild => ('*', '*' ) => sub { 6 };
# RESET EXPECTATIONS FOR EVERY POSSIBLE COMBINATION...
# CONSEQUENCES OF $::expect{'*'}{'*'} = 6;
foreach my $type1 ( @type1, @type2 )
{
foreach my $type2 ( @type2, @type1 )
{
$::expect{$type1}{$type2} = 6;
}
}
# CONSEQUENCES OF $::expect{Base1}{Base2} = 1;
foreach my $type1 ( @type1 )
{
foreach my $type2 ( @type2 )
{
$::expect{$type1}{$type2} = 1;
}
}
# CONSEQUENCES OF $::expect{Der1}{Der3} = 2;
foreach my $type1 (qw( Der1 DerDer1 ))
{
foreach my $type2 (qw( Der3 DerDer3 DerDer4 ))
{
$::expect{$type1}{$type2} = 2;
}
}
# CONSEQUENCES OF $::expect{Base1}{'*'} = 3;
foreach my $type1 ( @type1 )
{
foreach my $type2 ( @type1, @type2 )
{
$::expect{$type1}{$type2} = 3
if $::expect{$type1}{$type2} == 6 ;
}
}
# CONSEQUENCES OF $::expect{Base2}{'*'} = 4;
foreach my $type1 ( @type2 )
{
foreach my $type2 ( @type1, @type2 )
{
$::expect{$type1}{$type2} = 4
if $::expect{$type1}{$type2} == 6 ;
}
}
# CONSEQUENCES OF $::expect{'*'}{Der3} = 5;
foreach my $type1 ( @type1, @type2 )
{
foreach my $type2 (qw( Der3 DerDer3 DerDer4 ))
{
$::expect{$type1}{$type2} = 5
if $::expect{$type1}{$type2} == 6;
$::expect{$type1}{$type2} = 0
if $::expect{$type1}{$type2} == 3
|| $::expect{$type1}{$type2} == 4;
}
}
# CASES WHICH AREN'T AMBIGOUS, DESPITE THE PREVIOUS RULE
$::expect{Base2}{DerDer3} = 4; # 0 -> #4, 1 -> #5
$::expect{Base2}{DerDer4} = 4; # 0 -> #4, 1 -> #5
$::expect{Der3}{Der3} = 5; # 0 -> #5, 1 -> #4
$::expect{DerDer3}{Der3} = 5; # 0 -> #5, 2 -> #4
$::expect{DerDer4}{Der3} = 5; # 0 -> #5, 2 -> #4
$::expect{DerDer3}{DerDer3} = 5; # 1 -> #5, 2 -> #4
$::expect{DerDer4}{DerDer3} = 5; # 1 -> #5, 2 -> #4
$::expect{DerDer3}{DerDer4} = 5; # 1 -> #5, 2 -> #4
$::expect{DerDer4}{DerDer4} = 5; # 1 -> #5, 2 -> #4
# LOOP AND TEST EVERY COMBINATION...
foreach my $type1 ( @type1, @type2 )
{
foreach my $type2 ( @type2, @type1 )
{
$::n++;
wildtry($type1,$type2, $::expect{$type1}{$type2})
or print "not ";
print "ok $::n\n"
}
}
sub wildtry
{
# print "for: $_[0], $_[1]\n";
my $obj1 = eval "new $_[0]";
my $obj2 = eval "new $_[1]";
my $err = '';
my $res = 0;
eval { $res = wild($obj1, $obj2) } or $err = $@;
# print "\texpecting: $_[2], got: $res\n";
return $res == $_[2] || do {print "\n$err\n"; 0};
}
# TEST "INHERITANCE" OF '#' FROM '$'
multimethod val => ('$', '$') => sub { return '$$'; };
multimethod val => ('$', '#') => sub { return '$#'; };
multimethod val => ('#', '#') => sub { return '##'; };
$::n++;
val(1,2) eq '##' or print "not ";
print "ok $::n\n";
$::n++;
val('a',1) eq '$#' or print "not ";
print "ok $::n\n";
$::n++;
val('a','b') eq '$$' or print "not ";
print "ok $::n\n";
$::n++;
val(1,'a') eq '$$' or print "not ";
print "ok $::n\n";
Class-Multimethods-1.700/lib/Class/ 000755 000765 000024 00000000000 13015677726 017467 5 ustar 00damian staff 000000 000000 Class-Multimethods-1.700/lib/Class/Multimethods.pm 000755 000765 000024 00000127153 13015677725 022516 0 ustar 00damian staff 000000 000000 package Class::Multimethods;
use strict;
use vars qw($VERSION @ISA @EXPORT);
use Carp;
our $VERSION = '1.701';
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw( multimethod resolve_ambiguous resolve_no_match superclass multimethod_wrapper );
use vars qw(%dispatch %cached %hasgeneric %ambiguous_handler %no_match_handler %max_args %min_args %dispatch_installed);
%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
%dispatch_installed = (); # RECORDS DISPATCHES ALREADY INSTALLED __BY__ __US__
# 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',\@_) }"
if ( ! $dispatch_installed{$pkg}{$name} )
{
eval(make_dispatch($pkg,$name)) || croak "internal error: $@";
$dispatch_installed{$pkg}{$name}= 1;
}
#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 ? '#' : '$' );
$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__
=head1 NAME
Class::Multimethods - Support multimethods and function overloading in Perl
=head1 VERSION
This document describes version 1.701 of Class::Multimethods
released April 9, 2000.
=head1 SYNOPSIS
# IMPORT THE multimethod DECLARATION SUB...
use Class::Multimethods;
# DECLARE VARIOUS MULTIMETHODS CALLED find...
# 1. DO THIS IF find IS CALLED WITH A Container REF AND A Query REF...
multimethod find => (Container, Query)
=> sub { $_[0]->findquery($_[1]) };
# 2. DO THIS IF find IS CALLED WITH A Container REF AND A Sample REF...
multimethod find => (Container, Sample)
=> sub { $_[0]->findlike($_[1]) };
# 3. DO THIS IF find IS CALLED WITH AN Index REF AND A Word REF...
multimethod find => (Index, Word)
=> sub { $_[0]->lookup_word($_[1]) };
# 4. DO THIS IF find IS CALLED WITH AN Index REF AND A qr// PATTERN
multimethod find => (Index, Regexp)
=> sub { $_[0]->lookup_rx($_[1]) };
# 5. DO THIS IF find IS CALLED WITH AN Index REF AND A NUMERIC SCALAR
multimethod find => (Index, '#')
=> sub { $_[0]->lookup_elem($_[1]) };
# 6. DO THIS IF find IS CALLED WITH AN Index REF AND A NON-NUMERIC SCALAR
multimethod find => (Index, '$')
=> sub { $_[0]->lookup_str($_[1]) };
# 7. DO THIS IF find IS CALLED WITH AN Index REF AND AN UNBLESSED ARRAY REF
# (NOTE THE RECURSIVE CALL TO THE find MULTIMETHOD)
multimethod find => (Index, ARRAY)
=> sub { map { find($_[0],$_) } @{$_[1]} };
# SET UP SOME OBJECTS...
my $cntr = new Container ('./datafile');
my $indx = $cntr->get_index();
# ...AND SOME INHERITANCE...
@BadWord::ISA = qw( Word );
my $badword = new BadWord("fubar");
# ...AND EXERCISE THEM...
print find($cntr, new Query('cpan OR Perl')); # CALLS 1.
print find($cntr, new Example('by a committee')); # CALLS 2.
print find($indx, new Word('sugar')); # CALLS 3.
print find($indx, $badword); # CALLS 3.
print find($indx, qr/another brick in the Wall/); # CALLS 4.
print find($indx, 7); # CALLS 5.
print find($indx, 'But don't do that.'); # CALLS 6.
print find($indx, [1,"one"]); # CALLS 7,
# THEN 5 & 6.
=head1 DESCRIPTION
The Class:Multimethod module exports a subroutine (&multimethod)
that can be used to declare other subroutines that are dispatched
using a algorithm different from the normal Perl subroutine or
method dispatch mechanism.
Normal Perl subroutines are dispatched by finding the
appropriately-named subroutine in the current (or specified) package
and calling that. Normal Perl methods are dispatched by attempting to
find the appropriately-named subroutine in the package into which the
invoking object is blessed or, failing that, recursively searching for
it in the packages listed in the appropriate C<@ISA> arrays.
Class::Multimethods multimethods are dispatched quite differently. The
dispatch mechanism looks at the classes or types of each argument to
the multimethod (by calling C[ on each) and determines the
"closest" matching I of the multimethod, according to the
argument types specified in the variants' definitions (see L for a definition of "closest").
The result is something akin to C++'s function overloading, but more
intelligent, since multimethods take the inheritance relationships of
each argument into account. Another way of thinking of the mechanism
is that it performs polymorphic dispatch on I argument of a
method, not just the first.
=head2 Defining multimethods
The Class::Multimethods module exports a subroutine called
C, which can be used to specify multimethod variants with
the dispatch behaviour described above. The C subroutine
takes the name of the desired multimethod, a list of class names, and a
subroutine reference, and generates a corresponding multimethod variant
within the current package.
For example, the declaration:
package LargeInt; @ISA = (LargeNumeric);
package LargeFloat; @ISA = (LargeNumeric);
package LargeNumeric;
use Class::Multimethods;
multimethod divide => (LargeInt, LargeInt) => sub
{
LargeInt::divide($_[0],$_[1]);
};
multimethod divide => (LargeInt, LargeFloat) => sub
{
LargeFloat::divide($_[0]->AsLargeFloat(),$_[1]));
};
creates a (single!) multimethod C<&LargeNumeric::divide> with two variants.
If the multimethod is called with two references to C objects
as arguments, the first variant (i.e. anonymous subroutine) is invoked. If the
multimethod is called with a C reference and a C
reference, the second variant is called.
Note that if you're running under C]