function to parse isolated label

New API function parse_label() parses a label, separate from statements.
If a label has not already been lexed and queued up, it does not use
yylex(), but parses the label itself at the character level, to avoid
unwanted lexing past an absent optional label.

12 files changed, 417 insertions, 6 deletions

diff --git a/MANIFEST b/MANIFEST
index 31bf3e8b29..a69f37a30e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3398,6 +3398,8 @@ ext/XS-APItest/t/grok.t		XS::APItest: tests for grok* functions
 ext/XS-APItest/t/hash.t		XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/keyword_multiline.t	test keyword plugin parsing across lines
 ext/XS-APItest/t/keyword_plugin.t	test keyword plugin mechanism
+ext/XS-APItest/t/labelconst.aux	auxiliary file for label test
+ext/XS-APItest/t/labelconst.t	test recursive descent label parsing
 ext/XS-APItest/t/loopblock.t	test recursive descent block parsing
 ext/XS-APItest/t/looprest.t	test recursive descent statement-sequence parsing
 ext/XS-APItest/t/magic_chain.t	test low-level MAGIC chain handling
@@ -3425,6 +3427,7 @@ ext/XS-APItest/t/stuff_svcur_bug.t	test for a bug in lex_stuff_pvn
 ext/XS-APItest/t/svpeek.t	XS::APItest extension
 ext/XS-APItest/t/svpv_magic.t	Test behaviour of SvPVbyte and get magic
 ext/XS-APItest/t/svsetsv.t	Test behaviour of sv_setsv with/without PERL_CORE
+ext/XS-APItest/t/swaplabel.t	test recursive descent label parsing
 ext/XS-APItest/t/swaptwostmts.t	test recursive descent statement parsing
 ext/XS-APItest/t/temp_lv_sub.t	XS::APItest: tests for lvalue subs returning temps
 ext/XS-APItest/t/utf16_to_utf8.t	Test behaviour of utf16_to_utf8{,reversed}
diff --git a/embed.fnc b/embed.fnc
index 43d2a17c7d..340d86d635 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -625,6 +625,7 @@ AMpd	|void	|lex_read_space	|U32 flags
 : Public parser API
 AMpd	|OP*	|parse_block	|U32 flags
 AMpd	|OP*	|parse_barestmt	|U32 flags
+AMpd	|SV*	|parse_label	|U32 flags
 AMpd	|OP*	|parse_fullstmt	|U32 flags
 AMpd	|OP*	|parse_stmtseq	|U32 flags
 : Used in various files
diff --git a/embed.h b/embed.h
index 921f8c58ab..5db82375f1 100644
--- a/embed.h
+++ b/embed.h
@@ -379,6 +379,7 @@
 #define parse_barestmt(a)	Perl_parse_barestmt(aTHX_ a)
 #define parse_block(a)		Perl_parse_block(aTHX_ a)
 #define parse_fullstmt(a)	Perl_parse_fullstmt(aTHX_ a)
+#define parse_label(a)		Perl_parse_label(aTHX_ a)
 #define parse_stmtseq(a)	Perl_parse_stmtseq(aTHX_ a)
 #define pmop_dump(a)		Perl_pmop_dump(aTHX_ a)
 #define pop_scope()		Perl_pop_scope(aTHX)
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index c4b3433696..e4b7fa22a2 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -36,7 +36,7 @@ sub import {
 	}
     }
     foreach (keys %{$exports||{}}) {
-	next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr)\z/;
+	next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst)\z/;
 	$^H{"XS::APItest/$_"} = 1;
 	delete $exports->{$_};
     }
@@ -50,7 +50,7 @@ sub import {
     }
 }
 
-our $VERSION = '0.24';
+our $VERSION = '0.25';
 
 use vars '$WARNINGS_ON_BOOTSTRAP';
 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 5be2c36f12..a3f19ea220 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -568,6 +568,7 @@ static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
 static SV *hintkey_scopelessblock_sv;
 static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
 static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
+static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 
 /* low-level parser helpers */
@@ -804,6 +805,21 @@ static OP *THX_parse_keyword_blockasexpr(pTHX)
     return o;
 }
 
+#define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
+static OP *THX_parse_keyword_swaplabel(pTHX)
+{
+    OP *sop = parse_barestmt(0);
+    SV *label = parse_label(PARSE_OPTIONAL);
+    if (label) sv_2mortal(label);
+    return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop);
+}
+
+#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
+static OP *THX_parse_keyword_labelconst(pTHX)
+{
+    return newSVOP(OP_CONST, 0, parse_label(0));
+}
+
 /* plugin glue */
 
 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
@@ -860,6 +876,14 @@ static int my_keyword_plugin(pTHX_
 		    keyword_active(hintkey_blockasexpr_sv)) {
 	*op_ptr = parse_keyword_blockasexpr();
 	return KEYWORD_PLUGIN_EXPR;
+    } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) &&
+		    keyword_active(hintkey_swaplabel_sv)) {
+	*op_ptr = parse_keyword_swaplabel();
+	return KEYWORD_PLUGIN_STMT;
+    } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) &&
+		    keyword_active(hintkey_labelconst_sv)) {
+	*op_ptr = parse_keyword_labelconst();
+	return KEYWORD_PLUGIN_EXPR;
     } else {
 	return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
     }
@@ -2396,6 +2420,8 @@ BOOT:
     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
+    hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
+    hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
     next_keyword_plugin = PL_keyword_plugin;
     PL_keyword_plugin = my_keyword_plugin;
 }
diff --git a/ext/XS-APItest/t/labelconst.aux b/ext/XS-APItest/t/labelconst.aux
new file mode 100644
index 0000000000..d357a968e8
--- /dev/null
+++ b/ext/XS-APItest/t/labelconst.aux
@@ -0,0 +1,10 @@
+use XS::APItest qw(labelconst);
+my $z = "";
+$z .= labelconst FOO:;
+$z .= labelconst BAR:
+	;
+$z .= labelconst BAZ
+	:;
+$z .= labelconst
+	QUUX:;
+$z;
diff --git a/ext/XS-APItest/t/labelconst.t b/ext/XS-APItest/t/labelconst.t
new file mode 100644
index 0000000000..79fe9d2212
--- /dev/null
+++ b/ext/XS-APItest/t/labelconst.t
@@ -0,0 +1,96 @@
+use warnings;
+use strict;
+
+use Test::More tests => 18;
+
+BEGIN { $^H |= 0x20000; }
+
+my $t;
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst b:;
+	$t .= "c";
+};
+is $@, "";
+is $t, "abc";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= "b" . labelconst FOO: . "c";
+	$t .= "d";
+};
+is $@, "";
+is $t, "abFOOcd";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst FOO :;
+	$t .= "b";
+};
+is $@, "";
+is $t, "aFOOb";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst F_1B:;
+	$t .= "b";
+};
+is $@, "";
+is $t, "aF_1Bb";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst _AB:;
+	$t .= "b";
+};
+is $@, "";
+is $t, "a_ABb";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	no warnings;
+	$t .= "a";
+	$t .= labelconst 1AB:;
+	$t .= "b";
+};
+isnt $@, "";
+is $t, "";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst :;
+	$t .= "b";
+};
+isnt $@, "";
+is $t, "";
+
+$t = "";
+eval q{
+	use XS::APItest qw(labelconst);
+	$t .= "a";
+	$t .= labelconst ;
+	$t .= "b";
+};
+isnt $@, "";
+is $t, "";
+
+$t = "";
+$t = do("t/labelconst.aux");
+is $@, "";
+is $t, "FOOBARBAZQUUX";
+
+1;
diff --git a/ext/XS-APItest/t/swaplabel.t b/ext/XS-APItest/t/swaplabel.t
new file mode 100644
index 0000000000..a57368243b
--- /dev/null
+++ b/ext/XS-APItest/t/swaplabel.t
@@ -0,0 +1,182 @@
+use warnings;
+use strict;
+
+use Test::More tests => 28;
+
+BEGIN { $^H |= 0x20000; }
+
+my $t;
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	$t .= "b";
+	swaplabel $t .= "c";
+	swaplabel $t .= "d";
+	$t .= "e";
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	Lb: $t .= "b";
+	swaplabel $t .= "c"; Lc:
+	swaplabel $t .= "d"; Ld:
+	Le: $t .= "e";
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	goto Lb;
+	Lb: $t .= "b";
+	swaplabel $t .= "c"; Lc:
+	swaplabel $t .= "d"; Ld:
+	Le: $t .= "e";
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	goto Lc;
+	Lb: $t .= "b";
+	swaplabel $t .= "c"; Lc:
+	swaplabel $t .= "d"; Ld:
+	Le: $t .= "e";
+};
+is $@, "";
+is $t, "acde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	goto Ld;
+	Lb: $t .= "b";
+	swaplabel $t .= "c"; Lc:
+	swaplabel $t .= "d"; Ld:
+	Le: $t .= "e";
+};
+is $@, "";
+is $t, "ade";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	goto Le;
+	Lb: $t .= "b";
+	swaplabel $t .= "c"; Lc:
+	swaplabel $t .= "d"; Ld:
+	Le: $t .= "e";
+};
+is $@, "";
+is $t, "ae";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	$t .= "a";
+	swaplabel $t .= "b"; y:
+	$t .= "c";
+};
+isnt $@, "";
+is $t, "";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; }
+	swaplabel if(1) { $t .= "d"; }
+	if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	Lb: if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; } Lc:
+	swaplabel if(1) { $t .= "d"; } Ld:
+	Le: if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	goto Lb;
+	Lb: if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; } Lc:
+	swaplabel if(1) { $t .= "d"; } Ld:
+	Le: if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "abcde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	goto Lc;
+	Lb: if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; } Lc:
+	swaplabel if(1) { $t .= "d"; } Ld:
+	Le: if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "acde";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	goto Ld;
+	Lb: if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; } Lc:
+	swaplabel if(1) { $t .= "d"; } Ld:
+	Le: if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "ade";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	goto Le;
+	Lb: if(1) { $t .= "b"; }
+	swaplabel if(1) { $t .= "c"; } Lc:
+	swaplabel if(1) { $t .= "d"; } Ld:
+	Le: if(1) { $t .= "e"; }
+};
+is $@, "";
+is $t, "ae";
+
+$t = "";
+eval q{
+	use XS::APItest qw(swaplabel);
+	if(1) { $t .= "a"; }
+	swaplabel if(1) { $t .= "b"; } y:
+	if(1) { $t .= "c"; }
+};
+isnt $@, "";
+is $t, "";
+
+1;
diff --git a/global.sym b/global.sym
index 52eda8fa4d..d8eae72e92 100644
--- a/global.sym
+++ b/global.sym
@@ -424,6 +424,7 @@ Perl_pad_push
 Perl_parse_barestmt
 Perl_parse_block
 Perl_parse_fullstmt
+Perl_parse_label
 Perl_parse_stmtseq
 perl_alloc
 perl_construct
diff --git a/parser.h b/parser.h
index f4054d5a13..e2769a7cca 100644
--- a/parser.h
+++ b/parser.h
@@ -112,6 +112,9 @@ typedef struct yy_parser {
 #define LEX_STUFF_UTF8		0x00000001
 #define LEX_KEEP_PREVIOUS	0x00000002
 
+/* flags for parser API */
+#define PARSE_OPTIONAL          0x00000001
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/proto.h b/proto.h
index 415e61c8cf..644286b8b2 100644
--- a/proto.h
+++ b/proto.h
@@ -2768,6 +2768,7 @@ PERL_CALLCONV void	Perl_pad_undef(pTHX_ CV* cv)
 PERL_CALLCONV OP*	Perl_parse_barestmt(pTHX_ U32 flags);
 PERL_CALLCONV OP*	Perl_parse_block(pTHX_ U32 flags);
 PERL_CALLCONV OP*	Perl_parse_fullstmt(pTHX_ U32 flags);
+PERL_CALLCONV SV*	Perl_parse_label(pTHX_ U32 flags);
 PERL_CALLCONV OP*	Perl_parse_stmtseq(pTHX_ U32 flags);
 PERL_CALLCONV U32	Perl_parse_unicode_opts(pTHX_ const char **popt)
 			__attribute__nonnull__(pTHX_1);
diff --git a/toke.c b/toke.c
index 7c49e4a773..a30f60b6d5 100644
--- a/toke.c
+++ b/toke.c
@@ -4182,6 +4182,16 @@ S_tokenize_use(pTHX_ int is_use, char *s) {
 	};
 #endif
 
+#define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
+STATIC bool
+S_word_takes_any_delimeter(char *p, STRLEN len)
+{
+    return (len == 1 && strchr("msyq", p[0])) ||
+	   (len == 2 && (
+	    (p[0] == 't' && p[1] == 'r') ||
+	    (p[0] == 'q' && strchr("qwxr", p[1]))));
+}
+
 /*
   yylex
 
@@ -6149,10 +6159,7 @@ Perl_yylex(pTHX)
 	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
 
 	/* Some keywords can be followed by any delimiter, including ':' */
-	anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
-	       (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
-			     (PL_tokenbuf[0] == 'q' &&
-			      strchr("qwxr", PL_tokenbuf[1])))));
+	anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
 
 	/* x::* is just a word, unless x is "CORE" */
 	if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
@@ -14074,6 +14081,86 @@ Perl_parse_barestmt(pTHX_ U32 flags)
 }
 
 /*
+=for apidoc Amx|SV *|parse_label|U32 flags
+
+Parse a single label, possibly optional, of the type that may prefix a
+Perl statement.  It is up to the caller to ensure that the dynamic parser
+state (L</PL_parser> et al) is correctly set to reflect the source of
+the code to be parsed.  If I<flags> includes C<PARSE_OPTIONAL> then the
+label is optional, otherwise it is mandatory.
+
+The name of the label is returned in the form of a fresh scalar.  If an
+optional label is absent, a null pointer is returned.
+
+If an error occurs in parsing, which can only occur if the label is
+mandatory, a valid label is returned anyway.  The error is reflected in
+the parser state, normally resulting in a single exception at the top
+level of parsing which covers all the compilation errors that occurred.
+
+=cut
+*/
+
+SV *
+Perl_parse_label(pTHX_ U32 flags)
+{
+    if (flags & ~PARSE_OPTIONAL)
+	Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
+    if (PL_lex_state == LEX_KNOWNEXT) {
+	PL_parser->yychar = yylex();
+	if (PL_parser->yychar == LABEL) {
+	    char *lpv = pl_yylval.pval;
+	    STRLEN llen = strlen(lpv);
+	    SV *lsv;
+	    PL_parser->yychar = YYEMPTY;
+	    lsv = newSV_type(SVt_PV);
+	    SvPV_set(lsv, lpv);
+	    SvCUR_set(lsv, llen);
+	    SvLEN_set(lsv, llen+1);
+	    SvPOK_on(lsv);
+	    return lsv;
+	} else {
+	    yyunlex();
+	    goto no_label;
+	}
+    } else {
+	char *s, *t;
+	U8 c;
+	STRLEN wlen, bufptr_pos;
+	lex_read_space(0);
+	t = s = PL_bufptr;
+	c = (U8)*s;
+	if (!isIDFIRST_A(c))
+	    goto no_label;
+	do {
+	    c = (U8)*++t;
+	} while(isWORDCHAR_A(c));
+	wlen = t - s;
+	if (word_takes_any_delimeter(s, wlen))
+	    goto no_label;
+	bufptr_pos = s - SvPVX(PL_linestr);
+	PL_bufptr = t;
+	lex_read_space(LEX_KEEP_PREVIOUS);
+	t = PL_bufptr;
+	s = SvPVX(PL_linestr) + bufptr_pos;
+	if (t[0] == ':' && t[1] != ':') {
+	    PL_oldoldbufptr = PL_oldbufptr;
+	    PL_oldbufptr = s;
+	    PL_bufptr = t+1;
+	    return newSVpvn(s, wlen);
+	} else {
+	    PL_bufptr = s;
+	    no_label:
+	    if (flags & PARSE_OPTIONAL) {
+		return NULL;
+	    } else {
+		qerror(Perl_mess(aTHX_ "Parse error"));
+		return newSVpvs("x");
+	    }
+	}
+    }
+}
+
+/*
 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
 
 Parse a single complete Perl statement.  This may be a normal imperative