Dispatch tables are great and convienient, but sometimes can be a bit of a pain to write. You have references flying over here and closures flying over there; yuck! Thats much too complicated for so simple of an idea. Wouldn't it be great if you could say "Ok, I have a set of subs here, and I want a dispatch table that maps each subname to each sub... Go do it, Perl genie!" With this short snippet of a module, now you can. Just throw your subs in a module, use Dispatch;, and a create_dptable subroutine that (surpise!) creates a dispatch table that maps each subname in the package to its corresponding sub will magically appear to serve you.

Here's an example: 

package TestPkg;
use Dispatch;

sub sub_a {
    # ...
}

sub sub_b {
    # ...
}

sub _sub_b_helper { # not part of the table!
    # ...
}

sub sub_c {
    print $_[0];
}

package main;
my $table = create_dptable TestPkg; # or TestPkg::create_dptable();
$table->{sub_c}->("Hello!");

[download]

Update: Added a feature such that subroutines whose names start with a _ do not become part of the dispatch table. 

package Dispatch;

sub import {
   my $pkg = (caller)[0];
   *{"${pkg}::create_dptable"} = sub {
        my %dispatch;
        my @oksymbols = grep {    !/^_/
                             && !/^create_dptable$/
                             && defined *{"${pkg}::$_"}{CODE} }
                        keys %{*{"${pkg}::"}};
        $dispatch{$_} = *{"${pkg}::$_"}{CODE}
            foreach ( @oksymbols );
        return \%dispatch
    };
}

1;

[download]

Replies are listed 'Best First'.
Re: Easy dispatch tables. (pointless?)
by Aristotle (Chancellor) on Apr 02, 2003 at 22:38 UTC
    That seems pointless. If you put the subs in their own package, you can just call them as class methods: 
    my $dispatch = "sub_c";
TestPkg->$dispatch("Hello!");

    [download]
    You'll have to remember to shift the package name off the argument list in the subs, but that's the only difference. I don't see what's messy about a hashref, but that's just me.

    Makeshifts last the longest.

[reply]
[d/l]

      How about this:

      use CGI qw(:all);
my $op = param('operation');

my $table = create_dptable TestPkg;
$table->{$op}->() if exists $table->{$op};

      [download]

      As opposed to this: 

      use CGI qw(:all);
my $op = param('operation');

{
    no strict 'refs';
    TestPkg->$dispatch('Hello!')
        if defined *{"TestPkg::$dispatch"}{CODE};
}

      [download]


      Or what about this: 

      my $input = <>;

my $table = create_dptable TestPkg;
$table->{$_}->($input) foreach (keys $table);

      [download]

      As opposed to this:

      my $input = <>;

{
    no strict 'refs';
    *{"TestPkg::$_"}{CODE}->($input)
        foreach( grep {    !/^_/
                        && defined *{"TestPkg::$_"}{CODE} }
                 keys %{*{'TestPkg::'}}
        ); 
}

      [download]

      Essentially, the gain of a dispatch table is the gain of all of the advantages and techniques of working with hashes.

      Update: Added another example.

[reply]
[d/l]
[select]
        use CGI qw(:all);
my $op = param('operation');

TestPkg->$dispatch('Hello!') if UNIVERSAL::can('TestPkg', $dispatch);

        [download]
        You could also define an AUTOLOAD in TestPkg and forget about it entirely. 
        my $input = <>;

$_->($input) for
    map /^_/ ? () : *{$TestPkg::{$_}}{CODE} || (),
    keys %TestPkg::;

        [download]
        Or maybe 
        my $input = <>;

my $sub;
!/^_/ && *$sub{CODE} && *$sub{CODE}->($input)
    while ($_, $sub) = each %TestPkg::;

        [download]
        Any way you turn it though, I don't see the advantage of 
        package Foo;
use Dispatch;

sub bar {
    ...
}

sub baz {
    ...
}

package main;

my $t = Foo->create_dptable;
$t->{bar}->($quux);

        [download]
        over 
        my $t = {
    bar => sub {
        ...
    },
    baz => sub {
        ...
    },
};

$t->{bar}->($quux);

        [download]

        If anything, the latter keeps together things that belong together and is quicker to grasp the purpose of.

        Fixed minor errors thanks to jryan

        Makeshifts last the longest.

[reply]
[d/l]
[select]
Re: Easy dispatch tables.
by hardburn (Abbot) on Apr 02, 2003 at 15:09 UTC

    Added a feature such that subroutines whose names start with a _ do not become part of the dispatch table.

    IMHO, that's backwards. In a real-life program, the dispatch table subs will be much smaller than the number of regular subs. Having a bunch of subs with a _ before them is ugly, so their use should be minimized.

    I now await a post telling me how wrong I am (:

    ----
    I wanted to explore how Perl's closures can be manipulated, and ended up creating an object system by accident.
    -- Schemer

    Note: All code is untested, unless otherwise stated

[reply]
      Oh how wrong you are! ;-)

      Since the purpose of the package in which the subs live is to contain dispatch subs, it should be presumed that that is all those subs are to be used for. Allowing some subs to be exempted is a natural expediency. But it would be wrong (IMHO) to let the package (like TestPkg in the example) be any arbitrary class, or other package. Namespaces are a good way to package up a set of closely related subs, and in this case, they're closely related by virtue of being the targets of a dispatch table.

      jdporter
      The 6th Rule of Perl Club is -- There is no Rule #6.

[reply]
[d/l]

        Ahhh, I see. You're right.

        ----
        I wanted to explore how Perl's closures can be manipulated, and ended up creating an object system by accident.
        -- Schemer

        Note: All code is untested, unless otherwise stated

[reply]

Back to Cool Uses for Perl