Switch/case as a dispatch table with C-style fall-through

I plan to make a collection of various flavors of case/switch/given and package them up for CPAN as one package, probably named "Case.pm". This one is very C-flavored, with a twist. It constructs a hash associating your options with their actions, and returns a closure (necessary for handling default and fall-through). Then, when you need to execute the case, you just pass your term to the closure, and the appropriate sub(s) are executed.

I even wrangled a break() statement. No default identifier, though.

Comments on flaws or possible enhancements* would be welcome.

* within the limitations of using a hash jump table

Revision 1:

added a no-op subroutine to act as the default flag, and also as the default-default case
the term is passed to the subroutines
croaks on malformed input
simplified code by processing input list in reverse

Revision 2:(posted as followup, below)

Got rid of break(); added local $Case::action() for chaining subs
Die on non-CODE refs; warn on unreachable action block

package Swash;

# This is a tag you can stick in the list for clarity
# also serves as default routine when none is specified
sub default {}

# Make a key for each non-ref entry; the value is a coderef
# that executes the first subsequent coderef in the list
# Plus some bookkeeping to make fallthrough happen
sub new {
    my %swash;
    my ($default, $nextcode, $gotcode) = (\&default) x 2;
    my $call_pkg = caller;
    for my $item (reverse @_) {
        if (ref $item eq 'CODE') {
            if ($gotcode) {
                if (keys %swash) {
                    use Carp;
                    croak "Malformed swash: non-default coderef with n
+o associated term found";}
                $nextcode = $default = $gotcode;
            }
            $gotcode = $item;
        }
        elsif ($gotcode) {
            my ($case_code, $fallthru_code) = ($gotcode, $nextcode);
            $swash{$item} = sub {
                    my $fallthru = 1;
                    no strict 'refs';
                    no warnings 'redefine';
                    local *{$call_pkg.'::break'} = sub { $fallthru = 0
+ };
                    $case_code->($_[0]);
                    $fallthru_code->($_[0]) if $fallthru;
                };
            $nextcode = $swash{$item};
            ($gotcode, @keys) = ();
        }
        else {
            $swash{$item} = $nextcode;
        }
    }
    return sub { my ($term) = @_; ($swash{$term} || $default)->($term)
+ };
}

1;

package main;

my $case = Swash::new(
   qw(mozart)          => sub { print "$_[0] was a Musician!\n" },
   qw(einstein newton) => sub { print "$_[0] was a Genius!\n"; break()
+; },
   qw(dog cat pig)     => sub { print "$_[0] is an Animal!\n"; break()
+; },
   'Roy'               => sub { print "$_[0] should fall through..." }
+,
   Swash::default      => sub { print "No idea what $_[0] is.\n" }
);   

for (qw(mozart cat PerlMonk newton pig einstein)) {
    print "Looking up $_...\n";
    $case->($_);
}
print "And Roy?\n";
$case->('Roy');
[download]

Back to Cool Uses for Perl