#include "EXTERN.h"
#define PERL_IN_TOKE_C
#include "perl.h"
+#include "dquote_static.c"
#define new_constant(a,b,c,d,e,f,g) \
S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
#define pl_yylval (PL_parser->yylval)
-/* YYINITDEPTH -- initial size of the parser's stacks. */
-#define YYINITDEPTH 200
-
/* XXX temporary backwards compatibility */
#define PL_lex_brackets (PL_parser->lex_brackets)
+#define PL_lex_allbrackets (PL_parser->lex_allbrackets)
+#define PL_lex_fakeeof (PL_parser->lex_fakeeof)
#define PL_lex_brackstack (PL_parser->lex_brackstack)
#define PL_lex_casemods (PL_parser->lex_casemods)
#define PL_lex_casestack (PL_parser->lex_casestack)
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
#endif
-#define XFAKEBRACK 128
-#define XENUMMASK 127
+#define XENUMMASK 0x3f
+#define XFAKEEOF 0x40
+#define XFAKEBRACK 0x80
#ifdef USE_UTF8_SCRIPTS
# define UTF (!IN_BYTES)
}
/* grandfather return to old style */
-#define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+#define OLDLOP(f) \
+ do { \
+ if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
+ pl_yylval.ival = (f); \
+ PL_expect = XTERM; \
+ PL_bufptr = s; \
+ return (int)LSTOP; \
+ } while(0)
#ifdef DEBUGGING
Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
}
-#define FEATURE_IS_ENABLED(name) \
- ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
- && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
-/* The longest string we pass in. */
-#define MAX_FEATURE_LEN (sizeof("unicode_strings")-1)
-
/*
- * S_feature_is_enabled
* Check whether the named feature is enabled.
*/
-STATIC bool
-S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
+bool
+Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
HV * const hinthv = GvHV(PL_hintgv);
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
- assert(namelen <= MAX_FEATURE_LEN);
+ if (namelen > MAX_FEATURE_LEN)
+ return FALSE;
memcpy(&he_name[8], name, namelen);
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
#endif
-
-
/*
- * Perl_lex_start
- *
- * Create a parser object and initialise its parser and lexer fields
- *
- * rsfp is the opened file handle to read from (if any),
- *
- * line holds any initial content already read from the file (or in
- * the case of no file, such as an eval, the whole contents);
- *
- * new_filter indicates that this is a new file and it shouldn't inherit
- * the filters from the current parser (ie require).
- */
+=for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
+
+Creates and initialises a new lexer/parser state object, supplying
+a context in which to lex and parse from a new source of Perl code.
+A pointer to the new state object is placed in L</PL_parser>. An entry
+is made on the save stack so that upon unwinding the new state object
+will be destroyed and the former value of L</PL_parser> will be restored.
+Nothing else need be done to clean up the parsing context.
+
+The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
+non-null, provides a string (in SV form) containing code to be parsed.
+A copy of the string is made, so subsequent modification of I<line>
+does not affect parsing. I<rsfp>, if non-null, provides an input stream
+from which code will be read to be parsed. If both are non-null, the
+code in I<line> comes first and must consist of complete lines of input,
+and I<rsfp> supplies the remainder of the source.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
void
-Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
{
dVAR;
const char *s = NULL;
STRLEN len;
yy_parser *parser, *oparser;
+ if (flags)
+ Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
/* create and initialise a parser */
parser->old_parser = oparser = PL_parser;
PL_parser = parser;
- Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
- parser->ps = parser->stack;
- parser->stack_size = YYINITDEPTH;
-
- parser->stack->state = 0;
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
+ parser->stack = NULL;
+ parser->ps = NULL;
+ parser->stack_size = 0;
/* on scope exit, free this parser and restore any outer one */
SAVEPARSER(parser);
parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
- parser->rsfp_filters = (new_filter || !oparser) ? newAV()
- : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
+ parser->rsfp_filters = newAV();
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
if (!len) {
parser->linestr = newSVpvs("\n;");
- } else if (SvREADONLY(line) || s[len-1] != ';') {
- parser->linestr = newSVsv(line);
+ } else {
+ parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
if (s[len-1] != ';')
sv_catpvs(parser->linestr, "\n;");
- } else {
- SvTEMP_off(line);
- SvREFCNT_inc_simple_void_NN(line);
- parser->linestr = line;
}
parser->oldoldbufptr =
parser->oldbufptr =
parser->linestart = SvPVX(parser->linestr);
parser->bufend = parser->bufptr + SvCUR(parser->linestr);
parser->last_lop = parser->last_uni = NULL;
+
+ parser->in_pod = 0;
}
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
- Safefree(parser->stack);
Safefree(parser->lex_brackstack);
Safefree(parser->lex_casestack);
PL_parser = parser->old_parser;
/*
- * Perl_lex_end
- * Finalizer for lexing operations. Must be called when the parser is
- * done with the lexer.
- */
-
-void
-Perl_lex_end(pTHX)
-{
- dVAR;
- PL_doextract = FALSE;
-}
-
-/*
=for apidoc AmxU|SV *|PL_parser-E<gt>linestr
Buffer scalar containing the chunk currently under consideration of the
}
/*
-=for apidoc Amx|void|lex_stuff_pvn|char *pv|STRLEN len|U32 flags
+=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
The characters are recoded for the lexer buffer, according to how the
buffer is currently being interpreted (L</lex_bufutf8>). If a string
-to be interpreted is available as a Perl scalar, the L</lex_stuff_sv>
+to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
function is more convenient.
=cut
*/
void
-Perl_lex_stuff_pvn(pTHX_ char *pv, STRLEN len, U32 flags)
+Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
{
+ dVAR;
char *bufptr;
PERL_ARGS_ASSERT_LEX_STUFF_PVN;
if (flags & ~(LEX_STUFF_UTF8))
goto plain_copy;
} else {
STRLEN highhalf = 0;
- char *p, *e = pv+len;
+ const char *p, *e = pv+len;
for (p = pv; p != e; p++)
highhalf += !!(((U8)*p) & 0x80);
if (!highhalf)
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr,
+ SvCUR(PL_parser->linestr) + len+highhalf);
PL_parser->bufend += len+highhalf;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
} else {
if (flags & LEX_STUFF_UTF8) {
STRLEN highhalf = 0;
- char *p, *e = pv+len;
+ const char *p, *e = pv+len;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
if (c >= 0xc4) {
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr,
+ SvCUR(PL_parser->linestr) + len-highhalf);
PL_parser->bufend += len-highhalf;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
PL_parser->bufend += len;
Copy(pv, bufptr, len, char);
}
}
/*
+=for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
+
+Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
+immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
+reallocating the buffer if necessary. This means that lexing code that
+runs later will see the characters as if they had appeared in the input.
+It is not recommended to do this as part of normal parsing, and most
+uses of this facility run the risk of the inserted characters being
+interpreted in an unintended manner.
+
+The string to be inserted is represented by octets starting at I<pv>
+and continuing to the first nul. These octets are interpreted as either
+UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
+in I<flags>. The characters are recoded for the lexer buffer, according
+to how the buffer is currently being interpreted (L</lex_bufutf8>).
+If it is not convenient to nul-terminate a string to be inserted, the
+L</lex_stuff_pvn> function is more appropriate.
+
+=cut
+*/
+
+void
+Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
+{
+ PERL_ARGS_ASSERT_LEX_STUFF_PV;
+ lex_stuff_pvn(pv, strlen(pv), flags);
+}
+
+/*
=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
The string to be inserted is the string value of I<sv>. The characters
are recoded for the lexer buffer, according to how the buffer is currently
-being interpreted (L</lex_bufutf8>). If a string to be interpreted is
+being interpreted (L</lex_bufutf8>). If a string to be inserted is
not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
need to construct a scalar.
Normally it is not necessarily to do this directly, because it suffices to
use the implicit discarding behaviour of L</lex_next_chunk> and things
based on it. However, if a token stretches across multiple lines,
-and the lexing code has kept multiple lines of text in the buffer fof
+and the lexing code has kept multiple lines of text in the buffer for
that purpose, then after completion of the token it would be wise to
explicitly discard the now-unneeded earlier lines, to avoid future
multi-line tokens growing the buffer without bound.
else if (PL_parser->rsfp)
(void)PerlIO_close(PL_parser->rsfp);
PL_parser->rsfp = NULL;
- PL_doextract = FALSE;
+ PL_parser->in_pod = 0;
#ifdef PERL_MAD
if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
PL_faketokens = 1;
I32
Perl_lex_peek_unichar(pTHX_ U32 flags)
{
+ dVAR;
char *s, *bufend;
if (flags & ~(LEX_KEEP_PREVIOUS))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
PL_last_lop_op = (OPCODE)f;
#ifdef PERL_MAD
if (PL_lasttoke)
- return REPORT(LSTOP);
+ goto lstop;
#else
if (PL_nexttoke)
- return REPORT(LSTOP);
+ goto lstop;
#endif
if (*s == '(')
return REPORT(FUNC);
s = PEEKSPACE(s);
if (*s == '(')
return REPORT(FUNC);
- else
+ else {
+ lstop:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
return REPORT(LSTOP);
+ }
}
#ifdef PERL_MAD
#endif
}
+void
+Perl_yyunlex(pTHX)
+{
+ int yyc = PL_parser->yychar;
+ if (yyc != YYEMPTY) {
+ if (yyc) {
+ start_force(-1);
+ NEXTVAL_NEXTTOKE = PL_parser->yylval;
+ if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
+ PL_lex_allbrackets--;
+ PL_lex_brackets--;
+ yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
+ } else if (yyc == '('/*)*/) {
+ PL_lex_allbrackets--;
+ yyc |= (2<<24);
+ }
+ force_next(yyc);
+ }
+ PL_parser->yychar = YYEMPTY;
+ }
+}
+
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
curmad('X', newSVpvn(s,d-s));
}
#endif
- if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
+ if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
#ifdef USE_LOCALE_NUMERIC
char *loc = setlocale(LC_NUMERIC, "C");
s = (char *)scan_version(s, ver, 0);
version = newSVOP(OP_CONST, 0, ver);
}
- else if ( (*s != ';' && *s != '}' ) && (s = SKIPSPACE1(s), (*s != ';' && *s !='}' ))) {
+ else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
+ (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
+ {
PL_bufptr = s;
if (errstr)
yyerror(errstr); /* version required */
if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
goto finish;
send = s + len;
- while (s < send && *s != '\\')
+ /* This is relying on the SV being "well formed" with a trailing '\0' */
+ while (s < send && !(*s == '\\' && s[1] == '\\'))
s++;
if (s == send)
goto finish;
PL_lex_state = PL_sublex_info.super_state;
SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
+ SAVEI32(PL_lex_allbrackets);
+ SAVEI8(PL_lex_fakeeof);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEI8(PL_lex_state);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
+ PL_lex_allbrackets = 0;
+ PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
Newx(PL_lex_brackstack, 120, char);
Newx(PL_lex_casestack, 12, char);
PL_lex_casemods = 0;
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
PL_lex_inwhat = PL_sublex_info.sub_inwhat;
+ if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
PL_lex_inpat = PL_sublex_info.sub_op;
else
}
/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
+ assert(PL_lex_inwhat != OP_TRANSR);
if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
PL_linestr = PL_lex_repl;
PL_lex_inpat = 0;
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
PL_lex_brackets = 0;
+ PL_lex_allbrackets = 0;
+ PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
PL_lex_casemods = 0;
*PL_lex_casestack = '\0';
PL_lex_starts = 0;
PERL_ARGS_ASSERT_SCAN_CONST;
+ assert(PL_lex_inwhat != OP_TRANSR);
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
/* likewise skip #-initiated comments in //x patterns */
else if (*s == '#' && PL_lex_inpat &&
- ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
+ ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
s++;
- /* deprecate \1 in strings and substitution replacements */
+ /* warn on \1 - \9 in substitution replacements, but note that \11
+ * is an octal; and \19 is \1 followed by '9' */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
goto default_action;
}
- /* eg. \132 indicates the octal constant 0x132 */
+ /* eg. \132 indicates the octal constant 0132 */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
}
goto NUM_ESCAPE_INSERT;
+ /* eg. \o{24} indicates the octal constant \024 */
+ case 'o':
+ {
+ STRLEN len;
+ const char* error;
+
+ bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
+ s += len;
+ if (! valid) {
+ yyerror(error);
+ continue;
+ }
+ goto NUM_ESCAPE_INSERT;
+ }
+
/* eg. \x24 indicates the hex constant 0x24 */
case 'x':
++s;
* no-op except on utfebcdic variant characters. Every
* character generated by this that would normally need to be
* enclosed by this macro is invariant, so the macro is not
- * needed, and would complicate use of copy(). There are other
- * parts of this file where the macro is used inconsistently,
- * but are saved by it being a no-op */
+ * needed, and would complicate use of copy(). XXX There are
+ * other parts of this file where the macro is used
+ * inconsistently, but are saved by it being a no-op */
/* The structure of this section of code (besides checking for
* errors and upgrading to utf8) is:
* utf8 now, we save a whole pass in the regular expression
* compiler. Once that code is changed so Unicode
* semantics doesn't necessarily have to be in utf8, this
- * block should be removed */
+ * block should be removed. However, the code that parses
+ * the output of this would have to be changed to not
+ * necessarily expect utf8 */
if (!has_utf8) {
SvCUR_set(sv, d - SvPVX_const(sv));
SvPOK_on(sv);
/* Convert first code point to hex, including the
* boiler plate before it */
- sprintf(hex_string, "\\N{U+%X", (unsigned int) uv);
- output_length = strlen(hex_string);
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ "\\N{U+%X", (unsigned int) uv);
/* Make sure there is enough space to hold it */
d = off + SvGROW(sv, off
uv = UNICODE_REPLACEMENT;
}
- sprintf(hex_string, ".%X", (unsigned int) uv);
- output_length = strlen(hex_string);
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ ".%X", (unsigned int) uv);
d = off + SvGROW(sv, off
+ output_length
d += len;
}
SvREFCNT_dec(res);
- }
+
+ /* Deprecate non-approved name syntax */
+ if (ckWARN_d(WARN_DEPRECATED)) {
+ bool problematic = FALSE;
+ char* i = s;
+
+ /* For non-ut8 input, look to see that the first
+ * character is an alpha, then loop through the rest
+ * checking that each is a continuation */
+ if (! this_utf8) {
+ if (! isALPHAU(*i)) problematic = TRUE;
+ else for (i = s + 1; i < e; i++) {
+ if (isCHARNAME_CONT(*i)) continue;
+ problematic = TRUE;
+ break;
+ }
+ }
+ else {
+ /* Similarly for utf8. For invariants can check
+ * directly. We accept anything above the latin1
+ * range because it is immaterial to Perl if it is
+ * correct or not, and is expensive to check. But
+ * it is fairly easy in the latin1 range to convert
+ * the variants into a single character and check
+ * those */
+ if (UTF8_IS_INVARIANT(*i)) {
+ if (! isALPHAU(*i)) problematic = TRUE;
+ } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
+ if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
+ *(i+1)))))
+ {
+ problematic = TRUE;
+ }
+ }
+ if (! problematic) for (i = s + UTF8SKIP(s);
+ i < e;
+ i+= UTF8SKIP(i))
+ {
+ if (UTF8_IS_INVARIANT(*i)) {
+ if (isCHARNAME_CONT(*i)) continue;
+ } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
+ continue;
+ } else if (isCHARNAME_CONT(
+ UNI_TO_NATIVE(
+ TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
+ {
+ continue;
+ }
+ problematic = TRUE;
+ break;
+ }
+ }
+ if (problematic) {
+ /* The e-i passed to the final %.*s makes sure that
+ * should the trailing NUL be missing that this
+ * print won't run off the end of the string */
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
+ (int)(i - s + 1), s, (int)(e - i), i + 1);
+ }
+ }
+ } /* End \N{NAME} */
#ifdef EBCDIC
if (!dorange)
native_range = FALSE; /* \N{} is defined to be Unicode */
case 'c':
s++;
if (s < send) {
- U8 c = *s++;
-#ifdef EBCDIC
- if (isLOWER(c))
- c = toUPPER(c);
-#endif
- *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
+ *d++ = grok_bslash_c(*s++, 1);
}
else {
yyerror("Missing control char name in \\c");
/* In a pattern, so maybe we have {n,m}. */
if (*s == '{') {
- s++;
- if (!isDIGIT(*s))
- return TRUE;
- while (isDIGIT(*s))
- s++;
- if (*s == ',')
- s++;
- while (isDIGIT(*s))
- s++;
- if (*s == '}')
+ if (regcurly(s)) {
return FALSE;
+ }
return TRUE;
-
}
/* On the other hand, maybe we have a character class */
#endif
s = PEEKSPACE(s);
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
- return 0; /* no assumptions -- "=>" quotes bearword */
+ return 0; /* no assumptions -- "=>" quotes bareword */
bare_package:
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
- IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
- IoANY(datasv) = (void *)NULL;
sv_free(av_pop(PL_rsfp_filters));
return;
/*
* S_readpipe_override
- * Check whether readpipe() is overriden, and generates the appropriate
+ * Check whether readpipe() is overridden, and generates the appropriate
* optree, provided sublex_start() is called afterwards.
*/
STATIC void
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
{
PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
+ op_append_elem(OP_LIST,
newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
}
PL_thismad = 0;
/* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return S_pending_ident(aTHX);
/* previous token ate up our whitespace? */
};
#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
SvREFCNT_dec(tmp);
} );
/* check if there's an identifier for us to look at */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return REPORT(S_pending_ident(aTHX));
/* no identifier pending identification */
PL_lex_defer = LEX_NORMAL;
}
#endif
+ {
+ I32 next_type;
+#ifdef PERL_MAD
+ next_type = PL_nexttoke[PL_lasttoke].next_type;
+#else
+ next_type = PL_nexttype[PL_nexttoke];
+#endif
+ if (next_type & (7<<24)) {
+ if (next_type & (1<<24)) {
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] =
+ (next_type >> 16) & 0xff;
+ }
+ if (next_type & (2<<24))
+ PL_lex_allbrackets++;
+ if (next_type & (4<<24))
+ PL_lex_allbrackets--;
+ next_type &= 0xffff;
+ }
#ifdef PERL_MAD
- /* FIXME - can these be merged? */
- return(PL_nexttoke[PL_lasttoke].next_type);
+ /* FIXME - can these be merged? */
+ return next_type;
#else
- return REPORT(PL_nexttype[PL_nexttoke]);
+ return REPORT(next_type);
#endif
+ }
/* interpolated case modifiers like \L \U, including \Q and \E.
when we get here, PL_bufptr is at the \
PL_thistoken = newSVpvs("\\E");
#endif
}
+ PL_lex_allbrackets--;
return REPORT(')');
}
#ifdef PERL_MAD
if ((*s == 'L' || *s == 'U') &&
(strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
PL_lex_casestack[--PL_lex_casemods] = '\0';
+ PL_lex_allbrackets--;
return REPORT(')');
}
if (PL_lex_casemods > 10)
PL_lex_state = LEX_INTERPCONCAT;
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next('(');
+ force_next((2<<24)|'(');
start_force(PL_curforce);
if (*s == 'l')
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
force_next('$');
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next('(');
+ force_next((2<<24)|'(');
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
PL_thistoken = newSVpvs("");
}
#endif
+ PL_lex_allbrackets--;
return REPORT(')');
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
if (!PL_rsfp) {
PL_last_uni = 0;
PL_last_lop = 0;
- if (PL_lex_brackets) {
+ if (PL_lex_brackets &&
+ PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
yyerror((const char *)
(PL_lex_formbrack
? "Format not terminated"
s = swallow_bom((U8*)s);
}
}
- if (PL_doextract) {
+ if (PL_parser->in_pod) {
/* Incest with pod. */
#ifdef PERL_MAD
if (PL_madskills)
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- PL_doextract = FALSE;
+ PL_parser->in_pod = 0;
}
}
if (PL_rsfp)
incline(s);
- } while (PL_doextract);
+ } while (PL_parser->in_pod);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
else
TERM(ARROW);
}
- if (PL_expect == XOPERATOR)
+ if (PL_expect == XOPERATOR) {
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
Aop(OP_SUBTRACT);
+ }
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
else
OPERATOR(PREINC);
}
- if (PL_expect == XOPERATOR)
+ if (PL_expect == XOPERATOR) {
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
Aop(OP_ADD);
+ }
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
s++;
if (*s == '*') {
s++;
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
PWop(OP_POW);
}
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
Mop(OP_MULTIPLY);
case '%':
if (PL_expect == XOPERATOR) {
+ if (s[1] == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ TOKEN(0);
++s;
Mop(OP_MODULO);
}
TERM('%');
case '^':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
+ TOKEN(0);
s++;
BOop(OP_BIT_XOR);
case '[':
- PL_lex_brackets++;
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] = 0;
+ PL_lex_allbrackets++;
{
const char tmp = *s++;
OPERATOR(tmp);
if (s[1] == '~'
&& (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
{
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ TOKEN(0);
s += 2;
Eop(OP_SMARTMATCH);
}
+ s++;
+ OPERATOR('~');
case ',':
- {
- const char tmp = *s++;
- OPERATOR(tmp);
- }
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ TOKEN(0);
+ s++;
+ OPERATOR(',');
case ':':
if (s[1] == ':') {
len = 0;
break;
PL_bufptr = s; /* update in case we back off */
if (*s == '=') {
- deprecate(":= for an empty attribute list");
+ Perl_croak(aTHX_
+ "Use of := for an empty attribute list is not allowed");
}
goto grabattrs;
case XATTRBLOCK:
}
if (PL_lex_stuff) {
sv_catsv(sv, PL_lex_stuff);
- attrs = append_elem(OP_LIST, attrs,
+ attrs = op_append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0, sv));
SvREFCNT_dec(PL_lex_stuff);
PL_lex_stuff = NULL;
justified by the performance win for the common case
of applying only built-in attributes.) */
else
- attrs = append_elem(OP_LIST, attrs,
+ attrs = op_append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
sv));
}
#endif
TOKEN(COLONATTR);
}
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets--;
OPERATOR(':');
case '(':
s++;
else
PL_expect = XTERM;
s = SKIPSPACE1(s);
+ PL_lex_allbrackets++;
TOKEN('(');
case ';':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ TOKEN(0);
CLINE;
- {
- const char tmp = *s++;
- OPERATOR(tmp);
- }
+ s++;
+ OPERATOR(';');
case ')':
- {
- const char tmp = *s++;
- s = SKIPSPACE1(s);
- if (*s == '{')
- PREBLOCK(tmp);
- TERM(tmp);
- }
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
+ TOKEN(0);
+ s++;
+ PL_lex_allbrackets--;
+ s = SKIPSPACE1(s);
+ if (*s == '{')
+ PREBLOCK(')');
+ TERM(')');
case ']':
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
s++;
if (PL_lex_brackets <= 0)
yyerror("Unmatched right square bracket");
else
--PL_lex_brackets;
+ PL_lex_allbrackets--;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
if (*s == '-' && s[1] == '>')
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
OPERATOR(HASHBRACK);
case XOPERATOR:
while (s < PL_bufend && SPACE_OR_TAB(*s))
case XATTRBLOCK:
case XBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
+ PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
case XATTRTERM:
case XTERMBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
default: {
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
s = SKIPSPACE1(s);
if (*s == '}') {
if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
PL_copline = NOLINE; /* invalidate current command line number */
TOKEN('{');
case '}':
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
rightbracket:
s++;
if (PL_lex_brackets <= 0)
yyerror("Unmatched right curly bracket");
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
+ PL_lex_allbrackets--;
if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
PL_lex_formbrack = 0;
if (PL_lex_state == LEX_INTERPNORMAL) {
TOKEN(';');
case '&':
s++;
- if (*s++ == '&')
+ if (*s++ == '&') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
AOPERATOR(ANDAND);
+ }
s--;
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s--;
+ TOKEN(0);
+ }
BAop(OP_BIT_AND);
}
case '|':
s++;
- if (*s++ == '|')
+ if (*s++ == '|') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
AOPERATOR(OROR);
+ }
s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s--;
+ TOKEN(0);
+ }
BOop(OP_BIT_OR);
case '=':
s++;
{
const char tmp = *s++;
- if (tmp == '=')
+ if (tmp == '=') {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
Eop(OP_EQ);
- if (tmp == '>')
+ }
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
+ s -= 2;
+ TOKEN(0);
+ }
OPERATOR(',');
+ }
if (tmp == '~')
PMop(OP_MATCH);
if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
}
#endif
s = PL_bufend;
- PL_doextract = TRUE;
+ PL_parser->in_pod = 1;
goto retry;
}
}
goto leftbracket;
}
}
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
pl_yylval.ival = 0;
OPERATOR(ASSIGNOP);
case '!':
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"!=~ should be !~");
}
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
Eop(OP_NE);
}
if (tmp == '~')
s++;
{
char tmp = *s++;
- if (tmp == '<')
+ if (tmp == '<') {
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
SHop(OP_LEFT_SHIFT);
+ }
if (tmp == '=') {
tmp = *s++;
- if (tmp == '>')
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 3;
+ TOKEN(0);
+ }
Eop(OP_NCMP);
+ }
s--;
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
Rop(OP_LE);
}
}
s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
Rop(OP_LT);
case '>':
s++;
{
const char tmp = *s++;
- if (tmp == '>')
+ if (tmp == '>') {
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
SHop(OP_RIGHT_SHIFT);
- else if (tmp == '=')
+ }
+ else if (tmp == '=') {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
Rop(OP_GE);
+ }
}
s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
Rop(OP_GT);
case '$':
}
}
- if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
+ if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
PL_tokenbuf[0] = '@';
s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
case '/': /* may be division, defined-or, or pattern */
if (PL_expect == XTERMORDORDOR && s[1] == '/') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
+ TOKEN(0);
s += 2;
AOPERATOR(DORDOR);
}
if (PL_expect == XOPERATOR) {
char tmp = *s++;
if(tmp == '?') {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
OPERATOR('?');
}
else {
tmp = *s++;
if(tmp == '/') {
/* A // operator. */
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN :
+ LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
AOPERATOR(DORDOR);
}
else {
s--;
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
Mop(OP_DIVIDE);
}
}
|| isALNUM_lazy_if(PL_last_uni+5,UTF)
))
check_uni();
+ if (*s == '?')
+ deprecate("?PATTERN? without explicit operator");
s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
}
if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
char tmp = *s++;
if (*s == tmp) {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
+ s--;
+ TOKEN(0);
+ }
s++;
if (*s == tmp) {
s++;
pl_yylval.ival = 0;
OPERATOR(DOTDOT);
}
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
Aop(OP_CONCAT);
}
/* FALL THROUGH */
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"))
int result;
char *saved_bufptr = PL_bufptr;
PL_bufptr = s;
- result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
+ result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
s = PL_bufptr;
if (result == KEYWORD_PLUGIN_DECLINE) {
/* not a plugged-in keyword */
/* Is this a label? */
if (!anydelim && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
- if (tmp)
- Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
s = d + 1;
pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
gvp = 0;
if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous call resolved as CORE::%s(), %s",
- GvENAME(hgv), "qualify as such or use &");
+ "Ambiguous call resolved as CORE::%s(), "
+ "qualify as such or use &",
+ GvENAME(hgv));
}
}
}
/* Look for a subroutine with this name in current package,
- unless name is "Foo::", in which case Foo is a bearword
+ unless name is "Foo::", in which case Foo is a bareword
(and a package name). */
if (len > 2 && !PL_madskills &&
/* if we saw a global override before, get the right name */
+ sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
+ len ? len : strlen(PL_tokenbuf));
if (gvp) {
+ SV * const tmp_sv = sv;
sv = newSVpvs("CORE::GLOBAL::");
- sv_catpv(sv,PL_tokenbuf);
- }
- else {
- /* If len is 0, newSVpv does strlen(), which is correct.
- If len is non-zero, then it will be the true length,
- and so the scalar will be created correctly. */
- sv = newSVpv(PL_tokenbuf,len);
+ sv_catsv(sv, tmp_sv);
+ SvREFCNT_dec(tmp_sv);
}
+
#ifdef PERL_MAD
if (PL_madskills && !PL_thistoken) {
char *start = SvPVX(PL_linestr) + PL_realtokenstart;
#endif
/* Presume this is going to be a bareword of some sort. */
-
CLINE;
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
pl_yylval.opval->op_private = OPpCONST_BARE;
- /* UTF-8 package name? */
- if (UTF && !IN_BYTES &&
- is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
- SvUTF8_on(sv);
/* And if "Foo::", then that's what it certainly is. */
-
if (len)
goto safe_bareword;
- cv = NULL;
{
OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv));
const_op->op_private = OPpCONST_BARE;
rv2cv_op = newCVREF(0, const_op);
}
- if (rv2cv_op->op_type == OP_RV2CV &&
- (rv2cv_op->op_flags & OPf_KIDS)) {
- OP *rv_op = cUNOPx(rv2cv_op)->op_first;
- switch (rv_op->op_type) {
- case OP_CONST: {
- SV *sv = cSVOPx_sv(rv_op);
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
- cv = (CV*)SvRV(sv);
- } break;
- case OP_GV: {
- GV *gv = cGVOPx_gv(rv_op);
- CV *maybe_cv = GvCVu(gv);
- if (maybe_cv && SvTYPE((SV*)maybe_cv) == SVt_PVCV)
- cv = maybe_cv;
- } break;
- }
- }
+ cv = rv2cv_op_cv(rv2cv_op, 0);
/* See if it's the indirect object for a list operator. */
if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
(tmp = intuit_method(s, gv, cv))) {
op_free(rv2cv_op);
+ if (tmp == METHOD && !PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
return REPORT(tmp);
}
op_free(rv2cv_op);
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_METHOD;
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
PREBLOCK(METHOD);
}
&& (isIDFIRST_lazy_if(s,UTF) || *s == '$')
&& (tmp = intuit_method(s, gv, cv))) {
op_free(rv2cv_op);
+ if (tmp == METHOD && !PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
return REPORT(tmp);
}
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
pl_yylval.opval->op_private = 0;
+ pl_yylval.opval->op_flags |= OPf_SPECIAL;
TOKEN(WORD);
}
const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
if (!protolen)
TERM(FUNC0SUB);
- if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
- OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
+ if (
+ (
+ (
+ *proto == '$' || *proto == '_'
+ || *proto == '*' || *proto == '+'
+ )
+ && proto[1] == '\0'
+ )
+ || (
+ *proto == '\\' && proto[1] && proto[2] == '\0'
+ )
+ )
+ OPERATOR(UNIOPSUB);
+ if (*proto == '\\' && proto[1] == '[') {
+ const char *p = proto + 2;
+ while(*p && *p != ']')
+ ++p;
+ if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+ }
if (*proto == '&' && *s == '{') {
if (PL_curstash)
sv_setpvs(PL_subname, "__ANON__");
else
sv_setpvs(PL_subname, "__ANON__::__ANON__");
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
PREBLOCK(LSTOPSUB);
}
}
PL_thistoken = newSVpvs("");
}
force_next(WORD);
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
TOKEN(NOAMP);
}
}
curmad('X', PL_thistoken);
PL_thistoken = newSVpvs("");
force_next(WORD);
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
TOKEN(NOAMP);
}
#else
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
force_next(WORD);
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
TOKEN(NOAMP);
#endif
}
LOP(OP_ACCEPT,XTERM);
case KEY_and:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
OPERATOR(ANDOP);
case KEY_atan2:
UNI(OP_CLOSEDIR);
case KEY_cmp:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Eop(OP_SCMP);
case KEY_caller:
UNI(OP_DELETE);
case KEY_dbmopen:
- gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
+ Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
+ STR_WITH_LEN("NDBM_File::"),
+ STR_WITH_LEN("DB_File::"),
+ STR_WITH_LEN("GDBM_File::"),
+ STR_WITH_LEN("SDBM_File::"),
+ STR_WITH_LEN("ODBM_File::"),
+ NULL);
LOP(OP_DBMOPEN,XTERM);
case KEY_dbmclose:
OPERATOR(ELSIF);
case KEY_eq:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Eop(OP_SEQ);
case KEY_exists:
case KEY_for:
case KEY_foreach:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
s = SKIPSPACE1(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
LOP(OP_FLOCK,XTERM);
case KEY_gt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Rop(OP_SGT);
case KEY_ge:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Rop(OP_SGE);
case KEY_grep:
UNI(OP_HEX);
case KEY_if:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(IF);
UNI(OP_LENGTH);
case KEY_lt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Rop(OP_SLT);
case KEY_le:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Rop(OP_SLE);
case KEY_localtime:
LOOPX(OP_NEXT);
case KEY_ne:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
Eop(OP_SNE);
case KEY_no:
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
FUN1(OP_NOT);
- else
+ else {
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
OPERATOR(NOTOP);
+ }
case KEY_open:
s = SKIPSPACE1(s);
LOP(OP_OPEN,XTERM);
case KEY_or:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
pl_yylval.ival = OP_OR;
OPERATOR(OROP);
s = force_word(s,WORD,FALSE,TRUE,FALSE);
s = SKIPSPACE1(s);
s = force_strict_version(s);
+ PL_lex_expect = XBLOCK;
OPERATOR(PACKAGE);
case KEY_pipe:
case KEY_quotemeta:
UNI(OP_QUOTEMETA);
- case KEY_qw:
+ case KEY_qw: {
+ OP *words = NULL;
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
PL_expect = XOPERATOR;
- force_next(')');
if (SvCUR(PL_lex_stuff)) {
- OP *words = NULL;
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
/**/;
}
sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
- words = append_elem(OP_LIST, words,
+ words = op_append_elem(OP_LIST, words,
newSVOP(OP_CONST, 0, tokeq(sv)));
}
}
- if (words) {
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = words;
- force_next(THING);
- }
}
+ if (!words)
+ words = newNULLLIST();
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
PL_lex_stuff = NULL;
}
- PL_expect = XTERM;
- TOKEN('(');
+ PL_expect = XOPERATOR;
+ pl_yylval.opval = sawparens(words);
+ TOKEN(QWLIST);
+ }
case KEY_qq:
s = scan_str(s,!!PL_madskills,FALSE);
missingterm(NULL);
pl_yylval.ival = OP_STRINGIFY;
if (SvIVX(PL_lex_stuff) == '\'')
- SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
+ SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
TERM(sublex_start());
case KEY_qr:
if (warnillegalproto) {
if (must_be_last)
proto_after_greedy_proto = TRUE;
- if (!strchr("$@%*;[]&\\_", *p)) {
+ if (!strchr("$@%*;[]&\\_+", *p)) {
bad_proto = TRUE;
}
else {
UNI(OP_UNTIE);
case KEY_until:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNTIL);
case KEY_unless:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNLESS);
LOP(OP_VEC,XTERM);
case KEY_when:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHEN);
case KEY_while:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHILE);
UNI(OP_ENTERWRITE);
case KEY_x:
- if (PL_expect == XOPERATOR)
+ if (PL_expect == XOPERATOR) {
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ return REPORT(0);
Mop(OP_REPEAT);
+ }
check_uni();
goto just_a_word;
case KEY_xor:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
pl_yylval.ival = OP_XOR;
OPERATOR(OROP);
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
tokenbuf_len - 1));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpvn_flags(
- PL_tokenbuf + 1, tokenbuf_len - 1,
- /* If the identifier refers to a stash, don't autovivify it.
- * Change 24660 had the side effect of causing symbol table
- * hashes to always be defined, even if they were freshly
- * created and the only reference in the entire program was
- * the single statement with the defined %foo::bar:: test.
- * It appears that all code in the wild doing this actually
- * wants to know whether sub-packages have been loaded, so
- * by avoiding auto-vivifying symbol tables, we ensure that
- * defined %foo::bar:: continues to be false, and the existing
- * tests still give the expected answers, even though what
- * they're actually testing has now changed subtly.
- */
- (*PL_tokenbuf == '%'
- && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
- && d[-1] == ':'
- ? 0
- : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
+ PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
return WORD;
}
-/*
- * The following code was generated by perl_keyword.pl.
- */
-
-I32
-Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
+STATIC void
+S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
dVAR;
- PERL_ARGS_ASSERT_KEYWORD;
-
- switch (len)
- {
- case 1: /* 5 tokens of length 1 */
- switch (name[0])
- {
- case 'm':
- { /* m */
- return KEY_m;
- }
-
- case 'q':
- { /* q */
- return KEY_q;
- }
-
- case 's':
- { /* s */
- return KEY_s;
- }
-
- case 'x':
- { /* x */
- return -KEY_x;
- }
-
- case 'y':
- { /* y */
- return KEY_y;
- }
-
- default:
- goto unknown;
- }
-
- case 2: /* 18 tokens of length 2 */
- switch (name[0])
- {
- case 'd':
- if (name[1] == 'o')
- { /* do */
- return KEY_do;
- }
-
- goto unknown;
-
- case 'e':
- if (name[1] == 'q')
- { /* eq */
- return -KEY_eq;
- }
-
- goto unknown;
-
- case 'g':
- switch (name[1])
- {
- case 'e':
- { /* ge */
- return -KEY_ge;
- }
-
- case 't':
- { /* gt */
- return -KEY_gt;
- }
-
- default:
- goto unknown;
- }
-
- case 'i':
- if (name[1] == 'f')
- { /* if */
- return KEY_if;
- }
-
- goto unknown;
-
- case 'l':
- switch (name[1])
- {
- case 'c':
- { /* lc */
- return -KEY_lc;
- }
-
- case 'e':
- { /* le */
- return -KEY_le;
- }
-
- case 't':
- { /* lt */
- return -KEY_lt;
- }
-
- default:
- goto unknown;
- }
-
- case 'm':
- if (name[1] == 'y')
- { /* my */
- return KEY_my;
- }
-
- goto unknown;
-
- case 'n':
- switch (name[1])
- {
- case 'e':
- { /* ne */
- return -KEY_ne;
- }
-
- case 'o':
- { /* no */
- return KEY_no;
- }
-
- default:
- goto unknown;
- }
-
- case 'o':
- if (name[1] == 'r')
- { /* or */
- return -KEY_or;
- }
-
- goto unknown;
-
- case 'q':
- switch (name[1])
- {
- case 'q':
- { /* qq */
- return KEY_qq;
- }
-
- case 'r':
- { /* qr */
- return KEY_qr;
- }
-
- case 'w':
- { /* qw */
- return KEY_qw;
- }
-
- case 'x':
- { /* qx */
- return KEY_qx;
- }
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[1] == 'r')
- { /* tr */
- return KEY_tr;
- }
-
- goto unknown;
-
- case 'u':
- if (name[1] == 'c')
- { /* uc */
- return -KEY_uc;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 3: /* 29 tokens of length 3 */
- switch (name[0])
- {
- case 'E':
- if (name[1] == 'N' &&
- name[2] == 'D')
- { /* END */
- return KEY_END;
- }
-
- goto unknown;
-
- case 'a':
- switch (name[1])
- {
- case 'b':
- if (name[2] == 's')
- { /* abs */
- return -KEY_abs;
- }
-
- goto unknown;
-
- case 'n':
- if (name[2] == 'd')
- { /* and */
- return -KEY_and;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'c':
- switch (name[1])
- {
- case 'h':
- if (name[2] == 'r')
- { /* chr */
- return -KEY_chr;
- }
-
- goto unknown;
-
- case 'm':
- if (name[2] == 'p')
- { /* cmp */
- return -KEY_cmp;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 's')
- { /* cos */
- return -KEY_cos;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'd':
- if (name[1] == 'i' &&
- name[2] == 'e')
- { /* die */
- return -KEY_die;
- }
-
- goto unknown;
-
- case 'e':
- switch (name[1])
- {
- case 'o':
- if (name[2] == 'f')
- { /* eof */
- return -KEY_eof;
- }
-
- goto unknown;
-
- case 'x':
- if (name[2] == 'p')
- { /* exp */
- return -KEY_exp;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'f':
- if (name[1] == 'o' &&
- name[2] == 'r')
- { /* for */
- return KEY_for;
- }
-
- goto unknown;
-
- case 'h':
- if (name[1] == 'e' &&
- name[2] == 'x')
- { /* hex */
- return -KEY_hex;
- }
-
- goto unknown;
-
- case 'i':
- if (name[1] == 'n' &&
- name[2] == 't')
- { /* int */
- return -KEY_int;
- }
-
- goto unknown;
-
- case 'l':
- if (name[1] == 'o' &&
- name[2] == 'g')
- { /* log */
- return -KEY_log;
- }
-
- goto unknown;
-
- case 'm':
- if (name[1] == 'a' &&
- name[2] == 'p')
- { /* map */
- return KEY_map;
- }
-
- goto unknown;
-
- case 'n':
- if (name[1] == 'o' &&
- name[2] == 't')
- { /* not */
- return -KEY_not;
- }
-
- goto unknown;
-
- case 'o':
- switch (name[1])
- {
- case 'c':
- if (name[2] == 't')
- { /* oct */
- return -KEY_oct;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'd')
- { /* ord */
- return -KEY_ord;
- }
-
- goto unknown;
-
- case 'u':
- if (name[2] == 'r')
- { /* our */
- return KEY_our;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'p':
- if (name[1] == 'o')
- {
- switch (name[2])
- {
- case 'p':
- { /* pop */
- return -KEY_pop;
- }
+ PERL_ARGS_ASSERT_CHECKCOMMA;
- case 's':
- { /* pos */
- return KEY_pos;
- }
+ if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
+ if (ckWARN(WARN_SYNTAX)) {
+ int level = 1;
+ const char *w;
+ for (w = s+2; *w && level; w++) {
+ if (*w == '(')
+ ++level;
+ else if (*w == ')')
+ --level;
+ }
+ while (isSPACE(*w))
+ ++w;
+ /* the list of chars below is for end of statements or
+ * block / parens, boolean operators (&&, ||, //) and branch
+ * constructs (or, and, if, until, unless, while, err, for).
+ * Not a very solid hack... */
+ if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%s (...) interpreted as function",name);
+ }
+ }
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == '(')
+ s++;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (isIDFIRST_lazy_if(s,UTF)) {
+ const char * const w = s++;
+ while (isALNUM_lazy_if(s,UTF))
+ s++;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == ',') {
+ GV* gv;
+ if (keyword(w, s - w, 0))
+ return;
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'r':
- if (name[1] == 'e' &&
- name[2] == 'f')
- { /* ref */
- return -KEY_ref;
- }
-
- goto unknown;
-
- case 's':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 'y')
- { /* say */
- return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
- }
-
- goto unknown;
-
- case 'i':
- if (name[2] == 'n')
- { /* sin */
- return -KEY_sin;
- }
-
- goto unknown;
-
- case 'u':
- if (name[2] == 'b')
- { /* sub */
- return KEY_sub;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[1] == 'i' &&
- name[2] == 'e')
- { /* tie */
- return KEY_tie;
- }
-
- goto unknown;
-
- case 'u':
- if (name[1] == 's' &&
- name[2] == 'e')
- { /* use */
- return KEY_use;
- }
-
- goto unknown;
-
- case 'v':
- if (name[1] == 'e' &&
- name[2] == 'c')
- { /* vec */
- return -KEY_vec;
- }
-
- goto unknown;
-
- case 'x':
- if (name[1] == 'o' &&
- name[2] == 'r')
- { /* xor */
- return -KEY_xor;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 4: /* 41 tokens of length 4 */
- switch (name[0])
- {
- case 'C':
- if (name[1] == 'O' &&
- name[2] == 'R' &&
- name[3] == 'E')
- { /* CORE */
- return -KEY_CORE;
- }
-
- goto unknown;
-
- case 'I':
- if (name[1] == 'N' &&
- name[2] == 'I' &&
- name[3] == 'T')
- { /* INIT */
- return KEY_INIT;
- }
-
- goto unknown;
-
- case 'b':
- if (name[1] == 'i' &&
- name[2] == 'n' &&
- name[3] == 'd')
- { /* bind */
- return -KEY_bind;
- }
-
- goto unknown;
-
- case 'c':
- if (name[1] == 'h' &&
- name[2] == 'o' &&
- name[3] == 'p')
- { /* chop */
- return -KEY_chop;
- }
-
- goto unknown;
-
- case 'd':
- if (name[1] == 'u' &&
- name[2] == 'm' &&
- name[3] == 'p')
- { /* dump */
- return -KEY_dump;
- }
-
- goto unknown;
-
- case 'e':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 'c' &&
- name[3] == 'h')
- { /* each */
- return -KEY_each;
- }
-
- goto unknown;
-
- case 'l':
- if (name[2] == 's' &&
- name[3] == 'e')
- { /* else */
- return KEY_else;
- }
-
- goto unknown;
-
- case 'v':
- if (name[2] == 'a' &&
- name[3] == 'l')
- { /* eval */
- return KEY_eval;
- }
-
- goto unknown;
-
- case 'x':
- switch (name[2])
- {
- case 'e':
- if (name[3] == 'c')
- { /* exec */
- return -KEY_exec;
- }
-
- goto unknown;
-
- case 'i':
- if (name[3] == 't')
- { /* exit */
- return -KEY_exit;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 'f':
- if (name[1] == 'o' &&
- name[2] == 'r' &&
- name[3] == 'k')
- { /* fork */
- return -KEY_fork;
- }
-
- goto unknown;
-
- case 'g':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 't' &&
- name[3] == 'c')
- { /* getc */
- return -KEY_getc;
- }
-
- goto unknown;
-
- case 'l':
- if (name[2] == 'o' &&
- name[3] == 'b')
- { /* glob */
- return KEY_glob;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 't' &&
- name[3] == 'o')
- { /* goto */
- return KEY_goto;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'e' &&
- name[3] == 'p')
- { /* grep */
- return KEY_grep;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'j':
- if (name[1] == 'o' &&
- name[2] == 'i' &&
- name[3] == 'n')
- { /* join */
- return -KEY_join;
- }
-
- goto unknown;
-
- case 'k':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 'y' &&
- name[3] == 's')
- { /* keys */
- return -KEY_keys;
- }
-
- goto unknown;
-
- case 'i':
- if (name[2] == 'l' &&
- name[3] == 'l')
- { /* kill */
- return -KEY_kill;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'l':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 's' &&
- name[3] == 't')
- { /* last */
- return KEY_last;
- }
-
- goto unknown;
-
- case 'i':
- if (name[2] == 'n' &&
- name[3] == 'k')
- { /* link */
- return -KEY_link;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'c' &&
- name[3] == 'k')
- { /* lock */
- return -KEY_lock;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'n':
- if (name[1] == 'e' &&
- name[2] == 'x' &&
- name[3] == 't')
- { /* next */
- return KEY_next;
- }
-
- goto unknown;
-
- case 'o':
- if (name[1] == 'p' &&
- name[2] == 'e' &&
- name[3] == 'n')
- { /* open */
- return -KEY_open;
- }
-
- goto unknown;
-
- case 'p':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 'c' &&
- name[3] == 'k')
- { /* pack */
- return -KEY_pack;
- }
-
- goto unknown;
-
- case 'i':
- if (name[2] == 'p' &&
- name[3] == 'e')
- { /* pipe */
- return -KEY_pipe;
- }
-
- goto unknown;
-
- case 'u':
- if (name[2] == 's' &&
- name[3] == 'h')
- { /* push */
- return -KEY_push;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'r':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 'n' &&
- name[3] == 'd')
- { /* rand */
- return -KEY_rand;
- }
-
- goto unknown;
-
- case 'e':
- switch (name[2])
- {
- case 'a':
- if (name[3] == 'd')
- { /* read */
- return -KEY_read;
- }
-
- goto unknown;
-
- case 'c':
- if (name[3] == 'v')
- { /* recv */
- return -KEY_recv;
- }
-
- goto unknown;
-
- case 'd':
- if (name[3] == 'o')
- { /* redo */
- return KEY_redo;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 's':
- switch (name[1])
- {
- case 'e':
- switch (name[2])
- {
- case 'e':
- if (name[3] == 'k')
- { /* seek */
- return -KEY_seek;
- }
-
- goto unknown;
-
- case 'n':
- if (name[3] == 'd')
- { /* send */
- return -KEY_send;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'o':
- if (name[2] == 'r' &&
- name[3] == 't')
- { /* sort */
- return KEY_sort;
- }
-
- goto unknown;
-
- case 'q':
- if (name[2] == 'r' &&
- name[3] == 't')
- { /* sqrt */
- return -KEY_sqrt;
- }
-
- goto unknown;
-
- case 't':
- if (name[2] == 'a' &&
- name[3] == 't')
- { /* stat */
- return -KEY_stat;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 't':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 'l' &&
- name[3] == 'l')
- { /* tell */
- return -KEY_tell;
- }
-
- goto unknown;
-
- case 'i':
- switch (name[2])
- {
- case 'e':
- if (name[3] == 'd')
- { /* tied */
- return KEY_tied;
- }
-
- goto unknown;
-
- case 'm':
- if (name[3] == 'e')
- { /* time */
- return -KEY_time;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 'w':
- switch (name[1])
- {
- case 'a':
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
-
- goto unknown;
-
- case 'r':
- if (name[3] == 'n')
- { /* warn */
- return -KEY_warn;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'h':
- if (name[2] == 'e' &&
- name[3] == 'n')
- { /* when */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 5: /* 39 tokens of length 5 */
- switch (name[0])
- {
- case 'B':
- if (name[1] == 'E' &&
- name[2] == 'G' &&
- name[3] == 'I' &&
- name[4] == 'N')
- { /* BEGIN */
- return KEY_BEGIN;
- }
-
- goto unknown;
-
- case 'C':
- if (name[1] == 'H' &&
- name[2] == 'E' &&
- name[3] == 'C' &&
- name[4] == 'K')
- { /* CHECK */
- return KEY_CHECK;
- }
-
- goto unknown;
-
- case 'a':
- switch (name[1])
- {
- case 'l':
- if (name[2] == 'a' &&
- name[3] == 'r' &&
- name[4] == 'm')
- { /* alarm */
- return -KEY_alarm;
- }
-
- goto unknown;
-
- case 't':
- if (name[2] == 'a' &&
- name[3] == 'n' &&
- name[4] == '2')
- { /* atan2 */
- return -KEY_atan2;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'b':
- switch (name[1])
- {
- case 'l':
- if (name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'e' &&
- name[3] == 'a' &&
- name[4] == 'k')
- { /* break */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'c':
- switch (name[1])
- {
- case 'h':
- switch (name[2])
- {
- case 'd':
- if (name[3] == 'i' &&
- name[4] == 'r')
- { /* chdir */
- return -KEY_chdir;
- }
-
- goto unknown;
-
- case 'm':
- if (name[3] == 'o' &&
- name[4] == 'd')
- { /* chmod */
- return -KEY_chmod;
- }
-
- goto unknown;
-
- case 'o':
- switch (name[3])
- {
- case 'm':
- if (name[4] == 'p')
- { /* chomp */
- return -KEY_chomp;
- }
-
- goto unknown;
-
- case 'w':
- if (name[4] == 'n')
- { /* chown */
- return -KEY_chown;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 'l':
- if (name[2] == 'o' &&
- name[3] == 's' &&
- name[4] == 'e')
- { /* close */
- return -KEY_close;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'y' &&
- name[3] == 'p' &&
- name[4] == 't')
- { /* crypt */
- return -KEY_crypt;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'e':
- if (name[1] == 'l' &&
- name[2] == 's' &&
- name[3] == 'i' &&
- name[4] == 'f')
- { /* elsif */
- return KEY_elsif;
- }
-
- goto unknown;
-
- case 'f':
- switch (name[1])
- {
- case 'c':
- if (name[2] == 'n' &&
- name[3] == 't' &&
- name[4] == 'l')
- { /* fcntl */
- return -KEY_fcntl;
- }
-
- goto unknown;
-
- case 'l':
- if (name[2] == 'o' &&
- name[3] == 'c' &&
- name[4] == 'k')
- { /* flock */
- return -KEY_flock;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'g':
- if (name[1] == 'i' &&
- name[2] == 'v' &&
- name[3] == 'e' &&
- name[4] == 'n')
- { /* given */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
- }
-
- goto unknown;
-
- case 'i':
- switch (name[1])
- {
- case 'n':
- if (name[2] == 'd' &&
- name[3] == 'e' &&
- name[4] == 'x')
- { /* index */
- return -KEY_index;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'c' &&
- name[3] == 't' &&
- name[4] == 'l')
- { /* ioctl */
- return -KEY_ioctl;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'l':
- switch (name[1])
- {
- case 'o':
- if (name[2] == 'c' &&
- name[3] == 'a' &&
- name[4] == 'l')
- { /* local */
- return KEY_local;
- }
-
- goto unknown;
-
- case 's':
- if (name[2] == 't' &&
- name[3] == 'a' &&
- name[4] == 't')
- { /* lstat */
- return -KEY_lstat;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'm':
- if (name[1] == 'k' &&
- name[2] == 'd' &&
- name[3] == 'i' &&
- name[4] == 'r')
- { /* mkdir */
- return -KEY_mkdir;
- }
-
- goto unknown;
-
- case 'p':
- if (name[1] == 'r' &&
- name[2] == 'i' &&
- name[3] == 'n' &&
- name[4] == 't')
- { /* print */
- return KEY_print;
- }
-
- goto unknown;
-
- case 'r':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 's' &&
- name[3] == 'e' &&
- name[4] == 't')
- { /* reset */
- return -KEY_reset;
- }
-
- goto unknown;
-
- case 'm':
- if (name[2] == 'd' &&
- name[3] == 'i' &&
- name[4] == 'r')
- { /* rmdir */
- return -KEY_rmdir;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 's':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 'm' &&
- name[3] == 'o' &&
- name[4] == 'p')
- { /* semop */
- return -KEY_semop;
- }
-
- goto unknown;
-
- case 'h':
- if (name[2] == 'i' &&
- name[3] == 'f' &&
- name[4] == 't')
- { /* shift */
- return -KEY_shift;
- }
-
- goto unknown;
-
- case 'l':
- if (name[2] == 'e' &&
- name[3] == 'e' &&
- name[4] == 'p')
- { /* sleep */
- return -KEY_sleep;
- }
-
- goto unknown;
-
- case 'p':
- if (name[2] == 'l' &&
- name[3] == 'i' &&
- name[4] == 't')
- { /* split */
- return KEY_split;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'a' &&
- name[3] == 'n' &&
- name[4] == 'd')
- { /* srand */
- return -KEY_srand;
- }
-
- goto unknown;
-
- case 't':
- switch (name[2])
- {
- case 'a':
- if (name[3] == 't' &&
- name[4] == 'e')
- { /* state */
- return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
- }
-
- goto unknown;
-
- case 'u':
- if (name[3] == 'd' &&
- name[4] == 'y')
- { /* study */
- return KEY_study;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[1] == 'i' &&
- name[2] == 'm' &&
- name[3] == 'e' &&
- name[4] == 's')
- { /* times */
- return -KEY_times;
- }
-
- goto unknown;
-
- case 'u':
- switch (name[1])
- {
- case 'm':
- if (name[2] == 'a' &&
- name[3] == 's' &&
- name[4] == 'k')
- { /* umask */
- return -KEY_umask;
- }
-
- goto unknown;
-
- case 'n':
- switch (name[2])
- {
- case 'd':
- if (name[3] == 'e' &&
- name[4] == 'f')
- { /* undef */
- return KEY_undef;
- }
-
- goto unknown;
-
- case 't':
- if (name[3] == 'i')
- {
- switch (name[4])
- {
- case 'e':
- { /* untie */
- return KEY_untie;
- }
-
- case 'l':
- { /* until */
- return KEY_until;
- }
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[2] == 'i' &&
- name[3] == 'm' &&
- name[4] == 'e')
- { /* utime */
- return -KEY_utime;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'w':
- switch (name[1])
- {
- case 'h':
- if (name[2] == 'i' &&
- name[3] == 'l' &&
- name[4] == 'e')
- { /* while */
- return KEY_while;
- }
-
- goto unknown;
-
- case 'r':
- if (name[2] == 'i' &&
- name[3] == 't' &&
- name[4] == 'e')
- { /* write */
- return -KEY_write;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 6: /* 33 tokens of length 6 */
- switch (name[0])
- {
- case 'a':
- if (name[1] == 'c' &&
- name[2] == 'c' &&
- name[3] == 'e' &&
- name[4] == 'p' &&
- name[5] == 't')
- { /* accept */
- return -KEY_accept;
- }
-
- goto unknown;
-
- case 'c':
- switch (name[1])
- {
- case 'a':
- if (name[2] == 'l' &&
- name[3] == 'l' &&
- name[4] == 'e' &&
- name[5] == 'r')
- { /* caller */
- return -KEY_caller;
- }
-
- goto unknown;
-
- case 'h':
- if (name[2] == 'r' &&
- name[3] == 'o' &&
- name[4] == 'o' &&
- name[5] == 't')
- { /* chroot */
- return -KEY_chroot;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'd':
- if (name[1] == 'e' &&
- name[2] == 'l' &&
- name[3] == 'e' &&
- name[4] == 't' &&
- name[5] == 'e')
- { /* delete */
- return KEY_delete;
- }
-
- goto unknown;
-
- case 'e':
- switch (name[1])
- {
- case 'l':
- if (name[2] == 's' &&
- name[3] == 'e' &&
- name[4] == 'i' &&
- name[5] == 'f')
- { /* elseif */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
- }
-
- goto unknown;
-
- case 'x':
- if (name[2] == 'i' &&
- name[3] == 's' &&
- name[4] == 't' &&
- name[5] == 's')
- { /* exists */
- return KEY_exists;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'f':
- switch (name[1])
- {
- case 'i':
- if (name[2] == 'l' &&
- name[3] == 'e' &&
- name[4] == 'n' &&
- name[5] == 'o')
- { /* fileno */
- return -KEY_fileno;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'r' &&
- name[3] == 'm' &&
- name[4] == 'a' &&
- name[5] == 't')
- { /* format */
- return KEY_format;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'g':
- if (name[1] == 'm' &&
- name[2] == 't' &&
- name[3] == 'i' &&
- name[4] == 'm' &&
- name[5] == 'e')
- { /* gmtime */
- return -KEY_gmtime;
- }
-
- goto unknown;
-
- case 'l':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 'n' &&
- name[3] == 'g' &&
- name[4] == 't' &&
- name[5] == 'h')
- { /* length */
- return -KEY_length;
- }
-
- goto unknown;
-
- case 'i':
- if (name[2] == 's' &&
- name[3] == 't' &&
- name[4] == 'e' &&
- name[5] == 'n')
- { /* listen */
- return -KEY_listen;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'm':
- if (name[1] == 's' &&
- name[2] == 'g')
- {
- switch (name[3])
- {
- case 'c':
- if (name[4] == 't' &&
- name[5] == 'l')
- { /* msgctl */
- return -KEY_msgctl;
- }
-
- goto unknown;
-
- case 'g':
- if (name[4] == 'e' &&
- name[5] == 't')
- { /* msgget */
- return -KEY_msgget;
- }
-
- goto unknown;
-
- case 'r':
- if (name[4] == 'c' &&
- name[5] == 'v')
- { /* msgrcv */
- return -KEY_msgrcv;
- }
-
- goto unknown;
-
- case 's':
- if (name[4] == 'n' &&
- name[5] == 'd')
- { /* msgsnd */
- return -KEY_msgsnd;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'p':
- if (name[1] == 'r' &&
- name[2] == 'i' &&
- name[3] == 'n' &&
- name[4] == 't' &&
- name[5] == 'f')
- { /* printf */
- return KEY_printf;
- }
-
- goto unknown;
-
- case 'r':
- switch (name[1])
- {
- case 'e':
- switch (name[2])
- {
- case 'n':
- if (name[3] == 'a' &&
- name[4] == 'm' &&
- name[5] == 'e')
- { /* rename */
- return -KEY_rename;
- }
-
- goto unknown;
-
- case 't':
- if (name[3] == 'u' &&
- name[4] == 'r' &&
- name[5] == 'n')
- { /* return */
- return KEY_return;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'i':
- if (name[2] == 'n' &&
- name[3] == 'd' &&
- name[4] == 'e' &&
- name[5] == 'x')
- { /* rindex */
- return -KEY_rindex;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 's':
- switch (name[1])
- {
- case 'c':
- if (name[2] == 'a' &&
- name[3] == 'l' &&
- name[4] == 'a' &&
- name[5] == 'r')
- { /* scalar */
- return KEY_scalar;
- }
-
- goto unknown;
-
- case 'e':
- switch (name[2])
- {
- case 'l':
- if (name[3] == 'e' &&
- name[4] == 'c' &&
- name[5] == 't')
- { /* select */
- return -KEY_select;
- }
-
- goto unknown;
-
- case 'm':
- switch (name[3])
- {
- case 'c':
- if (name[4] == 't' &&
- name[5] == 'l')
- { /* semctl */
- return -KEY_semctl;
- }
-
- goto unknown;
-
- case 'g':
- if (name[4] == 'e' &&
- name[5] == 't')
- { /* semget */
- return -KEY_semget;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 'h':
- if (name[2] == 'm')
- {
- switch (name[3])
- {
- case 'c':
- if (name[4] == 't' &&
- name[5] == 'l')
- { /* shmctl */
- return -KEY_shmctl;
- }
-
- goto unknown;
-
- case 'g':
- if (name[4] == 'e' &&
- name[5] == 't')
- { /* shmget */
- return -KEY_shmget;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'c' &&
- name[3] == 'k' &&
- name[4] == 'e' &&
- name[5] == 't')
- { /* socket */
- return -KEY_socket;
- }
-
- goto unknown;
-
- case 'p':
- if (name[2] == 'l' &&
- name[3] == 'i' &&
- name[4] == 'c' &&
- name[5] == 'e')
- { /* splice */
- return -KEY_splice;
- }
-
- goto unknown;
-
- case 'u':
- if (name[2] == 'b' &&
- name[3] == 's' &&
- name[4] == 't' &&
- name[5] == 'r')
- { /* substr */
- return -KEY_substr;
- }
-
- goto unknown;
-
- case 'y':
- if (name[2] == 's' &&
- name[3] == 't' &&
- name[4] == 'e' &&
- name[5] == 'm')
- { /* system */
- return -KEY_system;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'u':
- if (name[1] == 'n')
- {
- switch (name[2])
- {
- case 'l':
- switch (name[3])
- {
- case 'e':
- if (name[4] == 's' &&
- name[5] == 's')
- { /* unless */
- return KEY_unless;
- }
-
- goto unknown;
-
- case 'i':
- if (name[4] == 'n' &&
- name[5] == 'k')
- { /* unlink */
- return -KEY_unlink;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'p':
- if (name[3] == 'a' &&
- name[4] == 'c' &&
- name[5] == 'k')
- { /* unpack */
- return -KEY_unpack;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'v':
- if (name[1] == 'a' &&
- name[2] == 'l' &&
- name[3] == 'u' &&
- name[4] == 'e' &&
- name[5] == 's')
- { /* values */
- return -KEY_values;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 7: /* 29 tokens of length 7 */
- switch (name[0])
- {
- case 'D':
- if (name[1] == 'E' &&
- name[2] == 'S' &&
- name[3] == 'T' &&
- name[4] == 'R' &&
- name[5] == 'O' &&
- name[6] == 'Y')
- { /* DESTROY */
- return KEY_DESTROY;
- }
-
- goto unknown;
-
- case '_':
- if (name[1] == '_' &&
- name[2] == 'E' &&
- name[3] == 'N' &&
- name[4] == 'D' &&
- name[5] == '_' &&
- name[6] == '_')
- { /* __END__ */
- return KEY___END__;
- }
-
- goto unknown;
-
- case 'b':
- if (name[1] == 'i' &&
- name[2] == 'n' &&
- name[3] == 'm' &&
- name[4] == 'o' &&
- name[5] == 'd' &&
- name[6] == 'e')
- { /* binmode */
- return -KEY_binmode;
- }
-
- goto unknown;
-
- case 'c':
- if (name[1] == 'o' &&
- name[2] == 'n' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 'c' &&
- name[6] == 't')
- { /* connect */
- return -KEY_connect;
- }
-
- goto unknown;
-
- case 'd':
- switch (name[1])
- {
- case 'b':
- if (name[2] == 'm' &&
- name[3] == 'o' &&
- name[4] == 'p' &&
- name[5] == 'e' &&
- name[6] == 'n')
- { /* dbmopen */
- return -KEY_dbmopen;
- }
-
- goto unknown;
-
- case 'e':
- if (name[2] == 'f')
- {
- switch (name[3])
- {
- case 'a':
- if (name[4] == 'u' &&
- name[5] == 'l' &&
- name[6] == 't')
- { /* default */
- return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
- }
-
- goto unknown;
-
- case 'i':
- if (name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'f':
- if (name[1] == 'o' &&
- name[2] == 'r' &&
- name[3] == 'e' &&
- name[4] == 'a' &&
- name[5] == 'c' &&
- name[6] == 'h')
- { /* foreach */
- return KEY_foreach;
- }
-
- goto unknown;
-
- case 'g':
- if (name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'p')
- {
- switch (name[4])
- {
- case 'g':
- if (name[5] == 'r' &&
- name[6] == 'p')
- { /* getpgrp */
- return -KEY_getpgrp;
- }
-
- goto unknown;
-
- case 'p':
- if (name[5] == 'i' &&
- name[6] == 'd')
- { /* getppid */
- return -KEY_getppid;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'l':
- if (name[1] == 'c' &&
- name[2] == 'f' &&
- name[3] == 'i' &&
- name[4] == 'r' &&
- name[5] == 's' &&
- name[6] == 't')
- { /* lcfirst */
- return -KEY_lcfirst;
- }
-
- goto unknown;
-
- case 'o':
- if (name[1] == 'p' &&
- name[2] == 'e' &&
- name[3] == 'n' &&
- name[4] == 'd' &&
- name[5] == 'i' &&
- name[6] == 'r')
- { /* opendir */
- return -KEY_opendir;
- }
-
- goto unknown;
-
- case 'p':
- if (name[1] == 'a' &&
- name[2] == 'c' &&
- name[3] == 'k' &&
- name[4] == 'a' &&
- name[5] == 'g' &&
- name[6] == 'e')
- { /* package */
- return KEY_package;
- }
-
- goto unknown;
-
- case 'r':
- if (name[1] == 'e')
- {
- switch (name[2])
- {
- case 'a':
- if (name[3] == 'd' &&
- name[4] == 'd' &&
- name[5] == 'i' &&
- name[6] == 'r')
- { /* readdir */
- return -KEY_readdir;
- }
-
- goto unknown;
-
- case 'q':
- if (name[3] == 'u' &&
- name[4] == 'i' &&
- name[5] == 'r' &&
- name[6] == 'e')
- { /* require */
- return KEY_require;
- }
-
- goto unknown;
-
- case 'v':
- if (name[3] == 'e' &&
- name[4] == 'r' &&
- name[5] == 's' &&
- name[6] == 'e')
- { /* reverse */
- return -KEY_reverse;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 's':
- switch (name[1])
- {
- case 'e':
- switch (name[2])
- {
- case 'e':
- if (name[3] == 'k' &&
- name[4] == 'd' &&
- name[5] == 'i' &&
- name[6] == 'r')
- { /* seekdir */
- return -KEY_seekdir;
- }
-
- goto unknown;
-
- case 't':
- if (name[3] == 'p' &&
- name[4] == 'g' &&
- name[5] == 'r' &&
- name[6] == 'p')
- { /* setpgrp */
- return -KEY_setpgrp;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'h':
- if (name[2] == 'm' &&
- name[3] == 'r' &&
- name[4] == 'e' &&
- name[5] == 'a' &&
- name[6] == 'd')
- { /* shmread */
- return -KEY_shmread;
- }
-
- goto unknown;
-
- case 'p':
- if (name[2] == 'r' &&
- name[3] == 'i' &&
- name[4] == 'n' &&
- name[5] == 't' &&
- name[6] == 'f')
- { /* sprintf */
- return -KEY_sprintf;
- }
-
- goto unknown;
-
- case 'y':
- switch (name[2])
- {
- case 'm':
- if (name[3] == 'l' &&
- name[4] == 'i' &&
- name[5] == 'n' &&
- name[6] == 'k')
- { /* symlink */
- return -KEY_symlink;
- }
-
- goto unknown;
-
- case 's':
- switch (name[3])
- {
- case 'c':
- if (name[4] == 'a' &&
- name[5] == 'l' &&
- name[6] == 'l')
- { /* syscall */
- return -KEY_syscall;
- }
-
- goto unknown;
-
- case 'o':
- if (name[4] == 'p' &&
- name[5] == 'e' &&
- name[6] == 'n')
- { /* sysopen */
- return -KEY_sysopen;
- }
-
- goto unknown;
-
- case 'r':
- if (name[4] == 'e' &&
- name[5] == 'a' &&
- name[6] == 'd')
- { /* sysread */
- return -KEY_sysread;
- }
-
- goto unknown;
-
- case 's':
- if (name[4] == 'e' &&
- name[5] == 'e' &&
- name[6] == 'k')
- { /* sysseek */
- return -KEY_sysseek;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[1] == 'e' &&
- name[2] == 'l' &&
- name[3] == 'l' &&
- name[4] == 'd' &&
- name[5] == 'i' &&
- name[6] == 'r')
- { /* telldir */
- return -KEY_telldir;
- }
-
- goto unknown;
-
- case 'u':
- switch (name[1])
- {
- case 'c':
- if (name[2] == 'f' &&
- name[3] == 'i' &&
- name[4] == 'r' &&
- name[5] == 's' &&
- name[6] == 't')
- { /* ucfirst */
- return -KEY_ucfirst;
- }
-
- goto unknown;
-
- case 'n':
- if (name[2] == 's' &&
- name[3] == 'h' &&
- name[4] == 'i' &&
- name[5] == 'f' &&
- name[6] == 't')
- { /* unshift */
- return -KEY_unshift;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'w':
- if (name[1] == 'a' &&
- name[2] == 'i' &&
- name[3] == 't' &&
- name[4] == 'p' &&
- name[5] == 'i' &&
- name[6] == 'd')
- { /* waitpid */
- return -KEY_waitpid;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 8: /* 26 tokens of length 8 */
- switch (name[0])
- {
- case 'A':
- if (name[1] == 'U' &&
- name[2] == 'T' &&
- name[3] == 'O' &&
- name[4] == 'L' &&
- name[5] == 'O' &&
- name[6] == 'A' &&
- name[7] == 'D')
- { /* AUTOLOAD */
- return KEY_AUTOLOAD;
- }
-
- goto unknown;
-
- case '_':
- if (name[1] == '_')
- {
- switch (name[2])
- {
- case 'D':
- if (name[3] == 'A' &&
- name[4] == 'T' &&
- name[5] == 'A' &&
- name[6] == '_' &&
- name[7] == '_')
- { /* __DATA__ */
- return KEY___DATA__;
- }
-
- goto unknown;
-
- case 'F':
- if (name[3] == 'I' &&
- name[4] == 'L' &&
- name[5] == 'E' &&
- name[6] == '_' &&
- name[7] == '_')
- { /* __FILE__ */
- return -KEY___FILE__;
- }
-
- goto unknown;
-
- case 'L':
- if (name[3] == 'I' &&
- name[4] == 'N' &&
- name[5] == 'E' &&
- name[6] == '_' &&
- name[7] == '_')
- { /* __LINE__ */
- return -KEY___LINE__;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'c':
- switch (name[1])
- {
- case 'l':
- if (name[2] == 'o' &&
- name[3] == 's' &&
- name[4] == 'e' &&
- name[5] == 'd' &&
- name[6] == 'i' &&
- name[7] == 'r')
- { /* closedir */
- return -KEY_closedir;
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'n' &&
- name[3] == 't' &&
- name[4] == 'i' &&
- name[5] == 'n' &&
- name[6] == 'u' &&
- name[7] == 'e')
- { /* continue */
- return -KEY_continue;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'd':
- if (name[1] == 'b' &&
- name[2] == 'm' &&
- name[3] == 'c' &&
- name[4] == 'l' &&
- name[5] == 'o' &&
- name[6] == 's' &&
- name[7] == 'e')
- { /* dbmclose */
- return -KEY_dbmclose;
- }
-
- goto unknown;
-
- case 'e':
- if (name[1] == 'n' &&
- name[2] == 'd')
- {
- switch (name[3])
- {
- case 'g':
- if (name[4] == 'r' &&
- name[5] == 'e' &&
- name[6] == 'n' &&
- name[7] == 't')
- { /* endgrent */
- return -KEY_endgrent;
- }
-
- goto unknown;
-
- case 'p':
- if (name[4] == 'w' &&
- name[5] == 'e' &&
- name[6] == 'n' &&
- name[7] == 't')
- { /* endpwent */
- return -KEY_endpwent;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'f':
- if (name[1] == 'o' &&
- name[2] == 'r' &&
- name[3] == 'm' &&
- name[4] == 'l' &&
- name[5] == 'i' &&
- name[6] == 'n' &&
- name[7] == 'e')
- { /* formline */
- return -KEY_formline;
- }
-
- goto unknown;
-
- case 'g':
- if (name[1] == 'e' &&
- name[2] == 't')
- {
- switch (name[3])
- {
- case 'g':
- if (name[4] == 'r')
- {
- switch (name[5])
- {
- case 'e':
- if (name[6] == 'n' &&
- name[7] == 't')
- { /* getgrent */
- return -KEY_getgrent;
- }
-
- goto unknown;
-
- case 'g':
- if (name[6] == 'i' &&
- name[7] == 'd')
- { /* getgrgid */
- return -KEY_getgrgid;
- }
-
- goto unknown;
-
- case 'n':
- if (name[6] == 'a' &&
- name[7] == 'm')
- { /* getgrnam */
- return -KEY_getgrnam;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'l':
- if (name[4] == 'o' &&
- name[5] == 'g' &&
- name[6] == 'i' &&
- name[7] == 'n')
- { /* getlogin */
- return -KEY_getlogin;
- }
-
- goto unknown;
-
- case 'p':
- if (name[4] == 'w')
- {
- switch (name[5])
- {
- case 'e':
- if (name[6] == 'n' &&
- name[7] == 't')
- { /* getpwent */
- return -KEY_getpwent;
- }
-
- goto unknown;
-
- case 'n':
- if (name[6] == 'a' &&
- name[7] == 'm')
- { /* getpwnam */
- return -KEY_getpwnam;
- }
-
- goto unknown;
-
- case 'u':
- if (name[6] == 'i' &&
- name[7] == 'd')
- { /* getpwuid */
- return -KEY_getpwuid;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'r':
- if (name[1] == 'e' &&
- name[2] == 'a' &&
- name[3] == 'd')
- {
- switch (name[4])
- {
- case 'l':
- if (name[5] == 'i' &&
- name[6] == 'n')
- {
- switch (name[7])
- {
- case 'e':
- { /* readline */
- return -KEY_readline;
- }
-
- case 'k':
- { /* readlink */
- return -KEY_readlink;
- }
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'p':
- if (name[5] == 'i' &&
- name[6] == 'p' &&
- name[7] == 'e')
- { /* readpipe */
- return -KEY_readpipe;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 's':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 't')
- {
- switch (name[3])
- {
- case 'g':
- if (name[4] == 'r' &&
- name[5] == 'e' &&
- name[6] == 'n' &&
- name[7] == 't')
- { /* setgrent */
- return -KEY_setgrent;
- }
-
- goto unknown;
-
- case 'p':
- if (name[4] == 'w' &&
- name[5] == 'e' &&
- name[6] == 'n' &&
- name[7] == 't')
- { /* setpwent */
- return -KEY_setpwent;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'h':
- switch (name[2])
- {
- case 'm':
- if (name[3] == 'w' &&
- name[4] == 'r' &&
- name[5] == 'i' &&
- name[6] == 't' &&
- name[7] == 'e')
- { /* shmwrite */
- return -KEY_shmwrite;
- }
-
- goto unknown;
-
- case 'u':
- if (name[3] == 't' &&
- name[4] == 'd' &&
- name[5] == 'o' &&
- name[6] == 'w' &&
- name[7] == 'n')
- { /* shutdown */
- return -KEY_shutdown;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 'y':
- if (name[2] == 's' &&
- name[3] == 'w' &&
- name[4] == 'r' &&
- name[5] == 'i' &&
- name[6] == 't' &&
- name[7] == 'e')
- { /* syswrite */
- return -KEY_syswrite;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 't':
- if (name[1] == 'r' &&
- name[2] == 'u' &&
- name[3] == 'n' &&
- name[4] == 'c' &&
- name[5] == 'a' &&
- name[6] == 't' &&
- name[7] == 'e')
- { /* truncate */
- return -KEY_truncate;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 9: /* 9 tokens of length 9 */
- switch (name[0])
- {
- case 'U':
- if (name[1] == 'N' &&
- name[2] == 'I' &&
- name[3] == 'T' &&
- name[4] == 'C' &&
- name[5] == 'H' &&
- name[6] == 'E' &&
- name[7] == 'C' &&
- name[8] == 'K')
- { /* UNITCHECK */
- return KEY_UNITCHECK;
- }
-
- goto unknown;
-
- case 'e':
- if (name[1] == 'n' &&
- name[2] == 'd' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'e' &&
- name[7] == 'n' &&
- name[8] == 't')
- { /* endnetent */
- return -KEY_endnetent;
- }
-
- goto unknown;
-
- case 'g':
- if (name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'e' &&
- name[7] == 'n' &&
- name[8] == 't')
- { /* getnetent */
- return -KEY_getnetent;
- }
-
- goto unknown;
-
- case 'l':
- if (name[1] == 'o' &&
- name[2] == 'c' &&
- name[3] == 'a' &&
- name[4] == 'l' &&
- name[5] == 't' &&
- name[6] == 'i' &&
- name[7] == 'm' &&
- name[8] == 'e')
- { /* localtime */
- return -KEY_localtime;
- }
-
- goto unknown;
-
- case 'p':
- if (name[1] == 'r' &&
- name[2] == 'o' &&
- name[3] == 't' &&
- name[4] == 'o' &&
- name[5] == 't' &&
- name[6] == 'y' &&
- name[7] == 'p' &&
- name[8] == 'e')
- { /* prototype */
- return KEY_prototype;
- }
-
- goto unknown;
-
- case 'q':
- if (name[1] == 'u' &&
- name[2] == 'o' &&
- name[3] == 't' &&
- name[4] == 'e' &&
- name[5] == 'm' &&
- name[6] == 'e' &&
- name[7] == 't' &&
- name[8] == 'a')
- { /* quotemeta */
- return -KEY_quotemeta;
- }
-
- goto unknown;
-
- case 'r':
- if (name[1] == 'e' &&
- name[2] == 'w' &&
- name[3] == 'i' &&
- name[4] == 'n' &&
- name[5] == 'd' &&
- name[6] == 'd' &&
- name[7] == 'i' &&
- name[8] == 'r')
- { /* rewinddir */
- return -KEY_rewinddir;
- }
-
- goto unknown;
-
- case 's':
- if (name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'e' &&
- name[7] == 'n' &&
- name[8] == 't')
- { /* setnetent */
- return -KEY_setnetent;
- }
-
- goto unknown;
-
- case 'w':
- if (name[1] == 'a' &&
- name[2] == 'n' &&
- name[3] == 't' &&
- name[4] == 'a' &&
- name[5] == 'r' &&
- name[6] == 'r' &&
- name[7] == 'a' &&
- name[8] == 'y')
- { /* wantarray */
- return -KEY_wantarray;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 10: /* 9 tokens of length 10 */
- switch (name[0])
- {
- case 'e':
- if (name[1] == 'n' &&
- name[2] == 'd')
- {
- switch (name[3])
- {
- case 'h':
- if (name[4] == 'o' &&
- name[5] == 's' &&
- name[6] == 't' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* endhostent */
- return -KEY_endhostent;
- }
-
- goto unknown;
-
- case 's':
- if (name[4] == 'e' &&
- name[5] == 'r' &&
- name[6] == 'v' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* endservent */
- return -KEY_endservent;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'g':
- if (name[1] == 'e' &&
- name[2] == 't')
- {
- switch (name[3])
- {
- case 'h':
- if (name[4] == 'o' &&
- name[5] == 's' &&
- name[6] == 't' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* gethostent */
- return -KEY_gethostent;
- }
-
- goto unknown;
-
- case 's':
- switch (name[4])
- {
- case 'e':
- if (name[5] == 'r' &&
- name[6] == 'v' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* getservent */
- return -KEY_getservent;
- }
-
- goto unknown;
-
- case 'o':
- if (name[5] == 'c' &&
- name[6] == 'k' &&
- name[7] == 'o' &&
- name[8] == 'p' &&
- name[9] == 't')
- { /* getsockopt */
- return -KEY_getsockopt;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 's':
- switch (name[1])
- {
- case 'e':
- if (name[2] == 't')
- {
- switch (name[3])
- {
- case 'h':
- if (name[4] == 'o' &&
- name[5] == 's' &&
- name[6] == 't' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* sethostent */
- return -KEY_sethostent;
- }
-
- goto unknown;
-
- case 's':
- switch (name[4])
- {
- case 'e':
- if (name[5] == 'r' &&
- name[6] == 'v' &&
- name[7] == 'e' &&
- name[8] == 'n' &&
- name[9] == 't')
- { /* setservent */
- return -KEY_setservent;
- }
-
- goto unknown;
-
- case 'o':
- if (name[5] == 'c' &&
- name[6] == 'k' &&
- name[7] == 'o' &&
- name[8] == 'p' &&
- name[9] == 't')
- { /* setsockopt */
- return -KEY_setsockopt;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 'o':
- if (name[2] == 'c' &&
- name[3] == 'k' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'p' &&
- name[7] == 'a' &&
- name[8] == 'i' &&
- name[9] == 'r')
- { /* socketpair */
- return -KEY_socketpair;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 11: /* 8 tokens of length 11 */
- switch (name[0])
- {
- case '_':
- if (name[1] == '_' &&
- name[2] == 'P' &&
- name[3] == 'A' &&
- name[4] == 'C' &&
- name[5] == 'K' &&
- name[6] == 'A' &&
- name[7] == 'G' &&
- name[8] == 'E' &&
- name[9] == '_' &&
- name[10] == '_')
- { /* __PACKAGE__ */
- return -KEY___PACKAGE__;
- }
-
- goto unknown;
-
- case 'e':
- if (name[1] == 'n' &&
- name[2] == 'd' &&
- name[3] == 'p' &&
- name[4] == 'r' &&
- name[5] == 'o' &&
- name[6] == 't' &&
- name[7] == 'o' &&
- name[8] == 'e' &&
- name[9] == 'n' &&
- name[10] == 't')
- { /* endprotoent */
- return -KEY_endprotoent;
- }
-
- goto unknown;
-
- case 'g':
- if (name[1] == 'e' &&
- name[2] == 't')
- {
- switch (name[3])
- {
- case 'p':
- switch (name[4])
- {
- case 'e':
- if (name[5] == 'e' &&
- name[6] == 'r' &&
- name[7] == 'n' &&
- name[8] == 'a' &&
- name[9] == 'm' &&
- name[10] == 'e')
- { /* getpeername */
- return -KEY_getpeername;
- }
-
- goto unknown;
-
- case 'r':
- switch (name[5])
- {
- case 'i':
- if (name[6] == 'o' &&
- name[7] == 'r' &&
- name[8] == 'i' &&
- name[9] == 't' &&
- name[10] == 'y')
- { /* getpriority */
- return -KEY_getpriority;
- }
-
- goto unknown;
-
- case 'o':
- if (name[6] == 't' &&
- name[7] == 'o' &&
- name[8] == 'e' &&
- name[9] == 'n' &&
- name[10] == 't')
- { /* getprotoent */
- return -KEY_getprotoent;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- default:
- goto unknown;
- }
-
- case 's':
- if (name[4] == 'o' &&
- name[5] == 'c' &&
- name[6] == 'k' &&
- name[7] == 'n' &&
- name[8] == 'a' &&
- name[9] == 'm' &&
- name[10] == 'e')
- { /* getsockname */
- return -KEY_getsockname;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 's':
- if (name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'p' &&
- name[4] == 'r')
- {
- switch (name[5])
- {
- case 'i':
- if (name[6] == 'o' &&
- name[7] == 'r' &&
- name[8] == 'i' &&
- name[9] == 't' &&
- name[10] == 'y')
- { /* setpriority */
- return -KEY_setpriority;
- }
-
- goto unknown;
-
- case 'o':
- if (name[6] == 't' &&
- name[7] == 'o' &&
- name[8] == 'e' &&
- name[9] == 'n' &&
- name[10] == 't')
- { /* setprotoent */
- return -KEY_setprotoent;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
- case 12: /* 2 tokens of length 12 */
- if (name[0] == 'g' &&
- name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'n' &&
- name[4] == 'e' &&
- name[5] == 't' &&
- name[6] == 'b' &&
- name[7] == 'y')
- {
- switch (name[8])
- {
- case 'a':
- if (name[9] == 'd' &&
- name[10] == 'd' &&
- name[11] == 'r')
- { /* getnetbyaddr */
- return -KEY_getnetbyaddr;
- }
-
- goto unknown;
-
- case 'n':
- if (name[9] == 'a' &&
- name[10] == 'm' &&
- name[11] == 'e')
- { /* getnetbyname */
- return -KEY_getnetbyname;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 13: /* 4 tokens of length 13 */
- if (name[0] == 'g' &&
- name[1] == 'e' &&
- name[2] == 't')
- {
- switch (name[3])
- {
- case 'h':
- if (name[4] == 'o' &&
- name[5] == 's' &&
- name[6] == 't' &&
- name[7] == 'b' &&
- name[8] == 'y')
- {
- switch (name[9])
- {
- case 'a':
- if (name[10] == 'd' &&
- name[11] == 'd' &&
- name[12] == 'r')
- { /* gethostbyaddr */
- return -KEY_gethostbyaddr;
- }
-
- goto unknown;
-
- case 'n':
- if (name[10] == 'a' &&
- name[11] == 'm' &&
- name[12] == 'e')
- { /* gethostbyname */
- return -KEY_gethostbyname;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 's':
- if (name[4] == 'e' &&
- name[5] == 'r' &&
- name[6] == 'v' &&
- name[7] == 'b' &&
- name[8] == 'y')
- {
- switch (name[9])
- {
- case 'n':
- if (name[10] == 'a' &&
- name[11] == 'm' &&
- name[12] == 'e')
- { /* getservbyname */
- return -KEY_getservbyname;
- }
-
- goto unknown;
-
- case 'p':
- if (name[10] == 'o' &&
- name[11] == 'r' &&
- name[12] == 't')
- { /* getservbyport */
- return -KEY_getservbyport;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
- }
-
- goto unknown;
-
- case 14: /* 1 tokens of length 14 */
- if (name[0] == 'g' &&
- name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'p' &&
- name[4] == 'r' &&
- name[5] == 'o' &&
- name[6] == 't' &&
- name[7] == 'o' &&
- name[8] == 'b' &&
- name[9] == 'y' &&
- name[10] == 'n' &&
- name[11] == 'a' &&
- name[12] == 'm' &&
- name[13] == 'e')
- { /* getprotobyname */
- return -KEY_getprotobyname;
- }
-
- goto unknown;
-
- case 16: /* 1 tokens of length 16 */
- if (name[0] == 'g' &&
- name[1] == 'e' &&
- name[2] == 't' &&
- name[3] == 'p' &&
- name[4] == 'r' &&
- name[5] == 'o' &&
- name[6] == 't' &&
- name[7] == 'o' &&
- name[8] == 'b' &&
- name[9] == 'y' &&
- name[10] == 'n' &&
- name[11] == 'u' &&
- name[12] == 'm' &&
- name[13] == 'b' &&
- name[14] == 'e' &&
- name[15] == 'r')
- { /* getprotobynumber */
- return -KEY_getprotobynumber;
- }
-
- goto unknown;
-
- default:
- goto unknown;
- }
-
-unknown:
- return 0;
-}
-
-STATIC void
-S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_CHECKCOMMA;
-
- if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
- if (ckWARN(WARN_SYNTAX)) {
- int level = 1;
- const char *w;
- for (w = s+2; *w && level; w++) {
- if (*w == '(')
- ++level;
- else if (*w == ')')
- --level;
- }
- while (isSPACE(*w))
- ++w;
- /* the list of chars below is for end of statements or
- * block / parens, boolean operators (&&, ||, //) and branch
- * constructs (or, and, if, until, unless, while, err, for).
- * Not a very solid hack... */
- if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%s (...) interpreted as function",name);
- }
- }
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (*s == '(')
- s++;
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (isIDFIRST_lazy_if(s,UTF)) {
- const char * const w = s++;
- while (isALNUM_lazy_if(s,UTF))
- s++;
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (*s == ',') {
- GV* gv;
- if (keyword(w, s - w, 0))
- return;
-
- gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
- if (gv && GvCVu(gv))
- return;
- Perl_croak(aTHX_ "No comma allowed after %s", what);
- }
- }
-}
+ gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
+ if (gv && GvCVu(gv))
+ return;
+ Perl_croak(aTHX_ "No comma allowed after %s", what);
+ }
+ }
+}
/* Either returns sv, or mortalizes sv and returns a new SV*.
Best used as sv=new_constant(..., sv, ...).
}
bracket++;
PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
+ PL_lex_allbrackets++;
return s;
}
}
S_pmflag(U32 pmfl, const char ch) {
switch (ch) {
CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl);
- case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
- case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
- case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
- case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break;
+ case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
+ case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
+ case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
+ case KEEPCOPY_PAT_MOD: pmfl |= RXf_PMf_KEEPCOPY; break;
+ case NONDESTRUCT_PAT_MOD: pmfl |= PMf_NONDESTRUCT; break;
}
return pmfl;
}
-void
-Perl_pmflag(pTHX_ U32* pmfl, int ch)
-{
- PERL_ARGS_ASSERT_PMFLAG;
-
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Perl_pmflag() is deprecated, and will be removed from the XS API");
-
- if (ch<256) {
- *pmfl = S_pmflag(*pmfl, (char)ch);
- }
-}
-
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
#endif
while (*s && strchr(valid_flags, *s))
pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
+
+ if (isALNUM(*s)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+ "Having no space between pattern and following word is deprecated");
+
+ }
#ifdef PERL_MAD
if (PL_madskills && modstart != s) {
SV* tmptoken = newSVpvn(modstart, s - modstart);
}
else if (strchr(S_PAT_MODS, *s))
pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
- else
+ else {
+ if (isALNUM(*s)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+ "Having no space between pattern and following word is deprecated");
+
+ }
break;
+ }
}
#ifdef PERL_MAD
U8 squash;
U8 del;
U8 complement;
+ bool nondestruct = 0;
#ifdef PERL_MAD
char *modstart;
#endif
case 's':
squash = OPpTRANS_SQUASH;
break;
+ case 'r':
+ nondestruct = 1;
+ break;
default:
goto no_more;
}
no_more:
tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
- o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
- pl_yylval.ival = OP_TRANS;
+ pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
#ifdef PERL_MAD
if (PL_madskills) {
o->op_targ = tmp;
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, o,
+ op_append_elem(OP_LIST, o,
newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
: (OP*)newUNOP(OP_READLINE, 0, o);
}
SVt_PV);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
+ op_append_elem(OP_LIST,
newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
: (OP*)newUNOP(OP_READLINE, 0,
GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
+ op_append_elem(OP_LIST,
newGVOP(OP_GV, 0, gv),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
: (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
const char *base, *Base, *max;
/* check for hex */
- if (s[1] == 'x') {
+ if (s[1] == 'x' || s[1] == 'X') {
shift = 4;
s += 2;
just_zero = FALSE;
- } else if (s[1] == 'b') {
+ } else if (s[1] == 'b' || s[1] == 'B') {
shift = 1;
s += 2;
just_zero = FALSE;
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
- sv = newSV(0);
if (overflowed) {
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
- sv_setnv(sv, n);
+ sv = newSVnv(n);
}
else {
#if UVSIZE > 4
"%s number > %s non-portable",
Base, max);
#endif
- sv_setuv(sv, u);
+ sv = newSVuv(u);
}
if (just_zero && (PL_hints & HINT_NEW_INTEGER))
sv = new_constant(start, s - start, "integer",
}
- /* make an sv from the string */
- sv = newSV(0);
-
/*
We try to do an integer conversion first if no characters
indicating "float" have been found.
if (flags == IS_NUMBER_IN_UV) {
if (uv <= IV_MAX)
- sv_setiv(sv, uv); /* Prefer IVs over UVs. */
+ sv = newSViv(uv); /* Prefer IVs over UVs. */
else
- sv_setuv(sv, uv);
+ sv = newSVuv(uv);
} else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
if (uv <= (UV) IV_MIN)
- sv_setiv(sv, -(IV)uv);
+ sv = newSViv(-(IV)uv);
else
floatit = TRUE;
} else
/* terminate the string */
*d = '\0';
nv = Atof(PL_tokenbuf);
- sv_setnv(sv, nv);
+ sv = newSVnv(nv);
}
if ( floatit
SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
SV *const utf8_buffer = filter;
IV status = IoPAGE(filter);
- const bool reverse = (bool) IoLINES(filter);
+ const bool reverse = cBOOL(IoLINES(filter));
I32 retval;
+ PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
+
/* As we're automatically added, at the lowest level, and hence only called
from this file, we can be sure that we're not called in block mode. Hence
don't bother writing code to deal with block mode. */
{
SV *filter = filter_add(S_utf16_textfilter, NULL);
+ PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
+
IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
sv_setpvs(filter, "");
IoLINES(filter) = reversed;
return KEYWORD_PLUGIN_DECLINE;
}
+#define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
+static void
+S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
+{
+ SAVEI32(PL_lex_brackets);
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
+ SAVEI32(PL_lex_allbrackets);
+ PL_lex_allbrackets = 0;
+ SAVEI8(PL_lex_fakeeof);
+ PL_lex_fakeeof = (U8)fakeeof;
+ if(yyparse(gramtype) && !PL_parser->error_count)
+ qerror(Perl_mess(aTHX_ "Parse error"));
+}
+
+#define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
+static OP *
+S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
+{
+ OP *o;
+ ENTER;
+ SAVEVPTR(PL_eval_root);
+ PL_eval_root = NULL;
+ parse_recdescent(gramtype, fakeeof);
+ o = PL_eval_root;
+ LEAVE;
+ return o;
+}
+
+#define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
+static OP *
+S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
+{
+ OP *exprop;
+ if (flags & ~PARSE_OPTIONAL)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
+ exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
+ if (!exprop && !(flags & PARSE_OPTIONAL)) {
+ if (!PL_parser->error_count)
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ exprop = newOP(OP_NULL, 0);
+ }
+ return exprop;
+}
+
+/*
+=for apidoc Amx|OP *|parse_arithexpr|U32 flags
+
+Parse a Perl arithmetic expression. This may contain operators of precedence
+down to the bit shift operators. The expression must be followed (and thus
+terminated) either by a comparison or lower-precedence operator or by
+something that would normally terminate an expression such as semicolon.
+If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
+otherwise it is mandatory. 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 and the lexical context for the
+expression.
+
+The op tree representing the expression is returned. If an optional
+expression is absent, a null pointer is returned, otherwise the pointer
+will be non-null.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree 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. Some compilation
+errors, however, will throw an exception immediately.
+
+=cut
+*/
+
+OP *
+Perl_parse_arithexpr(pTHX_ U32 flags)
+{
+ return parse_expr(LEX_FAKEEOF_COMPARE, flags);
+}
+
+/*
+=for apidoc Amx|OP *|parse_termexpr|U32 flags
+
+Parse a Perl term expression. This may contain operators of precedence
+down to the assignment operators. The expression must be followed (and thus
+terminated) either by a comma or lower-precedence operator or by
+something that would normally terminate an expression such as semicolon.
+If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
+otherwise it is mandatory. 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 and the lexical context for the
+expression.
+
+The op tree representing the expression is returned. If an optional
+expression is absent, a null pointer is returned, otherwise the pointer
+will be non-null.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree 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. Some compilation
+errors, however, will throw an exception immediately.
+
+=cut
+*/
+
+OP *
+Perl_parse_termexpr(pTHX_ U32 flags)
+{
+ return parse_expr(LEX_FAKEEOF_COMMA, flags);
+}
+
+/*
+=for apidoc Amx|OP *|parse_listexpr|U32 flags
+
+Parse a Perl list expression. This may contain operators of precedence
+down to the comma operator. The expression must be followed (and thus
+terminated) either by a low-precedence logic operator such as C<or> or by
+something that would normally terminate an expression such as semicolon.
+If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
+otherwise it is mandatory. 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 and the lexical context for the
+expression.
+
+The op tree representing the expression is returned. If an optional
+expression is absent, a null pointer is returned, otherwise the pointer
+will be non-null.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree 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. Some compilation
+errors, however, will throw an exception immediately.
+
+=cut
+*/
+
+OP *
+Perl_parse_listexpr(pTHX_ U32 flags)
+{
+ return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
+}
+
+/*
+=for apidoc Amx|OP *|parse_fullexpr|U32 flags
+
+Parse a single complete Perl expression. This allows the full
+expression grammar, including the lowest-precedence operators such
+as C<or>. The expression must be followed (and thus terminated) by a
+token that an expression would normally be terminated by: end-of-file,
+closing bracketing punctuation, semicolon, or one of the keywords that
+signals a postfix expression-statement modifier. If I<flags> includes
+C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
+mandatory. 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 and the lexical context for the expression.
+
+The op tree representing the expression is returned. If an optional
+expression is absent, a null pointer is returned, otherwise the pointer
+will be non-null.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree 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. Some compilation
+errors, however, will throw an exception immediately.
+
+=cut
+*/
+
+OP *
+Perl_parse_fullexpr(pTHX_ U32 flags)
+{
+ return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
+}
+
+/*
+=for apidoc Amx|OP *|parse_block|U32 flags
+
+Parse a single complete Perl code block. This consists of an opening
+brace, a sequence of statements, and a closing brace. The block
+constitutes a lexical scope, so C<my> variables and various compile-time
+effects can be contained within it. 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 and the lexical context for
+the statement.
+
+The op tree representing the code block is returned. This is always a
+real op, never a null pointer. It will normally be a C<lineseq> list,
+including C<nextstate> or equivalent ops. No ops to construct any kind
+of runtime scope are included by virtue of it being a block.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) 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.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_block(pTHX_ U32 flags)
+{
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
+ return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
+}
+
+/*
+=for apidoc Amx|OP *|parse_barestmt|U32 flags
+
+Parse a single unadorned Perl statement. This may be a normal imperative
+statement or a declaration that has compile-time effect. It does not
+include any label or other affixture. 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 and the lexical context for
+the statement.
+
+The op tree representing the statement is returned. This may be a
+null pointer if the statement is null, for example if it was actually
+a subroutine definition (which has compile-time side effects). If not
+null, it will be ops directly implementing the statement, suitable to
+pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
+equivalent op (except for those embedded in a scope contained entirely
+within the statement).
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) 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.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_barestmt(pTHX_ U32 flags)
+{
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
+ return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
+}
+
+/*
+=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
+statement or a declaration that has compile-time effect, and may include
+optional labels. 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 and the lexical context for the statement.
+
+The op tree representing the statement is returned. This may be a
+null pointer if the statement is null, for example if it was actually
+a subroutine definition (which has compile-time side effects). If not
+null, it will be the result of a L</newSTATEOP> call, normally including
+a C<nextstate> or equivalent op.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) 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.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_fullstmt(pTHX_ U32 flags)
+{
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
+ return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
+}
+
+/*
+=for apidoc Amx|OP *|parse_stmtseq|U32 flags
+
+Parse a sequence of zero or more Perl statements. These may be normal
+imperative statements, including optional labels, or declarations
+that have compile-time effect, or any mixture thereof. The statement
+sequence ends when a closing brace or end-of-file is encountered in a
+place where a new statement could have validly started. 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 and the
+lexical context for the statements.
+
+The op tree representing the statement sequence is returned. This may
+be a null pointer if the statements were all null, for example if there
+were no statements or if there were only subroutine definitions (which
+have compile-time side effects). If not null, it will be a C<lineseq>
+list, normally including C<nextstate> or equivalent ops.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree 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. Some compilation
+errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_stmtseq(pTHX_ U32 flags)
+{
+ OP *stmtseqop;
+ I32 c;
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
+ stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
+ c = lex_peek_unichar(0);
+ if (c != -1 && c != /*{*/'}')
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return stmtseqop;
+}
+
+void
+Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
+{
+ PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
+ deprecate("qw(...) as parentheses");
+ force_next((4<<24)|')');
+ if (qwlist->op_type == OP_STUB) {
+ op_free(qwlist);
+ }
+ else {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = qwlist;
+ force_next(THING);
+ }
+ force_next((2<<24)|'(');
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff