From c07656ed340bbe7027cae47dc3a85a51910f9d07 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 1 Jul 2012 22:53:41 -0700
Subject: Make &foo respect our sub
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This changes &foo to go through S_pending_ident (by setting
PL_pending_ident, which causes yylex to defer to S_pending_ident for
the next token) the way $foo and %foo do.

This necessitated reducing the maximum identifier length of &foo from
252 to 251, making it match @foo, $foo, etc.  So somebody’s JAPH might
break. :-)
---
 MANIFEST        |  1 +
 t/cmd/lexsub.t  | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/comp/parser.t |  6 ++---
 toke.c          |  8 ++++---
 4 files changed, 79 insertions(+), 6 deletions(-)
 create mode 100644 t/cmd/lexsub.t

diff --git a/MANIFEST b/MANIFEST
index 46f29a7669..6883a5f76f 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4994,6 +4994,7 @@ t/bigmem/read.t			Check read() handles large offsets
 t/bigmem/vec.t			Check vec() handles large offsets
 t/cmd/elsif.t			See if else-if works
 t/cmd/for.t			See if for loops work
+t/cmd/lexsub.t			See if lexical subroutines work
 t/cmd/mod.t			See if statement modifiers work
 t/cmd/subval.t			See if subroutine values work
 t/cmd/switch.t			See if switch optimizations work
diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
new file mode 100644
index 0000000000..6dd5059c36
--- /dev/null
+++ b/t/cmd/lexsub.t
@@ -0,0 +1,70 @@
+#!perl
+
+print "1..14\n";
+
+{
+  our sub foo { 42 }
+  print "not " unless foo == 42;
+  print "ok 1 - calling our sub from same package\n";
+  print "not " unless &foo == 42;
+  print "ok 2 - calling our sub from same package (amper)\n";
+  package bar;
+  sub bar::foo { 43 }
+  print "not " unless foo == 42;
+  print "ok 3 - calling our sub from another package # TODO\n";
+  print "not " unless &foo == 42;
+  print "ok 4 - calling our sub from another package (amper)\n";
+}
+package bar;
+print "not " unless foo == 43;
+print "ok 5 - our sub falling out of scope\n";
+print "not " unless &foo == 43;
+print "ok 6 - our sub falling out of scope (called via amper)\n";
+package main;
+{
+  sub bar::a { 43 }
+  our sub a {
+    if (shift) {
+      package bar;
+      print "not " unless a == 43;
+      print "ok 7 - our sub invisible inside itself\n";
+      print "not " unless &a == 43;
+      print "ok 8 - our sub invisible inside itself (called via amper)\n";
+    }
+    42
+  }
+  a(1);
+  sub bar::b { 43 }
+  our sub b;
+  our sub b {
+    if (shift) {
+      package bar;
+      print "not " unless b == 42;
+      print "ok 9 - our sub visible inside itself after decl # TODO\n";
+      print "not " unless &b == 42;
+      print "ok 10 - our sub visible inside itself after decl (amper)\n";
+    }
+    42
+  }
+  b(1)
+}
+sub c { 42 }
+sub bar::c { 43 }
+{
+  our sub c;
+  package bar;
+  print "not " unless c == 42;
+  print "ok 11 - our sub foo; makes lex alias for existing sub # TODO\n";
+  print "not " unless &c == 42;
+  print "ok 12 - our sub foo; makes lex alias for existing sub (amper)\n";
+}
+{
+  our sub d;
+  sub d { 'd42' }
+  sub bar::d { 'd43' }
+  package bar;
+  print "not " unless d eq 'd42';
+  print "ok 13 - our sub foo; applies to subsequent sub foo {} # TODO\n";
+  print "not " unless &d eq 'd42';
+  print "ok 14 - our sub foo; applies to subsequent sub foo {} (amper)\n";
+}
diff --git a/t/comp/parser.t b/t/comp/parser.t
index a5ba93cd2e..a0f9a0c73b 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -318,9 +318,9 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' );
   eval qq[ %$xFC ];
   like($@, qr/Identifier too long/, "too long id in % sigil ctx");
 
-  eval qq[ \\&$xFC ]; # take a ref since I don't want to call it
-  is($@, "", "252 character & sigil ident ok");
-  eval qq[ \\&$xFD ];
+  eval qq[ \\&$xFB ]; # take a ref since I don't want to call it
+  is($@, "", "251 character & sigil ident ok");
+  eval qq[ \\&$xFC ];
   like($@, qr/Identifier too long/, "too long id in & sigil ctx");
 
   eval qq[ *$xFC ];
diff --git a/toke.c b/toke.c
index 568e6186f2..1a82259553 100644
--- a/toke.c
+++ b/toke.c
@@ -5987,10 +5987,12 @@ Perl_yylex(pTHX)
 	    BAop(OP_BIT_AND);
 	}
 
-	s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
-	if (*PL_tokenbuf) {
+	PL_tokenbuf[0] = '&';
+	s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
+		       sizeof PL_tokenbuf - 1, TRUE);
+	if (PL_tokenbuf[1]) {
 	    PL_expect = XOPERATOR;
-	    force_ident(PL_tokenbuf, '&');
+	    PL_pending_ident = '&';
 	}
 	else
 	    PREREF('&');
-- 
cgit v1.2.1