This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Stop barewords from trumping subs with (*) proto
authorFather Chrysostomos <sprout@cpan.org>
Tue, 9 Sep 2014 05:37:46 +0000 (22:37 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 9 Sep 2014 05:37:46 +0000 (22:37 -0700)
The splat prototype was allowing barewords to take precedence over
sub calls, if those sub calls did not parenthesize the argument list.

But it was rather buggy and inconsistent:

$ perl -le 'sub splat(*){print @_} sub foo; splat main::foo'
foo

What happened to main::?

$ perl -le 'package Foo; sub splat(*){print @_} sub foo; splat foo'
Foo::foo

Where did the prefix come from?

And constant subroutines were exempt from this, but whether a subrou-
tine is constant may change between versions:

$ perl5.14.4 -le 'sub splat(*){print @_} sub foo(){"x"x3}; splat foo'
foo
$ perl5.18.1 -le 'sub splat(*){print @_} sub foo(){"x"x3}; splat foo'
xxx

because infix x is now subject to constant folding.

Also:

$ perl5.18.1 -le 'sub splat(*){print @_} BEGIN {$::{foo}=*bar}sub bar; splat foo'
bar

I know this is a naughty example, because it’s fiddling with the sym-
bol table, but if the splat gets confused by that, then something is
quite wrong with its implementation.

Furthermore, one of the stated purposes of prototypes is to enable
custom subroutines to mimic the syntax of built-in functions.  But
*all* the built-in functions that take filehandles allow subroutines
to take precedence over barewords.

This commit allows all subroutines as arguments to the * prototype
to take precedence over barewords, just as constant subroutines
have till now.

This also fixes #35129, because the mechanism that was accidentally
swallowing arguments is now gone.

op.c
t/comp/proto.t

diff --git a/op.c b/op.c
index c1f16bd..0c6f11e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10292,32 +10292,6 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                    goto wrapref;       /* autoconvert GLOB -> GLOBref */
                else if (o3->op_type == OP_CONST)
                    o3->op_private &= ~OPpCONST_STRICT;
-               else if (o3->op_type == OP_ENTERSUB) {
-                   /* accidental subroutine, revert to bareword */
-                   OP *gvop = ((UNOP*)o3)->op_first;
-                   if (gvop && gvop->op_type == OP_NULL) {
-                       gvop = ((UNOP*)gvop)->op_first;
-                       if (gvop) {
-                           for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
-                               ;
-                           if (gvop &&
-                                   (gvop->op_private & OPpENTERSUB_NOPAREN) &&
-                                   (gvop = ((UNOP*)gvop)->op_first) &&
-                                   gvop->op_type == OP_GV)
-                           {
-                                OP * newop;
-                               GV * const gv = cGVOPx_gv(gvop);
-                               SV * const n = newSVpvs("");
-                               gv_fullname4(n, gv, "", FALSE);
-                                /* replace the aop subtree with a const op */
-                               newop = newSVOP(OP_CONST, 0, n);
-                                op_sibling_splice(parent, prev, 1, newop);
-                               op_free(aop);
-                                aop = newop;
-                           }
-                       }
-                   }
-               }
                scalar(aop);
                break;
            case '+':
index 47ebf74..f984aaf 100644 (file)
@@ -500,11 +500,11 @@ star(\*FOO, sub {
        print "ok $i - star(\\*FOO)\n";
     }); $i++;
 star2 FOO, BAR, sub {
-    print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
+    print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
     print "ok $i - star2 FOO, BAR\n";
 }; $i++;
 star2(Bar::BAZ, FOO, sub {
-       print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO';
+       print "not " unless $_[0] eq 'quuz' and $_[1] eq 'FOO';
        print "ok $i - star2(Bar::BAZ, FOO)\n"
     }); $i++;
 star2 BAR(), FOO, sub {