Hack 98. Improve Your Dispatch Tables

Run code based on regex matches.

A dispatch table, in the form of a hash, is a useful technique for associating code with keys:

my %dispatch = (     red   => sub { return qq{<font color="#ff0000">$_[0]</font>} },     green => sub { return qq{<font color="#00ff00">$_[0]</font>} },     blue  => sub { return qq{<font color="#0000ff">$_[0]</font>} },     black => sub { return qq{<font color="#000000">$_[0]</font>} },     white => sub { return qq{<font color="#ffffff">$_[0]</font>} }, );

This approach lets you print out pretty HTML:

print $dispatch{black}->('knight');

Of course, this only works as long as the keys you use are fixed strings, because the hash lookup relies on string equality.

A regular expression that contains meta-characters (such as \\d or [abc]) can match strings, but the string matched is not equal (in the sense of string equality) to the regular expression. In other words, this reasonable-looking code just does not work:

my %dispatch = (   # note that backslashes need to be "doubled up"   '\\\\d'   => sub { return "saw a digit" },   '[a-z]' => sub { return "saw a lowercase letter" }, );

Looking up $dispatch{5} won't find anything. Being able to make it work would be very useful; Regexp::Assemble will let you do just that.

The hack

The idea is to gather all the different keys of the dispatch table and assemble them into a single regular expression. Given such an expression, you can then apply it to a target string and see what matches.

Even better, specifying a tracked pattern lets you find out after the match which pattern from the dispatch triggered the match. Once you have this, use it as a key into the dispatch table and call the corresponding code block. The more keys there are, the better the situation becomes, because instead of running down a long chain of regular expression matches in an if/elsif/elsif chain sequentially, you need only one match to try them all at once.

At the simplest, assemble the keys in the above dispatch table into a single tracked regular expression with:

my $re = Regexp::Assemble->new->track->add(keys %dispatch);

You can then use this to process a file with a loop as simple as:

while (<>) {     $re->match($_) and print $dispatch{$re->matched}->( ); }

Running the Code

As an example, consider an IRC bot. You may wish to program a bot to react to many different messages observed on a channel. Ordinarily, you might do this with a mini-parser running through a list of regular expressions. Regexp::Assemble allows you to use a dispatch table instead.

All that you need is a hash whose keys are regular expressions (or to be precise, scalars usable as regexps), and whose values are code references.

First assemble the hash keys, and then match the resulting expression against incoming messages on an IRC channel. When a match occurs, recover the original regexp and use it to look up the code reference in the dispatch table and call that, passing in the captured variables that the pattern specified.

Here's a bare-bones IRC bot that has just enough smarts to keep track of karma (foo++, bar--) and factoids (for instance, the association that TPF is The Perl Foundation, so when someone asks "TPF?", the bot responds with the definition).

The instantiating code is very short, thanks to Bot::BasicBot:

use DispatchBot; my $bot = DispatchBot->new(     server   => "irc.perl.org",     port     => "6667",     channels => ["#bottest"],     nick     => 'rebot', ); $bot->run( );

The package DispatchBot is where everything all happens:

package DispatchBot; use strict; use Regexp::Assemble; use Bot::BasicBot; use YAML qw(LoadFile DumpFile); use vars qw( $VERSION @ISA ); $VERSION    = '0.03'; @ISA        = 'Bot::BasicBot'; my $factoid = _load( 'factoid.dat' ); # "foo" is "bar" factoids my $karma   = _load( 'karma.dat' );   # keep track of foo++ and foo-- sub _load {     my $file = shift;     return -e $file ? LoadFile($file) : { }; } sub _save {     my ($dictionary, $file) = @_;     DumpFile( $file, $dictionary ); } sub _flush {     _save( $factoid, 'factoid.dat' );     _save( $karma,   'karma.dat' ); } END { _flush } my %dispatch = (     # define a factoid     '(\\\\S+) is (.*)$' => sub { $factoid->{$_[0]} = $_[1]; _flush; return },     # query a factoid     '(\\\\S+)\\s*\\\\?$' => sub     {         exists $factoid->{$_[0]}             and return "I believe that $_[0] is $factoid->{$_[0]}"     },     # drop a factoid     'forget (\\\\S+)$'=> sub     {         if (exists $factoid->{$_[0]})         {             my $message = "I forgot $_[0]";             delete $factoid->{$_[0]};             _flush;             return $message;         }     },     # karma shifts     '(\\\\S+)\\\\+\\\\+' => sub { $karma->{$_[0]}++; _flush; return },     '(\\\\S+)--'     => sub { $karma->{$_[0]}--; _flush; return },     # karma query     '^karma (\\\\S+)$' => sub     {         return exists $karma->{$_[0]}             ? "$_[0] has karma of $karma->{$_[0]}"             : "$_[0] has neutral karma"     },     # time... to die     '^!quit$' => sub { exit }, ); my $re = Regexp::Assemble->new->track->add(keys %dispatch); sub said {     my ($self, $arg) = @_;     $re->match($arg->{body})         and return $dispatch{$re->matched}->($re->capture);     return;                                 }