This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regularise "when"
authorZefram <zefram@fysh.org>
Tue, 21 Nov 2017 18:17:10 +0000 (18:17 +0000)
committerZefram <zefram@fysh.org>
Tue, 21 Nov 2017 18:17:10 +0000 (18:17 +0000)
Remove from "when" the implicit enreferencement of array/hash conditions
and the implicit smartmatch of most conditions.  Delete most of the
documentation about behaviour of older versions of given/when, because
explaining the now-old "when" behaviour would be excessively cumbersome
and there's little compatibility to take advantage of.  Delete the
documentation about differences of given/when from the Perl 6 feature,
because the differences are now even more extensive and it's too much
difference to sensibly explain.  Add tests of "when" in isolation.

MANIFEST
embed.fnc
embed.h
ext/XS-APItest/t/grok.t
op.c
pod/perlsyn.pod
proto.h
t/lib/croak/pp_ctl
t/op/switch.t
t/op/when.t [new file with mode: 0644]
t/run/switches.t

index db8b651..49ebbb8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5806,6 +5806,7 @@ t/op/ver.t                        See if v-strings and the %v format flag work
 t/op/waitpid.t                 See if waitpid works
 t/op/wantarray.t               See if wantarray works
 t/op/warn.t                    See if warn works
+t/op/when.t                    See if when works
 t/op/while.t                   See if while loops work
 t/op/write.t                   See if write works (formats work)
 t/op/yadayada.t                        See if ... works
index c33833a..e4b3194 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2140,7 +2140,6 @@ s |void   |no_bareword_allowed|NN OP *o
 sR     |OP*    |no_fh_allowed|NN OP *o
 sR     |OP*    |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags
 s      |OP*    |too_many_arguments_pv|NN OP *o|NN const char* name|U32 flags
-s      |bool   |looks_like_bool|NN const OP* o
 s      |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode \
                                |PADOFFSET entertarg
diff --git a/embed.h b/embed.h
index 13277fc..d6f8aa2 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define inplace_aassign(a)     S_inplace_aassign(aTHX_ a)
 #define is_handle_constructor  S_is_handle_constructor
 #define listkids(a)            S_listkids(aTHX_ a)
-#define looks_like_bool(a)     S_looks_like_bool(aTHX_ a)
 #define modkids(a,b)           S_modkids(aTHX_ a,b)
 #define move_proto_attr(a,b,c,d)       S_move_proto_attr(aTHX_ a,b,c,d)
 #define my_kid(a,b,c)          S_my_kid(aTHX_ a,b,c)
index 810ffae..4632752 100644 (file)
@@ -32,11 +32,11 @@ foreach my $leader ('', ' ', '  ') {
        {
            my (@UV, @NV);
            given ($Config{ivsize}) {
-               when (4) {
+               when ($_ == 4) {
                    @UV = qw(429496729  4294967290 4294967294 4294967295);
                    @NV = qw(4294967296 4294967297 4294967300 4294967304);
                }
-               when (8) {
+               when ($_ == 8) {
                    @UV = qw(1844674407370955161  18446744073709551610
                             18446744073709551614 18446744073709551615);
                    @NV = qw(18446744073709551616 18446744073709551617
diff --git a/op.c b/op.c
index 23f25db..67a7f00 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8851,88 +8851,6 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
     return o;
 }
 
-/* Does this look like a boolean operation? For these purposes
-   a boolean operation is:
-     - a subroutine call [*]
-     - a logical connective
-     - a comparison operator
-     - a filetest operator, with the exception of -s -M -A -C
-     - defined(), exists() or eof()
-     - /$re/ or $foo =~ /$re/
-   
-   [*] possibly surprising
- */
-STATIC bool
-S_looks_like_bool(pTHX_ const OP *o)
-{
-    PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
-
-    switch(o->op_type) {
-       case OP_OR:
-       case OP_DOR:
-           return looks_like_bool(cLOGOPo->op_first);
-
-       case OP_AND:
-        {
-            OP* sibl = OpSIBLING(cLOGOPo->op_first);
-            ASSUME(sibl);
-           return (
-               looks_like_bool(cLOGOPo->op_first)
-            && looks_like_bool(sibl));
-        }
-
-       case OP_NULL:
-       case OP_SCALAR:
-           return (
-               o->op_flags & OPf_KIDS
-           && looks_like_bool(cUNOPo->op_first));
-
-       case OP_ENTERSUB:
-
-       case OP_NOT:    case OP_XOR:
-
-       case OP_EQ:     case OP_NE:     case OP_LT:
-       case OP_GT:     case OP_LE:     case OP_GE:
-
-       case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
-       case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
-
-       case OP_SEQ:    case OP_SNE:    case OP_SLT:
-       case OP_SGT:    case OP_SLE:    case OP_SGE:
-       
-       case OP_SMARTMATCH:
-       
-       case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
-       case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
-       case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
-       case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
-       case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
-       case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
-       case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
-       case OP_FTTEXT:   case OP_FTBINARY:
-       
-       case OP_DEFINED: case OP_EXISTS:
-       case OP_MATCH:   case OP_EOF:
-
-       case OP_FLOP:
-
-           return TRUE;
-       
-       case OP_CONST:
-           /* Detect comparisons that have been optimized away */
-           if (cSVOPo->op_sv == &PL_sv_yes
-           ||  cSVOPo->op_sv == &PL_sv_no)
-           
-               return TRUE;
-           else
-               return FALSE;
-
-       /* FALLTHROUGH */
-       default:
-           return FALSE;
-    }
-}
-
 /*
 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
 
@@ -8962,8 +8880,7 @@ Constructs, checks, and returns an op tree expressing a C<when> block.
 C<cond> supplies the test expression, and C<block> supplies the block
 that will be executed if the test evaluates to true; they are consumed
 by this function and become part of the constructed op tree.  C<cond>
-will be interpreted DWIMically, often as a comparison against C<$_>,
-and may be null to generate a C<default> block.
+may be null to generate a C<default> block.
 
 =cut
 */
@@ -8971,20 +8888,8 @@ and may be null to generate a C<default> block.
 OP *
 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
 {
-    const bool cond_llb = (!cond || looks_like_bool(cond));
-    OP *cond_op;
-
     PERL_ARGS_ASSERT_NEWWHENOP;
-
-    if (cond_llb)
-       cond_op = cond;
-    else {
-       cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
-               newDEFSVOP(),
-               scalar(ref_array_or_hash(cond)));
-    }
-    
-    return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+    return newGIVWHENOP(cond, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
 }
 
 /* must not conflict with SVf_UTF8 */
index 80eca0a..d02516c 100644 (file)
@@ -671,29 +671,18 @@ Or if you don't care to play it safe, like this:
         default { $nothing = 1 }
     }
 
-The arguments to C<given> and C<when> are in scalar context,
-and C<given> aliases the C<$_> variable to the result of evaluating its
+The arguments to C<given> and C<when> are in scalar context.
+C<given> aliases the C<$_> variable to the result of evaluating its
 topic expression.
+C<when> evaluates its argument as a truth value.  If the argument
+was false then it does not execute its block, and proceeds to the
+following statement.  If the argument was true, it executes the block,
+then implicitly jumps to the end of the topicalizer.
 
-Exactly what the I<EXPR> argument to C<when> does is hard to describe
-precisely, but in general, it tries to guess what you want done.  Sometimes
-it is interpreted as C<< $_ ~~ I<EXPR> >>, and sometimes it is not.  It
-also behaves differently when lexically enclosed by a C<given> block than
-it does when dynamically enclosed by a C<foreach> loop.  The rules are far
-too difficult to understand to be described here.  See L</"Experimental Details
-on given and when"> later on.
-
-Due to an unfortunate bug in how C<given> was implemented between Perl 5.10
-and 5.16, under those implementations the version of C<$_> governed by
-C<given> is merely a lexically scoped copy of the original, not a
-dynamically scoped alias to the original, as it would be if it were a
-C<foreach> or under both the original and the current Perl 6 language
-specification.  This bug was fixed in Perl 5.18 (and lexicalized C<$_> itself
-was removed in Perl 5.24).
-
-If your code still needs to run on older versions,
-stick to C<foreach> for your topicalizer and
-you will be less unhappy.
+On versions of Perl preceding Perl 5.28, C<given> and C<when> behave
+somewhat differently from their present behaviour.
+If your code needs to run on older versions,
+avoid C<given> and C<when>.
 
 =head2 Goto
 X<goto>
@@ -907,194 +896,10 @@ shell:
 =head2 Experimental Details on given and when
 
 As previously mentioned, the "switch" feature is considered highly
-experimental; it is subject to change with little notice.  In particular,
-C<when> has tricky behaviours that are expected to change to become less
-tricky in the future.  Do not rely upon its current (mis)implementation.
-Before Perl 5.28, C<given> also had tricky behaviours that you should still
+experimental; it is subject to change with little notice.
+Before Perl 5.28, C<given> and C<when> had tricky behaviours that you should
 beware of if your code must run on older versions of Perl.
 
-Here is a longer example of C<given>:
-
-    use feature ":5.10";
-    given ($foo) {
-        when (undef) {
-            say '$foo is undefined';
-        }
-        when ("foo") {
-            say '$foo is the string "foo"';
-        }
-        when ([1,3,5,7,9]) {
-            say '$foo is an odd digit';
-            continue; # Fall through
-        }
-        when ($_ < 100) {
-            say '$foo is numerically less than 100';
-        }
-        when (\&complicated_check) {
-            say 'a complicated check for $foo is true';
-        }
-        default {
-            die q(I don't know what to do with $foo);
-        }
-    }
-
-Before Perl 5.18, C<given(EXPR)> assigned the value of I<EXPR> to
-merely a lexically scoped I<B<copy>> (!) of C<$_>, not a dynamically
-scoped alias the way C<foreach> does.  That made it similar to
-
-        do { my $_ = EXPR; ... }
-
-except that the block was automatically broken out of by a successful
-C<when> or an explicit C<break>.  Because it was only a copy, and because
-it was only lexically scoped, not dynamically scoped, you could not do the
-things with it that you are used to in a C<foreach> loop.  In particular,
-it did not work for arbitrary function calls if those functions might try
-to access $_.  Best stick to C<foreach> for that.
-
-Before Perl 5.28, if the I<EXPR> in C<given(EXPR)> was an array or hash
-reference then the topic would be a reference to that array or hash,
-rather than the result of evaluating the array or hash in scalar context.
-
-Most of the power comes from the implicit smartmatching that can
-sometimes apply.  Most of the time, C<when(EXPR)> is treated as an
-implicit smartmatch of C<$_>, that is, C<$_ ~~ EXPR>.  (See
-L<perlop/"Smartmatch Operator"> for more information on smartmatching.)
-But when I<EXPR> is one of the 10 exceptional cases (or things like them)
-listed below, it is used directly as a boolean.
-
-=over 4
-
-=item Z<>1.
-
-A user-defined subroutine call or a method invocation.
-
-=item Z<>2.
-
-A regular expression match in the form of C</REGEX/>, C<$foo =~ /REGEX/>,
-or C<$foo =~ EXPR>.  Also, a negated regular expression match in
-the form C<!/REGEX/>, C<$foo !~ /REGEX/>, or C<$foo !~ EXPR>.
-
-=item Z<>3.
-
-A smart match that uses an explicit C<~~> operator, such as C<EXPR ~~ EXPR>.
-
-B<NOTE:> You will often have to use C<$c ~~ $_> because the default case
-uses C<$_ ~~ $c> , which is frequentlythe opposite of what you want.
-
-=item Z<>4.
-
-A boolean comparison operator such as C<$_ E<lt> 10> or C<$x eq "abc">.  The
-relational operators that this applies to are the six numeric comparisons
-(C<< < >>, C<< > >>, C<< <= >>, C<< >= >>, C<< == >>, and C<< != >>), and
-the six string comparisons (C<lt>, C<gt>, C<le>, C<ge>, C<eq>, and C<ne>).
-
-=item Z<>5.
-
-At least the three builtin functions C<defined(...)>, C<exists(...)>, and
-C<eof(...)>.  We might someday add more of these later if we think of them.
-
-=item Z<>6.
-
-A negated expression, whether C<!(EXPR)> or C<not(EXPR)>, or a logical
-exclusive-or, C<(EXPR1) xor (EXPR2)>.  The bitwise versions (C<~> and C<^>)
-are not included.
-
-=item Z<>7.
-
-A filetest operator, with exactly 4 exceptions: C<-s>, C<-M>, C<-A>, and
-C<-C>, as these return numerical values, not boolean ones.  The C<-z>
-filetest operator is not included in the exception list.
-
-=item Z<>8.
-
-The C<..> and C<...> flip-flop operators.  Note that the C<...> flip-flop
-operator is completely different from the C<...> elliptical statement
-just described.
-
-=back
-
-In those 8 cases above, the value of EXPR is used directly as a boolean, so
-no smartmatching is done.  You may think of C<when> as a smartsmartmatch.
-
-Furthermore, Perl inspects the operands of logical operators to
-decide whether to use smartmatching for each one by applying the
-above test to the operands:
-
-=over 4
-
-=item Z<>9.
-
-If EXPR is C<EXPR1 && EXPR2> or C<EXPR1 and EXPR2>, the test is applied
-I<recursively> to both EXPR1 and EXPR2.
-Only if I<both> operands also pass the
-test, I<recursively>, will the expression be treated as boolean.  Otherwise,
-smartmatching is used.
-
-=item Z<>10.
-
-If EXPR is C<EXPR1 || EXPR2>, C<EXPR1 // EXPR2>, or C<EXPR1 or EXPR2>, the
-test is applied I<recursively> to EXPR1 only (which might itself be a
-higher-precedence AND operator, for example, and thus subject to the
-previous rule), not to EXPR2.  If EXPR1 is to use smartmatching, then EXPR2
-also does so, no matter what EXPR2 contains.  But if EXPR2 does not get to
-use smartmatching, then the second argument will not be either.  This is
-quite different from the C<&&> case just described, so be careful.
-
-=back
-
-These rules are complicated, but the goal is for them to do what you want
-(even if you don't quite understand why they are doing it).  For example:
-
-    when (/^\d+$/ && $_ < 75) { ... }
-
-will be treated as a boolean match because the rules say both
-a regex match and an explicit test on C<$_> will be treated
-as boolean.
-
-Also:
-
-    when ([qw(foo bar)] && /baz/) { ... }
-
-will use smartmatching because only I<one> of the operands is a boolean:
-the other uses smartmatching, and that wins.
-
-Further:
-
-    when ([qw(foo bar)] || /^baz/) { ... }
-
-will use smart matching (only the first operand is considered), whereas
-
-    when (/^baz/ || [qw(foo bar)]) { ... }
-
-will test only the regex, which causes both operands to be
-treated as boolean.  Watch out for this one, then, because an
-arrayref is always a true value, which makes it effectively
-redundant.  Not a good idea.
-
-Tautologous boolean operators are still going to be optimized
-away.  Don't be tempted to write
-
-    when ("foo" or "bar") { ... }
-
-This will optimize down to C<"foo">, so C<"bar"> will never be considered (even
-though the rules say to use a smartmatch
-on C<"foo">).  For an alternation like
-this, an array ref will work, because this will instigate smartmatching:
-
-    when ([qw(foo bar)] { ... }
-
-This is somewhat equivalent to the C-style switch statement's fallthrough
-functionality (not to be confused with I<Perl's> fallthrough
-functionality--see below), wherein the same block is used for several
-C<case> statements.
-
-Another useful shortcut is that, if you use a literal array or hash as the
-argument to C<given>, it is turned into a reference.  So C<given(@foo)> is
-the same as C<given(\@foo)>, for example.
-
-C<default> behaves exactly like C<when(1 == 1)>, which is
-to say that it always matches.
-
 =head3 Breaking out
 
 You can use the C<break> keyword to break out of the enclosing
@@ -1183,60 +988,4 @@ interested in only the first match alone.
 This doesn't work if you explicitly specify a loop variable, as
 in C<for $item (@array)>.  You have to use the default variable C<$_>.
 
-=head3 Differences from Perl 6
-
-The Perl 5 smartmatch and C<given>/C<when> constructs are not compatible
-with their Perl 6 analogues.  The most visible difference and least
-important difference is that, in Perl 5, parentheses are required around
-the argument to C<given()> and C<when()> (except when this last one is used
-as a statement modifier).  Parentheses in Perl 6 are always optional in a
-control construct such as C<if()>, C<while()>, or C<when()>; they can't be
-made optional in Perl 5 without a great deal of potential confusion,
-because Perl 5 would parse the expression
-
-    given $foo {
-        ...
-    }
-
-as though the argument to C<given> were an element of the hash
-C<%foo>, interpreting the braces as hash-element syntax.
-
-However, their are many, many other differences.  For example,
-this works in Perl 5:
-
-    use v5.12;
-    my @primary = ("red", "blue", "green");
-
-    if (@primary ~~ "red") {
-        say "primary smartmatches red";
-    }
-
-    if ("red" ~~ @primary) {
-        say "red smartmatches primary";
-    }
-
-    say "that's all, folks!";
-
-But it doesn't work at all in Perl 6.  Instead, you should
-use the (parallelizable) C<any> operator:
-
-   if any(@primary) eq "red" {
-       say "primary smartmatches red";
-   }
-
-   if "red" eq any(@primary) {
-       say "red smartmatches primary";
-   }
-
-The table of smartmatches in L<perlop/"Smartmatch Operator"> is not
-identical to that proposed by the Perl 6 specification, mainly due to
-differences between Perl 6's and Perl 5's data models, but also because
-the Perl 6 spec has changed since Perl 5 rushed into early adoption.
-
-In Perl 6, C<when()> will always do an implicit smartmatch with its
-argument, while in Perl 5 it is convenient (albeit potentially confusing) to
-suppress this implicit smartmatch in various rather loosely-defined
-situations, as roughly outlined above.  (The difference is largely because
-Perl 5 does not have, even internally, a boolean type.)
-
 =cut
diff --git a/proto.h b/proto.h
index 94009ac..de88b79 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4737,9 +4737,6 @@ STATIC bool       S_is_handle_constructor(const OP *o, I32 numargs)
        assert(o)
 
 STATIC OP*     S_listkids(pTHX_ OP* o);
-STATIC bool    S_looks_like_bool(pTHX_ const OP* o);
-#define PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL       \
-       assert(o)
 STATIC OP*     S_modkids(pTHX_ OP *o, I32 type);
 STATIC void    S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV *name, bool curstash);
 #define PERL_ARGS_ASSERT_MOVE_PROTO_ATTR       \
index ec66413..16488c6 100644 (file)
@@ -8,7 +8,7 @@ Can't find label foo at - line 3.
 ########
 # NAME when outside given
 use 5.01; no warnings 'experimental::smartmatch';
-when(undef){}
+when(!defined){}
 EXPECT
 Can't "when" outside a topicalizer at - line 2.
 ########
index fac2538..700ae35 100644 (file)
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
-plan tests => 193;
+plan tests => 170;
 
 # The behaviour of the feature pragma should be tested by lib/feature.t
 # using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -60,9 +60,9 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 {    
     my $ok;
     given(3) {
-       when(2) { $ok = 'two'; }
-       when(3) { $ok = 'three'; }
-       when(4) { $ok = 'four'; }
+       when($_ == 2) { $ok = 'two'; }
+       when($_ == 3) { $ok = 'three'; }
+       when($_ == 4) { $ok = 'four'; }
        default { $ok = 'd'; }
     }
     is($ok, 'three', "numeric comparison");
@@ -72,9 +72,9 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
     my $ok;
     use integer;
     given(3.14159265) {
-       when(2) { $ok = 'two'; }
-       when(3) { $ok = 'three'; }
-       when(4) { $ok = 'four'; }
+       when($_ == 2) { $ok = 'two'; }
+       when($_ == 3) { $ok = 'three'; }
+       when($_ == 4) { $ok = 'four'; }
        default { $ok = 'd'; }
     }
     is($ok, 'three', "integer comparison");
@@ -83,9 +83,9 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 {    
     my ($ok1, $ok2);
     given(3) {
-       when(3.1)   { $ok1 = 'n'; }
-       when(3.0)   { $ok1 = 'y'; continue }
-       when("3.0") { $ok2 = 'y'; }
+       when($_ == 3.1)   { $ok1 = 'n'; }
+       when($_ == 3.0)   { $ok1 = 'y'; continue }
+       when($_ == "3.0") { $ok2 = 'y'; }
        default     { $ok2 = 'n'; }
     }
     is($ok1, 'y', "more numeric (pt. 1)");
@@ -95,9 +95,9 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 {
     my $ok;
     given("c") {
-       when("b") { $ok = 'B'; }
-       when("c") { $ok = 'C'; }
-       when("d") { $ok = 'D'; }
+       when($_ eq "b") { $ok = 'B'; }
+       when($_ eq "c") { $ok = 'C'; }
+       when($_ eq "d") { $ok = 'D'; }
        default   { $ok = 'def'; }
     }
     is($ok, 'C', "string comparison");
@@ -106,9 +106,9 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 {
     my $ok;
     given("c") {
-       when("b") { $ok = 'B'; }
-       when("c") { $ok = 'C'; continue }
-       when("c") { $ok = 'CC'; }
+       when($_ eq "b") { $ok = 'B'; }
+       when($_ eq "c") { $ok = 'C'; continue }
+       when($_ eq "c") { $ok = 'CC'; }
        default   { $ok = 'D'; }
     }
     is($ok, 'CC', "simple continue");
@@ -117,20 +117,8 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 # Definedness
 {
     my $ok = 1;
-    given (0) { when(undef) {$ok = 0} }
-    is($ok, 1, "Given(0) when(undef)");
-}
-{
-    my $undef;
-    my $ok = 1;
-    given (0) { when($undef) {$ok = 0} }
-    is($ok, 1, 'Given(0) when($undef)');
-}
-{
-    my $undef;
-    my $ok = 0;
-    given (0) { when($undef++) {$ok = 1} }
-    is($ok, 1, "Given(0) when($undef++)");
+    given (0) { when(!defined) {$ok = 0} }
+    is($ok, 1, "Given(0) when(!defined)");
 }
 {
     no warnings "uninitialized";
@@ -148,51 +136,26 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 ########
 {
     my $ok = 1;
-    given ("") { when(undef) {$ok = 0} }
-    is($ok, 1, 'Given("") when(undef)');
-}
-{
-    my $undef;
-    my $ok = 1;
-    given ("") { when($undef) {$ok = 0} }
-    is($ok, 1, 'Given("") when($undef)');
+    given ("") { when(!defined) {$ok = 0} }
+    is($ok, 1, 'Given("") when(!defined)');
 }
 {
     no warnings "uninitialized";
     my $ok = 1;
-    given (undef) { when("") {$ok = 0} }
-    is($ok, 1, 'Given(undef) when("")');
-}
-{
-    no warnings "uninitialized";
-    my $undef;
-    my $ok = 1;
-    given ($undef) { when("") {$ok = 0} }
-    is($ok, 1, 'Given($undef) when("")');
+    given (undef) { when(0) {$ok = 0} }
+    is($ok, 1, 'Given(undef) when(0)');
 }
 ########
 {
     my $ok = 0;
-    given (undef) { when(undef) {$ok = 1} }
-    is($ok, 1, "Given(undef) when(undef)");
-}
-{
-    my $undef;
-    my $ok = 0;
-    given (undef) { when($undef) {$ok = 1} }
-    is($ok, 1, 'Given(undef) when($undef)');
+    given (undef) { when(!defined) {$ok = 1} }
+    is($ok, 1, "Given(undef) when(!defined)");
 }
 {
     my $undef;
     my $ok = 0;
-    given ($undef) { when(undef) {$ok = 1} }
-    is($ok, 1, 'Given($undef) when(undef)');
-}
-{
-    my $undef;
-    my $ok = 0;
-    given ($undef) { when($undef) {$ok = 1} }
-    is($ok, 1, 'Given($undef) when($undef)');
+    given ($undef) { when(!defined) {$ok = 1} }
+    is($ok, 1, 'Given($undef) when(!defined)');
 }
 
 
@@ -401,7 +364,7 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
 {
     my $ok;
     given(23) {
-        when (scalar 24) { $ok = 'n'; continue }
+        when ($_ == scalar 24) { $ok = 'n'; continue }
         default { $ok = 'y' }
     }
     is($ok,'y','scalar()');
@@ -497,10 +460,10 @@ sub notfoo {"bar"}
     my $ok = 1;
     given("foo") {
        when((1 == 1) && "bar") {
-           $ok = 0;
+           $ok = 2;
        }
        when((1 == 1) && $_ eq "foo") {
-           $ok = 2;
+           $ok = 0;
        }
     }
     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
@@ -535,7 +498,7 @@ sub notfoo {"bar"}
            $ok = 1;
        }
     }
-    ok($ok, '((1 == $ok) || "foo") smartmatched');
+    ok($ok, '((1 == $ok) || "foo")');
 }
 
 {
@@ -545,7 +508,7 @@ sub notfoo {"bar"}
            $ok = 1;
        }
     }
-    ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
+    ok($ok, '((1 == $ok || undef) // "foo")');
 }
 
 # Make sure we aren't invoking the get-magic more than once
@@ -578,11 +541,11 @@ my $f = tie my $v, "FetchCounter";
 {   my $test_name = "Multiple FETCHes in given, due to aliasing";
     my $ok;
     given($v = 23) {
-       when(undef) {}
+       when(!defined) {}
        when(sub{0}->()) {}
-       when(21) {}
-       when("22") {}
-       when(23) {$ok = 1}
+       when($_ == 21) {}
+       when($_ == "22") {}
+       when($_ == 23) {$ok = 1}
        when(/24/) {$ok = 0}
     }
     is($ok, 1, "precheck: $test_name");
@@ -594,11 +557,11 @@ my $f = tie my $v, "FetchCounter";
     $v = 23;
     is($f->count(), 0, "Sanity check: $test_name");
     given(23) {
-       when(undef) {}
+       when(!defined) {}
        when(sub{0}->()) {}
-       when(21) {}
-       when("22") {}
-       when($v) {$ok = 1}
+       when($_ == 21) {}
+       when($_ == "22") {}
+       when($_ == $v) {$ok = 1}
        when(/24/) {$ok = 0}
     }
     is($ok, 1, "precheck: $test_name");
@@ -610,44 +573,28 @@ my $f = tie my $v, "FetchCounter";
     $v = "23";
     is($f->count(), 0, "Sanity check: $test_name");
     given("23") {
-       when(undef) {}
+       when(!defined) {}
        when(sub{0}->()) {}
-       when("21") {}
-       when("22") {}
-       when($v) {$ok = 1}
+       when($_ eq "21") {}
+       when($_ eq "22") {}
+       when($_ eq $v) {$ok = 1}
        when(/24/) {$ok = 0}
     }
     is($ok, 1, "precheck: $test_name");
     is($f->count(), 1, $test_name);
 }
 
-{   my $test_name = "Only one FETCH (undef)";
-    my $ok;
-    $v = undef;
-    is($f->count(), 0, "Sanity check: $test_name");
-    no warnings "uninitialized";
-    given(my $undef) {
-       when(sub{0}->()) {}
-       when("21")  {}
-       when("22")  {}
-       when($v)    {$ok = 1}
-       when(undef) {$ok = 0}
-    }
-    is($ok, 1, "precheck: $test_name");
-    is($f->count(), 1, $test_name);
-}
-
 # Loop topicalizer
 {
     my $first = 1;
     for (1, "two") {
-       when ("two") {
+       when ($_ eq "two") {
            is($first, 0, "Loop: second");
            eval {break};
            like($@, qr/^Can't "break" in a loop topicalizer/,
                q{Can't "break" in a loop topicalizer});
        }
-       when (1) {
+       when ($_ == 1) {
            is($first, 1, "Loop: first");
            $first = 0;
            # Implicit break is okay
@@ -658,13 +605,13 @@ my $f = tie my $v, "FetchCounter";
 {
     my $first = 1;
     for $_ (1, "two") {
-       when ("two") {
+       when ($_ eq "two") {
            is($first, 0, "Explicit \$_: second");
            eval {break};
            like($@, qr/^Can't "break" in a loop topicalizer/,
                q{Can't "break" in a loop topicalizer});
        }
-       when (1) {
+       when ($_ == 1) {
            is($first, 1, "Explicit \$_: first");
            $first = 0;
            # Implicit break is okay
@@ -681,8 +628,8 @@ my $f = tie my $v, "FetchCounter";
     sub bar {$called_bar = 1; "@_" eq "bar"}
     my ($matched_foo, $matched_bar) = (0, 0);
     given("foo") {
-       when(\&bar) {$matched_bar = 1}
-       when(\&foo) {$matched_foo = 1}
+       when((\&bar)->($_)) {$matched_bar = 1}
+       when((\&foo)->($_)) {$matched_foo = 1}
     }
     is($called_foo, 1,  "foo() was called");
     is($called_bar, 1,  "bar() was called");
@@ -699,7 +646,7 @@ sub contains_x {
     given("foxy!") {
        when(contains_x($_))
            { $ok1 = 1; continue }
-       when(\&contains_x)
+       when((\&contains_x)->($_))
            { $ok2 = 1; continue }
     }
     is($ok1, 1, "Calling sub directly (true)");
@@ -708,116 +655,40 @@ sub contains_x {
     given("foggy") {
        when(contains_x($_))
            { $ok1 = 2; continue }
-       when(\&contains_x)
+       when((\&contains_x)->($_))
            { $ok2 = 2; continue }
     }
     is($ok1, 1, "Calling sub directly (false)");
     is($ok2, 1, "Calling sub indirectly (false)");
 }
 
-SKIP: {
-    skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
-    # Test overloading
-    { package OverloadTest;
-
-      use overload '""' => sub{"string value of obj"};
-      use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
-
-      use overload "~~" => sub {
-         my ($self, $other, $reversed) = @_;
-         if ($reversed) {
-             $self->{left}  = $other;
-             $self->{right} = $self;
-             $self->{reversed} = 1;
-         } else {
-             $self->{left}  = $self;
-             $self->{right} = $other;
-             $self->{reversed} = 0;
-         }
-         $self->{called} = 1;
-         return $self->{retval};
-      };
-    
-      sub new {
-         my ($pkg, $retval) = @_;
-         bless {
-                called => 0,
-                retval => $retval,
-               }, $pkg;
-      }
-  }
-
-    {
-       my $test = "Overloaded obj in given (true)";
-       my $obj = OverloadTest->new(1);
-       my $matched;
-       given($obj) {
-           when ("other arg") {$matched = 1}
-           default {$matched = 0}
-       }
-    
-       is($obj->{called}, 1, "$test: called");
-       ok($matched, "$test: matched");
-    }
-
-    {
-       my $test = "Overloaded obj in given (false)";
-       my $obj = OverloadTest->new(0);
-       my $matched;
-       given($obj) {
-           when ("other arg") {$matched = 1}
-       }
-    
-       is($obj->{called}, 1, "$test: called");
-       ok(!$matched, "$test: not matched");
-    }
-
-    {
-       my $test = "Overloaded obj in when (true)";
-       my $obj = OverloadTest->new(1);
-       my $matched;
-       given("topic") {
-           when ($obj) {$matched = 1}
-           default {$matched = 0}
-       }
-    
-       is($obj->{called},  1, "$test: called");
-       ok($matched, "$test: matched");
-       is($obj->{left}, "topic", "$test: left");
-       is($obj->{right}, "string value of obj", "$test: right");
-       ok($obj->{reversed}, "$test: reversed");
-    }
-
-    {
-       my $test = "Overloaded obj in when (false)";
-       my $obj = OverloadTest->new(0);
-       my $matched;
-       given("topic") {
-           when ($obj) {$matched = 1}
-           default {$matched = 0}
-       }
-    
-       is($obj->{called}, 1, "$test: called");
-       ok(!$matched, "$test: not matched");
-       is($obj->{left}, "topic", "$test: left");
-       is($obj->{right}, "string value of obj", "$test: right");
-       ok($obj->{reversed}, "$test: reversed");
+{
+    my($ea, $eb, $ec) = (0, 0, 0);
+    my $r;
+    given(3) {
+       when(do { $ea++; $_ == 2 }) { $r = "two"; }
+       when(do { $eb++; $_ == 3 }) { $r = "three"; }
+       when(do { $ec++; $_ == 4 }) { $r = "four"; }
     }
+    is $r, "three", "evaluation count";
+    is $ea, 1, "evaluation count";
+    is $eb, 1, "evaluation count";
+    is $ec, 0, "evaluation count";
 }
 
 # Postfix when
 {
     my $ok;
     given (undef) {
-       $ok = 1 when undef;
+       $ok = 1 when !defined;
     }
-    is($ok, 1, "postfix undef");
+    is($ok, 1, "postfix !defined");
 }
 {
     my $ok;
     given (2) {
-       $ok += 1 when 7;
-       $ok += 2 when 9.1685;
+       $ok += 1 when $_ == 7;
+       $ok += 2 when $_ == 9.1685;
        $ok += 4 when $_ > 4;
        $ok += 8 when $_ < 2.5;
     }
@@ -828,7 +699,7 @@ SKIP: {
     given ("apple") {
        $ok = 1, continue when $_ eq "apple";
        $ok += 2;
-       $ok = 0 when "banana";
+       $ok = 0 when $_ eq "banana";
     }
     is($ok, 3, "postfix string");
 }
@@ -869,7 +740,7 @@ $letter = '';
 for ("a".."e") {
     given ($_) {
        $letter = $_;
-       when ("b") { last }
+       when ($_ eq "b") { last }
     }
     $letter = "z";
 }
@@ -879,7 +750,7 @@ $letter = '';
 LETTER1: for ("a".."e") {
     given ($_) {
        $letter = $_;
-       when ("b") { last LETTER1 }
+       when ($_ eq "b") { last LETTER1 }
     }
     $letter = "z";
 }
@@ -911,7 +782,7 @@ is($letter, "a,c,e,", "next LABEL in when");
     goto GIVEN1;
     $flag = 1;
     GIVEN1: given ($flag) {
-       when (0) { break; }
+       when ($_ == 0) { break; }
        $flag = 2;
     }
     is($flag, 0, "goto GIVEN1");
@@ -919,7 +790,7 @@ is($letter, "a,c,e,", "next LABEL in when");
 {
     my $flag = 0;
     given ($flag) {
-       when (0) { $flag = 1; }
+       when ($_ == 0) { $flag = 1; }
        goto GIVEN2;
        $flag = 2;
     }
@@ -929,7 +800,7 @@ GIVEN2:
 {
     my $flag = 0;
     given ($flag) {
-       when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
+       when ($_ == 0) { $flag = 1; goto GIVEN3; $flag = 2; }
        $flag = 3;
     }
 GIVEN3:
@@ -938,7 +809,7 @@ GIVEN3:
 {
     my $flag = 0;
     for ($flag) {
-       when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
+       when ($_ == 0) { $flag = 1; goto GIVEN4; $flag = 2; }
        $flag = 3;
     }
 GIVEN4:
@@ -948,8 +819,8 @@ GIVEN4:
     my $flag = 0;
 GIVEN5:
     given ($flag) {
-       when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
-       when (1) { break; }
+       when ($_ == 0) { $flag = 1; goto GIVEN5; $flag = 2; }
+       when ($_ == 1) { break; }
        $flag = 3;
     }
     is($flag, 1, "goto inside given and when to the given stmt");
@@ -972,8 +843,8 @@ unreified_check(undef,"");
     no warnings 'void';
     for (0, 1, 2) {
        my $scalar = do { given ($_) {
-           when (0) { $lexical }
-           when (2) { 'void'; 8, 9 }
+           when ($_ == 0) { $lexical }
+           when ($_ == 2) { 'void'; 8, 9 }
            @things;
        } };
        is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
@@ -986,8 +857,8 @@ unreified_check(undef,"");
     for (0, 1, 2) {
        no warnings 'void';
        my $scalar = do { given ($_) {
-           $lexical when 0;
-           8, 9     when 2;
+           $lexical when $_ == 0;
+           8, 9     when $_ == 2;
            6, 7;
        } };
        is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
@@ -999,7 +870,7 @@ unreified_check(undef,"");
     for (0, 1, 2) {
        my $scalar = do { given ($_) {
            no warnings 'void';
-           when (0) { 5 }
+           when ($_ == 0) { 5 }
            default  { 8, 9 }
            6, 7;
        } };
@@ -1012,8 +883,8 @@ unreified_check(undef,"");
     my @exp = ('3 4 5', '11 12 13', '8 9');
     for (0, 1, 2) {
        my @list = do { given ($_) {
-           when (0) { 3 .. 5 }
-           when (2) { my $fake = 'void'; 8, 9 }
+           when ($_ == 0) { 3 .. 5 }
+           when ($_ == 2) { my $fake = 'void'; 8, 9 }
            @things;
        } };
        is("@list", shift(@exp), "rvalue given - simple list [$_]");
@@ -1025,8 +896,8 @@ unreified_check(undef,"");
     my @exp = ('3 4 5', '6 7', '12');
     for (0, 1, 2) {
        my @list = do { given ($_) {
-           3 .. 5  when 0;
-           @things when 2;
+           3 .. 5  when $_ == 0;
+           @things when $_ == 2;
            6, 7;
        } };
        is("@list", shift(@exp), "rvalue given - postfix list [$_]");
@@ -1038,7 +909,7 @@ unreified_check(undef,"");
     my @exp = ('m o o', '8 10', '8 10');
     for (0, 1, 2) {
        my @list = do { given ($_) {
-           when (0) { "moo" =~ /(.)/g }
+           when ($_ == 0) { "moo" =~ /(.)/g }
            default  { 8, scalar(@things) }
            6, 7;
        } };
@@ -1051,8 +922,8 @@ unreified_check(undef,"");
     for (0, 1, 2, 3) {
        my @list = do { given ($_) {
            continue when $_ <= 1;
-           break    when 1;
-           next     when 2;
+           break    when $_ == 1;
+           next     when $_ == 2;
            6, 7;
        } };
        is("@list", shift(@exp), "rvalue given - default list [$_]");
@@ -1062,9 +933,9 @@ unreified_check(undef,"");
     # Context propagation
     my $smart_hash = sub {
        do { given ($_[0]) {
-           'undef' when undef;
-           when ([ 1 .. 3 ]) { 1 .. 3 }
-           when (4) { my $fake; do { 4, 5 } }
+           'undef' when !defined;
+           when ($_ >= 1 && $_ <= 3) { 1 .. 3 }
+           when ($_ == 4) { my $fake; do { 4, 5 } }
        } };
     };
 
@@ -1093,44 +964,6 @@ unreified_check(undef,"");
     @list = $smart_hash->(999);
     is("@list", '',      "rvalue given - list context propagation [999]");
 }
-{
-    # Array slices
-    my @list = 10 .. 15;
-    my @in_list;
-    my @in_slice;
-    for (5, 10, 15) {
-        given ($_) {
-            when (@list) {
-                push @in_list, $_;
-                continue;
-            }
-            when (@list[0..2]) {
-                push @in_slice, $_;
-            }
-        }
-    }
-    is("@in_list", "10 15", "when(array)");
-    is("@in_slice", "10", "when(array slice)");
-}
-{
-    # Hash slices
-    my %list = map { $_ => $_ } "a" .. "f";
-    my @in_list;
-    my @in_slice;
-    for ("a", "e", "i") {
-        given ($_) {
-            when (%list) {
-                push @in_list, $_;
-                continue;
-            }
-            when (@list{"a".."c"}) {
-                push @in_slice, $_;
-            }
-        }
-    }
-    is("@in_list", "a e", "when(hash)");
-    is("@in_slice", "a", "when(hash slice)");
-}
 
 { # RT#84526 - Handle magical TARG
     my $x = my $y = "aaa";
@@ -1161,19 +994,19 @@ unreified_check(undef,"");
            our $given_glob  = 5;
            local $given_loc = 6;
 
-           when (0) { 0 }
+           when ($_ == 0) { 0 }
 
-           when (1) { my $when_lex    = 1 }
-           when (2) { our $when_glob  = 2 }
-           when (3) { local $when_loc = 3 }
+           when ($_ == 1) { my $when_lex    = 1 }
+           when ($_ == 2) { our $when_glob  = 2 }
+           when ($_ == 3) { local $when_loc = 3 }
 
-           when (4) { $given_lex }
-           when (5) { $given_glob }
-           when (6) { $given_loc }
+           when ($_ == 4) { $given_lex }
+           when ($_ == 5) { $given_glob }
+           when ($_ == 6) { $given_loc }
 
-           when (7) { $ext_lex }
-           when (8) { $ext_glob }
-           when (9) { $ext_loc }
+           when ($_ == 7) { $ext_lex }
+           when ($_ == 8) { $ext_glob }
+           when ($_ == 9) { $ext_loc }
 
            'fallback';
        }
@@ -1255,10 +1088,10 @@ unreified_check(undef,"");
            my $res = do {
                given ($id) {
                    my $x;
-                   when (0) { Fmurrr->new($destroyed, 0) }
-                   when (1) { my $y = Fmurrr->new($destroyed, 1); break }
-                   when (2) { $x = Fmurrr->new($destroyed, 2); continue }
-                   when (2) { $x }
+                   when ($_ == 0) { Fmurrr->new($destroyed, 0) }
+                   when ($_ == 1) { my $y = Fmurrr->new($destroyed, 1); break }
+                   when ($_ == 2) { $x = Fmurrr->new($destroyed, 2); continue }
+                   when ($_ == 2) { $x }
                    default  { Fmurrr->new($destroyed, 3) }
                }
            };
@@ -1312,27 +1145,27 @@ unreified_check(undef,"");
 
     $i = 0;
     for (1..3) {
-        when (1) {$i +=    1 }
-        when (2) {$i +=   10 }
-        when (3) {$i +=  100 }
+        when ($_ == 1) {$i +=    1 }
+        when ($_ == 2) {$i +=   10 }
+        when ($_ == 3) {$i +=  100 }
         default { $i += 1000 }
     }
     is($i, 111, "when in for 1..3");
 
     $i = 0;
     for ('a'..'c') {
-        when ('a') {$i +=    1 }
-        when ('b') {$i +=   10 }
-        when ('c') {$i +=  100 }
+        when ($_ eq 'a') {$i +=    1 }
+        when ($_ eq 'b') {$i +=   10 }
+        when ($_ eq 'c') {$i +=  100 }
         default { $i += 1000 }
     }
     is($i, 111, "when in for a..c");
 
     $i = 0;
     for (1,2,3) {
-        when (1) {$i +=    1 }
-        when (2) {$i +=   10 }
-        when (3) {$i +=  100 }
+        when ($_ == 1) {$i +=    1 }
+        when ($_ == 2) {$i +=   10 }
+        when ($_ == 3) {$i +=  100 }
         default { $i += 1000 }
     }
     is($i, 111, "when in for 1,2,3");
@@ -1340,9 +1173,9 @@ unreified_check(undef,"");
     $i = 0;
     my @a = (1,2,3);
     for (@a) {
-        when (1) {$i +=    1 }
-        when (2) {$i +=   10 }
-        when (3) {$i +=  100 }
+        when ($_ == 1) {$i +=    1 }
+        when ($_ == 2) {$i +=   10 }
+        when ($_ == 3) {$i +=  100 }
         default { $i += 1000 }
     }
     is($i, 111, 'when in for @a');
diff --git a/t/op/when.t b/t/op/when.t
new file mode 100644 (file)
index 0000000..62f0bcd
--- /dev/null
@@ -0,0 +1,180 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib');
+}
+
+use strict;
+use warnings;
+no warnings 'experimental::smartmatch';
+
+plan tests => 39;
+
+foreach(3) {
+    CORE::when(3) {
+       pass "CORE::when without feature flag";
+    }
+}
+
+use feature 'switch';
+
+foreach(3) {
+    CORE::when(3) {
+       pass "CORE::when with feature flag";
+    }
+}
+
+foreach(3) {
+    when(3) {
+       pass "when with feature flag";
+    }
+}
+
+foreach(0, 1) {
+    my $x = "foo";
+    is($x, "foo", "when lexical scope not started yet");
+    when(my $x = ($_ && "bar")) {
+       is($x, "bar", "when lexical scope starts");
+    }
+    is($x, "foo", "when lexical scope ends");
+}
+
+foreach(3) {
+    when($_ == 2) { fail; }
+    pass;
+}
+
+foreach(3) {
+    when($_ == 3) { pass; }
+    fail;
+}
+
+foreach(3) {
+    when($_ == 2) { fail; }
+    when($_ == 3) { pass; }
+    when($_ == 4) { fail; }
+    when($_ == 3) { fail; }
+}
+
+foreach(undef, 3) {
+    when(undef) { fail; }
+    pass;
+}
+
+foreach(undef, 1, 3) {
+    when(0) { fail; }
+    pass;
+}
+
+foreach(undef, 1, 3) {
+    when(1) { pass; }
+    fail;
+}
+
+sub is_list_context { wantarray }
+sub is_scalar_context { !wantarray && defined(wantarray) }
+sub is_void_context { !defined(wantarray) }
+foreach(3) {
+    when(is_list_context()) { fail; }
+    pass;
+}
+foreach(3) {
+    when(is_scalar_context()) { pass; }
+    fail;
+}
+foreach(3) {
+    when(is_void_context()) { fail; }
+    pass;
+}
+foreach(3) {
+    when(is_list_context) { fail; }
+    pass;
+}
+foreach(3) {
+    when(is_scalar_context) { pass; }
+    fail;
+}
+foreach(3) {
+    when(is_void_context) { fail; }
+    pass;
+}
+
+my $ps = "foo";
+foreach(3) {
+    when($ps) { pass; }
+    fail;
+}
+$ps = "";
+foreach(3) {
+    when($ps) { fail; }
+    pass;
+}
+our $gs = "bar";
+foreach(3) {
+    when($gs) { pass; }
+    fail;
+}
+$gs = "";
+foreach(3) {
+    when($gs) { fail; }
+    pass;
+}
+my @pa = qw(a b c d e);
+foreach(3) {
+    when(@pa) { pass; }
+    fail;
+}
+@pa = ();
+foreach(3) {
+    when(@pa) { fail; }
+    pass;
+}
+our @ga = qw(a b c d e);
+foreach(3) {
+    when(@ga) { pass; }
+    fail;
+}
+@ga = ();
+foreach(3) {
+    when(@ga) { fail; }
+    pass;
+}
+my %ph = qw(a b c d e f g h i j);
+foreach(3) {
+    when(%ph) { pass; }
+    fail;
+}
+%ph = ();
+foreach(3) {
+    when(%ph) { fail; }
+    pass;
+}
+our %gh = qw(a b c d e f g h i j);
+foreach(3) {
+    when(%gh) { pass; }
+    fail;
+}
+%gh = ();
+foreach(3) {
+    when(%gh) { fail; }
+    pass;
+}
+
+my $one = 1;
+foreach(3) {
+    when($one + 3) { pass; }
+    fail;
+}
+foreach(3) {
+    when($one - 1) { fail; }
+    pass;
+}
+
+foreach(3) {
+    when(()) { fail; }
+    pass;
+}
+
+1;
index 0ce0af7..c293c64 100644 (file)
@@ -653,7 +653,7 @@ $r = runperl(
 is( $r, "Hello, world!\n", "-E ~~" );
 
 $r = runperl(
-    switches   => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(undef) { say q(Hello, world!)"}}']
+    switches   => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(!defined) { say q(Hello, world!)"}}']
 );
 is( $r, "Hello, world!\n", "-E given" );