This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regularise "given"
authorZefram <zefram@fysh.org>
Tue, 21 Nov 2017 13:17:03 +0000 (13:17 +0000)
committerZefram <zefram@fysh.org>
Tue, 21 Nov 2017 13:23:28 +0000 (13:23 +0000)
Change "given" from implicitly enreferencing array and hash topics to just
giving the topic scalar context.  It's difficult to say whether this is a
change of the intended behaviour or merely a bugfix, because the implicit
enreferencement was not documented, and there were no tests exercising it.
The documentation merely said that the argument is in scalar context,
which correctly describes the new behaviour.  Add a documentation note
about the old behaviour, alongside the existing notes about historical
given/when behaviour.  Incidentally fix doc that referred to assiging
to $_, to instead refer to aliasing.  Add tests for "given".

MANIFEST
op.c
pod/perlsyn.pod
t/op/given.t [new file with mode: 0644]

index 778521b..db8b651 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5664,6 +5664,7 @@ t/op/fork.t                       See if fork works
 t/op/fresh_perl_utf8.t         UTF8 tests for pads and gvs
 t/op/getpid.t                  See if $$ and getppid work with threads
 t/op/getppid.t                 See if getppid works
+t/op/given.t                   See if given works
 t/op/glob.t                    See if <*> works
 t/op/gmagic.t                  See if GMAGIC works
 t/op/goto.t                    See if goto works
diff --git a/op.c b/op.c
index 8a185a1..23f25db 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8952,11 +8952,7 @@ Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
     PERL_UNUSED_ARG(defsv_off);
 
     assert(!defsv_off);
-    return newGIVWHENOP(
-       ref_array_or_hash(cond),
-       block,
-       OP_ENTERGIVEN, OP_LEAVEGIVEN,
-       0);
+    return newGIVWHENOP(cond, block, OP_ENTERGIVEN, OP_LEAVEGIVEN, 0);
 }
 
 /*
index efe4a26..80eca0a 100644 (file)
@@ -672,7 +672,8 @@ Or if you don't care to play it safe, like this:
     }
 
 The arguments to C<given> and C<when> are in scalar context,
-and C<given> assigns the C<$_> variable its topic value.
+and C<given> aliases the C<$_> variable to the result of evaluating its
+topic expression.
 
 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
@@ -909,7 +910,7 @@ 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.18, C<given> also had tricky behaviours that you should still
+Before Perl 5.28, C<given> also had tricky behaviours that you should still
 beware of if your code must run on older versions of Perl.
 
 Here is a longer example of C<given>:
@@ -950,6 +951,10 @@ 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
diff --git a/t/op/given.t b/t/op/given.t
new file mode 100644 (file)
index 0000000..ff7ee75
--- /dev/null
@@ -0,0 +1,134 @@
+#!./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;
+
+CORE::given(3) {
+    pass "CORE::given without feature flag";
+}
+
+use feature 'switch';
+
+CORE::given(3) {
+    pass "CORE::given with feature flag";
+}
+
+given(3) {
+    pass "given with feature flag";
+}
+
+{
+    my $x = "foo";
+    is($x, "foo", "given lexical scope not started yet");
+    given(my $x = "bar") {
+       is($x, "bar", "given lexical scope starts");
+    }
+    is($x, "foo", "given lexical scope ends");
+}
+
+sub topic_is ($@) { is $_, shift, @_ }
+{
+    local $_ = "foo";
+    is $_, "foo", "given dynamic scope not started yet";
+    topic_is "foo", "given dynamic scope not started yet";
+    given("bar") {
+       is $_, "bar", "given dynamic scope starts";
+       topic_is "bar", "given dynamic scope starts";
+    }
+    is $_, "foo", "given dynamic scope ends";
+    topic_is "foo", "given dynamic scope ends";
+}
+
+given(undef) {
+    is $_, undef, "folded undef topic value";
+    is \$_, \undef, "folded undef topic identity";
+}
+given(1 < 3) {
+    is $_, !!1, "folded true topic value";
+    is \$_, \!!1, "folded true topic identity";
+}
+given(1 > 3) {
+    is $_, !!0, "folded false topic value";
+    is \$_, \!!0, "folded false topic identity";
+}
+my $one = 1;
+given($one && undef) {
+    is $_, undef, "computed undef topic value";
+    is \$_, \undef, "computed undef topic identity";
+}
+given($one < 3) {
+    is $_, !!1, "computed true topic value";
+    is \$_, \!!1, "computed true topic identity";
+}
+given($one > 3) {
+    is $_, !!0, "computed false topic value";
+    is \$_, \!!0, "computed false topic identity";
+}
+
+sub which_context {
+    return wantarray ? "list" : defined(wantarray) ? "scalar" : "void";
+}
+given(which_context) {
+    is $_, "scalar", "topic sub called without parens";
+}
+given(which_context()) {
+    is $_, "scalar", "topic sub called with parens";
+}
+
+my $ps = "foo";
+given($ps) {
+    is $_, "foo", "padsv topic value";
+    is \$_, \$ps, "padsv topic identity";
+}
+our $gs = "bar";
+given($gs) {
+    is $_, "bar", "gvsv topic value";
+    is \$_, \$gs, "gvsv topic identity";
+}
+my @pa = qw(a b c d e);
+given(@pa) {
+    is $_, 5, "padav topic";
+}
+our @ga = qw(x y z);
+given(@ga) {
+    is $_, 3, "gvav topic";
+}
+my %ph = qw(a b c d e f g h i j);
+given(%ph) {
+    is $_, 5, "padhv topic";
+}
+our %gh = qw(u v w x y z);
+given(%gh) {
+    is $_, 3, "gvhv topic";
+}
+
+given($one + 3) {
+    is $_, 4, "general computed topic";
+}
+
+is join(",", 111, 222,
+    do {
+       no warnings "void";
+       given($one, 22, $one, 33) {
+           is $_, 33, "list topic";
+           (1111, 2222);
+       }
+    },
+    333, 444,
+), "111,222,1111,2222,333,444", "stack discipline";
+
+given(()) {
+    is $_, undef, "stub topic value";
+    is \$_, \undef, "stub topic identity";
+}
+
+1;