#!perl
=pod

=head1 NAME

smatch - smart matching switch construct

=head1 SYNOPSIS

smatch $val =>
  [ 1,           sub { print "number 1" } ],
  [ 'a',         sub { print 'string a' } ],
  [ [1,10],      sub { print 'number in range' } ], # strings work, to
+o
  [ @array, 42,  sub { print 'number in list' } ],
  [ qr/\w+/,     sub { print 'pattern' } ],
  [ \%hash,      sub { print 'entry in hash' } ],
  [ \&sub,       sub { print 'arg to sub' } ],
  [ (),          sub { print 'default' } ]
;

[download]

=head1 NOTES

C<smatch> aliases $_ to $val and evaluates its subsequent
arguments in that context.
Each subsequent argument should be an arrayref, whose last element
is a coderef. The coderef will be executed if any other element
yields a true value after being evaluated according to this table:

 Input ($in) is    Example         Operation
 ===============   =============   =================================
 Regex             qr/foo|bar/     /$in/
 
 Number            3.14            $_ == $in

 coderef           sub { /foo/ }   $in->($_)

 range specifier   [100,1000]      $in->[0] <= $_ and $_ <= $in->[1]
 (arrayref)

 hashref           \%hash          $in->{$_}

 any other scalar  'a string'      $_ eq $in

=cut

use strict;
use warnings;

package Smatch;

use Regexp::Common;

sub in_range {
    my ($n, $lo, $hi) = @_;
    if ($n =~ /^RE{num}{real}$/
        and $lo =~ /^$RE{num}{real}$/ and $hi =~ /^$RE{num}{real}$/) {
        $lo <= $hi or warnings::warnif(misc => 'Invalid range $lo .. $
+hi');
        return ($lo <= $n and $n <= $hi);
    } else {
        $lo le $hi or warnings::warnif(misc => 'Invalid range $lo .. $
+hi');
        return ($lo le $n and $n le $hi);
    }
}

sub smatch {
    local *_ = \$_[0];
  CASES:
    for my $caselist (@_[1..$#_] ) {
        my $coderef = pop @$caselist;
        if (@$caselist) {
            for my $case (@$caselist) {
                if (my $reftype = ref $case) {
                    $coderef->(), last CASES if
                      ($reftype eq 'Regexp' and m{$case}) or
                      ($reftype eq 'ARRAY' and in_range($_, @$case)) o
+r
                      ($reftype eq 'HASH' and $case->{$_}) or
                      ($reftype eq 'CODE' and $case->($_)) or
                      $case eq $_
                    ;
                }
                else {
                    $coderef->(), last CASES if
                      ($case =~ /^$RE{num}{real}$/ and /^$RE{num}{real
+}/
                       and $case == $_) or
                      $case eq $_
                    ;
                }
            }
        }
        else {
            $coderef->();
            last;
        }
    }
}


package main;

my @vals = (1, 10, 'foo1', 'bar', 'leftover');
for my $val (@vals) {
    no warnings 'exiting';
    Smatch::smatch $val =>
      [ 1,           sub { print "$_ is 1\n" } ],
      [ [10, 20],    sub { print "$_ hit me\n"; next } ],
      [ 'foo1',      sub { print "$_ matched foo1\n"; next} ],
      [ { foo1=>1 }, sub { print "$_ found in hash\n" } ],
      [ qr/1/,       sub { print "$_ got me, too?\n" } ],
      [ sub { s/bar/baz/ },  sub { print "$_ satisfied code\n" } ],
      [ (),          sub { print "$_ fell to the default\n" } ]
;
    print "Done smatching $val\n";
}
[download]

Note that coderefs can alter the loop variables (bar gets changed to baz in my example. Also note that use of "next" triggers fallthrough (much like Switch.pm, on which this is based) but you'll want to turn off exiting warnings as I have done here.