Improvements and fixes to the _ prototype

p4raw-id: //depot/perl@29035

diff --git a/op.c b/op.c
index 711aa24..eb14e03 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7534,15 +7534,15 @@ Perl_ck_subr(pTHX_ OP *o)
        mod(o2, OP_ENTERSUB);
        prev = o2;
        o2 = o2->op_sibling;
-       if (o2 && o2->op_type == OP_NULL && proto && *proto == '_') {
-           /* generate an access to $_ */
-           o2 = newDEFSVOP();
-           o2->op_sibling = prev->op_sibling;
-           prev->op_sibling = o2; /* instead of cvop */
-       }
     } /* while */
+    if (o2 == cvop && proto && *proto == '_') {
+       /* generate an access to $_ */
+       o2 = newDEFSVOP();
+       o2->op_sibling = prev->op_sibling;
+       prev->op_sibling = o2; /* instead of cvop */
+    }
     if (proto && !optional && proto_end > proto &&
-       (*proto != '@' && *proto != '%' && *proto != ';'))
+       (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
        return too_few_arguments(o, gv_ename(namegv));
     if(delete_op) {
 #ifdef PERL_MAD

diff --git a/t/comp/uproto.t b/t/comp/uproto.t
index ba7dcd6..16c748a 100644 (file)
--- a/t/comp/uproto.t
+++ b/t/comp/uproto.t
@@ -6,7 +6,7 @@ BEGIN {
     require "./test.pl";
 }
 
-plan(tests => 14);
+plan(tests => 28);
 
 sub f($$_) { my $x = shift; is("@_", $x) }
 
@@ -31,6 +31,29 @@ like( $@, qr/Not enough arguments for main::f at/ );
 eval q{ f(1,2,3,4) };
 like( $@, qr/Too many arguments for main::f at/ );
 
+{
+    my $_ = "quarante-deux";
+    $foo = "FOO";
+    $bar = "BAR";
+    f("FOO quarante-deux", $foo);
+    f("BAR quarante-deux", $bar);
+    f("y quarante-deux", substr("xy",1,1));
+    f("1 quarante-deux", ("abcdef" =~ /abc/));
+    f("not undef quarante-deux", $undef || "not undef");
+    f(" quarante-deux", -f "no_such_file");
+    f("FOOBAR quarante-deux", ($foo . $bar));
+    f("FOOBAR quarante-deux", ($foo .= $bar));
+    f("FOOBAR quarante-deux", $foo);
+}
+
 &f(""); # no error
 
-# TODO: sub g(_) (doesn't work)
+sub g(_) { is(shift, $expected) }
+
+$expected = "foo";
+g("foo");
+g($expected);
+$_ = $expected;
+g();
+undef $expected; &g; # $_ not passed
+{ $expected = my $_ = "bar"; g() }