smt

#!perl
use 5.20.0;
use warnings;
use experimental qw(smartmatch signatures);
use Test::More 'no_plan';

my $evens;

sub test ($input) {
  given ($input) {
    when { ref }      { "ref" }
    when (/\D/)       { "non-number" }
    when { $_ == 0 }  { "zero" }
    when { $_ % 2  }  { "odd" }

    "negative" when { $_ < 0 };

    $evens++;

    default           { "even" }
  }
}

for (
  qw(
    1
    2
    123
    -124
    eleventy-one
  ),
  []
) {
  # Why do we warn on smart match in void?  smart match can have side effects
  # like capturing or whatever the subroutine does.  I'm not sold on this
  # warning. -- rjbs, 2015-09-09
  # $_ ~~ \&test;

  # It makes sense to me that test($_) returns the contents of the matching
  # when block.  I am surprised that the result of the subroutine is returned
  # as the result of the smart match — that is, that it is not forced into
  # a boolean.  I think I'm going to mark that up as my problem, not perl's,
  # but I'm still surprised. -- rjbs, 2015-09-09

  my $sub_rv = test($_);
  my $smt_rv = ($_ ~~ \&test);

  printf "%s ~~ \&test is: %s, %s\n", $_, $sub_rv, $smt_rv;
}

for (qw(Alice Bob Charlie Dirk Emanuel Freddi3)) {
  say "No Charlies allowed" when /Charlie/;

  say "Hello, $_";

  when { $_ eq 'Emmanuel' } {
    say "...and may the Lord be with you.";
  }

  # behold, the postfix when BLOCK form
  say "Good to see you again." when { $_ eq 'Alice' };
  say "Where's your lovely wife?" when sub ($who) { $who eq 'Bob' };

  my $odd = qr/[13479]\z/;
  when ($odd) {
    say "What an odd name.";
  }

  say "Nice to meet you, $_";
}

say "By the way, saw $evens even numbers.";

# ----------------------------------------------------------------------------

# We want this object to work like a test when on the rhs, but not to do
# anything special on the lhs.
package TestRHS {
  use overload '~~' => '_smartmatch',
               '""' => sub { 'Right Hand Side' },
               fallback => 1;

  sub new { bless {} }

  sub _smartmatch ($x, $y, $rev) {
    return $y eq 'Right' if $rev;
    return $y ~~ $x;
  }
}

my $rhs = TestRHS->new;

ok(   'Right' ~~ $rhs,   'Right ~~ RHS');
ok(! ('Left'  ~~ $rhs),  'Left !~~ RHS');

ok($rhs ~~ /Hand/,             'RHS ~~ /Hand/');
ok($rhs ~~ sub { ref($_[0]) }, 'RHS ~~ sub{ref$_[0]}');

# The one on the right gets first crack, and it checks whether the one on the
# left is eq to 'Right', which it isn't, because it stringifies to 'Right Hand
# Side.'
ok(! ($rhs ~~ $rhs),           'RHS !~~ RHS');

# ----------------------------------------------------------------------------

# We want this object to work like a test-me-specially on the left, but not on
# the right.
package TestLHS {
  use overload '~~' => '_smartmatch',
               '""' => sub { 'Left Hand Side' },
               fallback => 1;

  sub new { bless {} }

  sub _smartmatch ($x, $y, $rev) {
    return $y eq 'Left' if ! $rev;

    # This will also disable overloading on $y.  Will this ever be a problem?
    no overloading;
    return $y ~~ $x;
  }
}

package TestStringifies {
  use overload '""' => sub { 'Left' }, fallback => 1;
  sub new { bless {} }
}

my $lhs = TestLHS->new;
my $str = TestStringifies->new;

ok(   $lhs ~~ 'Left', 'LHS  ~~ Left');
ok(! ($lhs ~~ []),    'LHS !~~ []'); # Important: $x~~[] normally fatal!
ok(   $lhs ~~ $str,   'LHS !~~ ""-overloaded'); # also fatal w/o lhs ol!

# Note especially how we're showing that the test on the rhs is used when it's
# understood.  The left-hand-side fallback is used just before giving up only.
ok($lhs ~~ sub { ref($_[0]) }, 'LHS ~~ sub{ref$_[0]}');

{
  my $ok = eval { 'Left' ~~ $lhs; 1 };
  my $error = $@;

  ok(! $ok, 'Left ~~ LHS --> FATAL');
  like($error, qr/only smart/i, "can't put no-overload obj on rhs of ~~");
}

# ----------------------------------------------------------------------------

# Weird-o stuff:

# I believe this should pass, as literal array and hash expressions should
# become references before testing.  (Tony Cook: this was discussed in
# <20150618123544.GA17342@cancer.codesimply.com>, June 18, 2015)
ok( @INC ~~ /ARRAY/, '@INC~~/ARRAY/, because the LHS is en-referenced first');

ok(
  # remember: array slice in scalar context gets you the final element
  @INC[0 .. $#INC] ~~ sub { $_[0] eq $INC[-1] },
  'everything other than literal array/hash expr get scalar context',
);

I may be blind, but you don't seem to have a test here for the most common (for me) usage, which is as a kind of "in" operator. That is, I have code like:

given ($path) {
    when (['/', '/index']) { $app->do_index($env); }
    when (['/dumpapp']) { $app->do_dump($env); }
    ...
}

Am I missing something above and this is supported?