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 no 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');