From 18f703895eca8c44a852a7e191cb3fdbb65d6891 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Wed, 4 Jul 2012 23:18:32 -0700
Subject: Let barewords look up our subs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

These take precedence over built-in keywords (just as my $AUTOLOAD
shadows the package var), but not the keyword plugin, as the latter
takes precedence over labels, and these don’t.
---
 toke.c | 37 ++++++++++++++++++++++++++++++++++---
 1 file changed, 34 insertions(+), 3 deletions(-)

(limited to 'toke.c')

diff --git a/toke.c b/toke.c
index 901ebe9f0a..f93d96e41c 100644
--- a/toke.c
+++ b/toke.c
@@ -6599,9 +6599,13 @@ Perl_yylex(pTHX)
 
       keylookup: {
 	bool anydelim;
+	bool lex;
 	I32 tmp;
+	SV *sv;
 
+	lex = FALSE;
 	orig_keyword = 0;
+	sv = NULL;
 	gv = NULL;
 	gvp = NULL;
 
@@ -6670,6 +6674,31 @@ Perl_yylex(pTHX)
 	    TOKEN(LABEL);
 	}
 
+	/* Check for lexical sub */
+	if (PL_expect != XOPERATOR) {
+	    char tmpbuf[sizeof PL_tokenbuf + 1];
+	    PADOFFSET off;
+	    *tmpbuf = '&';
+	    Copy(PL_tokenbuf, tmpbuf+1, len, char);
+	    off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
+	    if (off != NOT_IN_PAD) {
+		if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+		    HV *  const stash = PAD_COMPNAME_OURSTASH(off);
+		    HEK * const stashname = HvNAME_HEK(stash);
+		    sv = newSVhek(stashname);
+                    sv_catpvs(sv, "::");
+                    sv_catpvn_flags(sv, PL_tokenbuf, len,
+				    (UTF ? SV_CATUTF8 : SV_CATBYTES));
+		    gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
+				    SVt_PVCV);
+		    lex = TRUE;
+		    goto just_a_word;
+		}
+		/* unreachable */
+		else Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+	    }
+	}
+
 	if (tmp < 0) {			/* second-class keyword? */
 	    GV *ogv = NULL;	/* override (winner) */
 	    GV *hgv = NULL;	/* hidden (loser) */
@@ -6732,9 +6761,10 @@ Perl_yylex(pTHX)
 		gv = NULL;
 		gvp = NULL;
 		orig_keyword = 0;
+		lex = 0;
+		off = 0;
 	    }
 	  just_a_word: {
-		SV *sv;
 		int pkgname = 0;
 		const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
 		OP *rv2cv_op;
@@ -6802,7 +6832,8 @@ Perl_yylex(pTHX)
 
 		/* if we saw a global override before, get the right name */
 
-		sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
+		if (!lex)
+		  sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
 		    len ? len : strlen(PL_tokenbuf));
 		if (gvp) {
 		    SV * const tmp_sv = sv;
@@ -6833,7 +6864,7 @@ Perl_yylex(pTHX)
 		    const_op->op_private = OPpCONST_BARE;
 		    rv2cv_op = newCVREF(0, const_op);
 		}
-		cv = rv2cv_op_cv(rv2cv_op, 0);
+		cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
 
 		/* See if it's the indirect object for a list operator. */
 
-- 
cgit v1.2.1