From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Tue, 17 Oct 2006 16:07:04 +0000 (+0000)
Subject: First attempt at implementing the _ prototype
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b13fd70a68ddf5966a8175e04009af31c9841332;p=p5sagit%2Fp5-mst-13.2.git

First attempt at implementing the _ prototype

p4raw-id: //depot/perl@29032
---

diff --git a/MANIFEST b/MANIFEST
index 3a2cbb5..736f44e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3163,6 +3163,7 @@ t/comp/redef.t			See if we get correct warnings on redefined subs
 t/comp/require.t		See if require works
 t/comp/script.t			See if script invocation works
 t/comp/term.t			See if more terms work
+t/comp/uproto.t			See if the _ prototype works
 t/comp/use.t			See if pragmata work
 t/comp/utf.t			See if UTFs work
 t/harness			Finer diagnostics from test suite
diff --git a/op.c b/op.c
index fbe455e..711aa24 100644
--- a/op.c
+++ b/op.c
@@ -7375,6 +7375,7 @@ Perl_ck_subr(pTHX_ OP *o)
 		optional = 1;
 		proto++;
 		continue;
+	    case '_':
 	    case '$':
 		proto++;
 		arg++;
@@ -7533,6 +7534,12 @@ 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 (proto && !optional && proto_end > proto &&
 	(*proto != '@' && *proto != '%' && *proto != ';'))
diff --git a/t/comp/uproto.t b/t/comp/uproto.t
new file mode 100644
index 0000000..ba7dcd6
--- /dev/null
+++ b/t/comp/uproto.t
@@ -0,0 +1,36 @@
+#!perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require "./test.pl";
+}
+
+plan(tests => 14);
+
+sub f($$_) { my $x = shift; is("@_", $x) }
+
+$foo = "FOO";
+my $bar = "BAR";
+$_ = 42;
+
+f("FOO xy", $foo, "xy");
+f("BAR zt", $bar, "zt");
+f("FOO 42", $foo);
+f("BAR 42", $bar);
+f("y 42", substr("xy",1,1));
+f("1 42", ("abcdef" =~ /abc/));
+f("not undef 42", $undef || "not undef");
+f(" 42", -f "no_such_file");
+f("FOOBAR 42", ($foo . $bar));
+f("FOOBAR 42", ($foo .= $bar));
+f("FOOBAR 42", $foo);
+
+eval q{ f("foo") };
+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/ );
+
+&f(""); # no error
+
+# TODO: sub g(_) (doesn't work)
diff --git a/toke.c b/toke.c
index f9e79fc..0629099 100644
--- a/toke.c
+++ b/toke.c
@@ -6580,7 +6580,7 @@ Perl_yylex(pTHX)
 		    for (p = d; *p; ++p) {
 			if (!isSPACE(*p)) {
 			    d[tmp++] = *p;
-			    if (warnsyntax && !strchr("$@%*;[]&\\", *p))
+			    if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
 				bad_proto = TRUE;
 			}
 		    }