File Coverage

blib/lib/Class/Multimethods.pm

Criterion	Covered	Total	%
statement	218	639	34.1
branch	54	304	17.7
condition	53	193	27.4
subroutine	22	35	62.8
pod	1	17	5.8
total	348	1188	29.2

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__