Listing 3.
Implementing the receive_event() method via a dynamic dispatch-table.
Multiple Dispatch in Perl
The Perl Journal, Spring 2000
 
package Window;
   
my $_id = 1;
sub new { bless { _id => $_id++ }, $_[0] }
  
my %table;
   
sub init {
    my ($param1,$param2,$param3,$handler) = @_;    
    $table{$param1}{$param2}{$param3} = $handler; 
}
   
init "Window", "Event", "Mode"
    => sub { print "Window $_[0]->{_id} can't handle a ",
             ref($_[1]), " event in ", ref($_[2]), " mode\n" };
   
init "Window", "Event", "OffMode"
    => sub { print "No window operations available in OffMode\n" };
   
init "ModalWindow", "ReshapeEvent", "Mode"
    => sub { print "Modal windows can't handle reshape events\n" };
   
init "ModalWindow", "AcceptEvent", "Mode"
    => sub { print "Modal window $_[0]->{_id} accepts!\n" };
   
init "ModalWindow", "AcceptEvent", "OffMode"
    => sub { print "Modal window $_[0]->{_id} can't accept in OffMode!\n" };
   
init "MovableWindow", "MoveEvent", "OnMode"
    => sub { print "Moving window $_[0]->{_id}!\n" };
   
init "ResizableWindow", "ResizeEvent", "OnMode"
    => sub { print "Resizing window $_[0]->{_id}!\n" };
   
init "ResizableWindow", "MoveAndResizeEvent", "OnMode"
    => sub { print "Moving and resizing window $_[0]->{_id}!\n" };
   

sub ancestors {
    no strict "refs";
    my @ancestors = @_;
    for (my $i=0; $i(@ancestors; $i++) 
        { splice @ancestors, $i+1, 0, @{"$ancestors[$i]::ISA"} }
    return @ancestors;
}
   
sub receive_event {
    my ($type1, $type2, $type3) = map {ref} @_;
    my $handler = $table{$type1}{$type2}{$type3};
 if (!$handler) {
        my @ancestors1 = ancestors($type1);
        my @ancestors2 = ancestors($type2);
        my @ancestors3 = ancestors($type3);

        SEARCH: foreach my $anc1 ( @ancestors1 ) {
                  foreach my $anc2 ( @ancestors2 )  {
                    foreach my $anc3 ( @ancestors3 ) {
                        $handler = $table{$anc1}{$anc2}{$anc3};
                        next unless $handler;
                        $table{$type1}{$type2}{$type3} = $handler;
                        last SEARCH;
                    }
                  }
                }
    }
    die "No handler defined for ($type1,$type2,$type3)"
        unless $handler;
    $handler->(@_);
}
   
package ModalWindow;     @ISA = qw( Window );
package MovableWindow;   @ISA = qw( Window );
package ResizableWindow; @ISA = qw( MovableWindow );