view release on metacpan or  search on metacpan

lib/Class/Multimethods.pm  view on Meta::CPAN

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);