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.

5 files changed, 316 insertions, 2 deletions

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;