This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
function to parse isolated label
authorZefram <zefram@fysh.org>
Sun, 24 Oct 2010 04:44:43 +0000 (05:44 +0100)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 25 Oct 2010 19:29:47 +0000 (12:29 -0700)
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:
MANIFEST
embed.fnc
embed.h
ext/XS-APItest/APItest.pm
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/labelconst.aux [new file with mode: 0644]
ext/XS-APItest/t/labelconst.t [new file with mode: 0644]
ext/XS-APItest/t/swaplabel.t [new file with mode: 0644]
global.sym
parser.h
proto.h
toke.c

index 31bf3e8..a69f37a 100644 (file)
--- 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}
index 43d2a17..340d86d 100644 (file)
--- 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 921f8c5..5db8237 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index c4b3433..e4b7fa2 100644 (file)
@@ -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);
index 5be2c36..a3f19ea 100644 (file)
@@ -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 (file)
index 0000000..d357a96
--- /dev/null
@@ -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 (file)
index 0000000..79fe9d2
--- /dev/null
@@ -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 (file)
index 0000000..a573682
--- /dev/null
@@ -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;
index 52eda8f..d8eae72 100644 (file)
@@ -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
index f4054d5..e2769a7 100644 (file)
--- 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 415e61c..644286b 100644 (file)
--- 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 7c49e4a..a30f60b 100644 (file)
--- 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