/* 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)
* LOOPX : loop exiting command (goto, last, dump, etc)
* FTST : file test operator
* FUN0 : zero-argument function
+ * FUN0OP : zero-argument function, with its op created in this file
* FUN1 : not used, except for not, which isn't a UNIOP
* BOop : bitwise or or xor
* BAop : bitwise and
#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
+#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
}
/* 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
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
{ FUNC, TOKENTYPE_OPNUM, "FUNC" },
{ FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
+ { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
{ FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
{ FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
{ FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
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
+/*
+=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, except for one flag that is currently reserved for perl's internal
+use.
-/*
- * 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).
- */
+=cut
+*/
+
+/* LEX_START_SAME_FILTER indicates that this is not a new file, so it
+ can share filters with the current parser. */
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 && flags != LEX_START_SAME_FILTER)
+ Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
/* create and initialise a 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 =
+ !(flags & LEX_START_SAME_FILTER) || !oparser
+ ? newAV()
+ : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
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] != ';' || !SvPOK(line)) {
- /* avoid tie/overload weirdness */
+ } 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;
}
/*
- * 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
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
}
/*
+=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.
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;
if (c != -1) {
if (c == '\n')
CopLINE_inc(PL_curcop);
- PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
+ if (UTF)
+ PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
+ else
+ ++(PL_parser->bufptr);
}
return c;
}
const char *t;
const char *n;
const char *e;
+ line_t line_num;
PERL_ARGS_ASSERT_INCLINE;
if (*e != '\n' && *e != '\0')
return; /* false alarm */
+ line_num = atoi(n)-1;
+
if (t - s > 0) {
const STRLEN len = t - s;
-#ifndef USE_ITHREADS
SV *const temp_sv = CopFILESV(PL_curcop);
const char *cf;
STRLEN tmplen;
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
/* adjust ${"::_<newfilename"} to store the new file name */
GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
- GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
- GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
+ /* The line number may differ. If that is the case,
+ alias the saved lines that are in the array.
+ Otherwise alias the whole array. */
+ if (CopLINE(PL_curcop) == line_num) {
+ GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
+ GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
+ }
+ else if (GvAV(*gvp)) {
+ AV * const av = GvAV(*gvp);
+ const I32 start = CopLINE(PL_curcop)+1;
+ I32 items = AvFILLp(av) - start;
+ if (items > 0) {
+ AV * const av2 = GvAVn(gv2);
+ SV **svp = AvARRAY(av) + start;
+ I32 l = (I32)line_num+1;
+ while (items--)
+ av_store(av2, l++, SvREFCNT_inc(*svp++));
+ }
+ }
}
if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
}
-#endif
CopFILE_free(PL_curcop);
CopFILE_setn(PL_curcop, s, len);
}
- CopLINE_set(PL_curcop, atoi(n)-1);
+ CopLINE_set(PL_curcop, line_num);
}
#ifdef PERL_MAD
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
void
Perl_yyunlex(pTHX)
{
- if (PL_parser->yychar != YYEMPTY) {
- start_force(-1);
- NEXTVAL_NEXTTOKE = PL_parser->yylval;
- force_next(PL_parser->yychar);
+ 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;
}
}
if (*s) {
const STRLEN len = strlen(s);
- OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
+ OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
+ UTF ? SVf_UTF8 : 0));
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
gv_fetchpvn_flags(s, len,
- PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADD,
+ (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
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;
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
- I32 has_utf8 = FALSE; /* Output constant is UTF8 */
- I32 this_utf8 = UTF; /* Is the source string assumed
+ bool has_utf8 = FALSE; /* Output constant is UTF8 */
+ bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
to be UTF8? But, this can
show as true when the source
isn't utf8, as for example
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++);
}
* 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);
if (PL_lex_inpat) {
- /* Pass through to the regex compiler unchanged. The
- * reason we evaluated the number above is to make sure
- * there wasn't a syntax error. */
+ /* On non-EBCDIC platforms, pass through to the regex
+ * compiler unchanged. The reason we evaluated the
+ * number above is to make sure there wasn't a syntax
+ * error. But on EBCDIC we convert to native so
+ * downstream code can continue to assume it's native
+ */
s -= 5; /* Include the '\N{U+' */
+#ifdef EBCDIC
+ d += my_snprintf(d, e - s + 1 + 1, /* includes the }
+ and the \0 */
+ "\\N{U+%X}",
+ (unsigned int) UNI_TO_NATIVE(uv));
+#else
Copy(s, d, e - s + 1, char); /* 1 = include the } */
d += e - s + 1;
+#endif
}
else { /* Not a pattern: convert the hex to string */
}
/* 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);
+ * boiler plate before it. For all these, we
+ * convert to native format so that downstream code
+ * can continue to assume the input is native */
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ "\\N{U+%X",
+ (unsigned int) UNI_TO_NATIVE(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) UNI_TO_NATIVE(uv));
d = off + SvGROW(sv, off
+ output_length
if (UTF8_IS_INVARIANT(*i)) {
if (! isALPHAU(*i)) problematic = TRUE;
} else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
- if (! isALPHAU(UNI_TO_NATIVE(UTF8_ACCUMULATE(*i,
+ if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
*(i+1)))))
{
problematic = TRUE;
continue;
} else if (isCHARNAME_CONT(
UNI_TO_NATIVE(
- UTF8_ACCUMULATE(*i, *(i+1)))))
+ TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
{
continue;
}
case 'c':
s++;
if (s < send) {
- *d++ = grok_bslash_c(*s++, 1);
+ *d++ = grok_bslash_c(*s++, has_utf8, 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 */
int len;
scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
len = (int)strlen(tmpbuf);
- if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
+ if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
+ UTF ? SVf_UTF8 : 0, SVt_PV))
weight -= 100;
else
weight -= 10;
#endif
goto bare_package;
}
- indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
+ indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
#ifdef PERL_MAD
soff = s - SvPVX(PL_linestr);
#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,
S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
if (PL_madskills)
- curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
+ curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
+ ( UTF ? SVf_UTF8 : 0 )));
PL_expect = XTERM;
force_next(WORD);
PL_bufptr = s;
if (len > 2 &&
(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
- (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
+ (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
{
return GvHV(gv); /* Foo:: */
}
/* use constant CLASS => 'MyClass' */
- gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
+ gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
if (gv && GvCV(gv)) {
SV * const sv = cv_const_sv(GvCV(gv));
if (sv)
pkgname = SvPV_const(sv, len);
}
- return gv_stashpvn(pkgname, len, 0);
+ return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
}
/*
* 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))));
}
};
#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
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++] =
+ (char) ((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"
*(U8*)s == 0xEF ||
*(U8*)s >= 0xFE ||
s[1] == 0)) {
- bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
+ Off_t offset = (IV)PerlIO_tell(PL_rsfp);
+ bof = (offset == (Off_t)SvCUR(PL_linestr));
+#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
+ /* offset may include swallowed CR */
+ if (!bof)
+ bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
+#endif
if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
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 '$':
PREREF('$');
}
- /* This kludge not intended to be bulletproof. */
- if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
- pl_yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(CopARYBASE_get(&PL_compiling)));
- pl_yylval.opval->op_private = OPpCONST_ARYBASE;
- TERM(THING);
- }
-
d = s;
{
const char tmp = *s;
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 */
else if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
- GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
+ GV *const gv = gv_fetchpvn_flags(s, start - s,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV);
if (!gv) {
s = scan_num(s, &pl_yylval);
TERM(THING);
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"))
GV *hgv = NULL; /* hidden (loser) */
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
- if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
+ if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
(cv = GvCVu(gv)))
{
if (GvIMPORTED_CV(gv))
hgv = gv;
}
if (!ogv &&
- (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
+ (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
+ UTF ? -len : len, FALSE)) &&
(gv = *gvp) && isGV_with_GP(gv) &&
GvCVu(gv) && GvIMPORTED_CV(gv))
{
}
/* 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 &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD)
- && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
+ && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
"Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
constants that might already be there into full
blown PVGVs with attached PVCV. */
gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- GV_NOADD_NOINIT, SVt_PVCV);
+ GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
+ SVt_PVCV);
}
len = 0;
}
if (len)
goto safe_bareword;
- cv = NULL;
{
- OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv));
+ OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(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);
}
(
(
*proto == '$' || *proto == '_'
- || *proto == '*'
+ || *proto == '*' || *proto == '+'
)
&& proto[1] == '\0'
)
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);
}
}
}
}
if (probable_sub) {
- gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
+ gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
+ SVt_PVCV);
op_free(pl_yylval.opval);
pl_yylval.opval = rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
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
}
d = PL_tokenbuf;
while (isLOWER(*d))
d++;
- if (!*d && !gv_stashpv(PL_tokenbuf, 0))
+ if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
}
case KEY___FILE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
- newSVpv(CopFILE(PL_curcop),0));
- TERM(THING);
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
+ );
case KEY___LINE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
- Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
- TERM(THING);
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
+ );
case KEY___PACKAGE__:
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ FUN0OP(
+ (OP*)newSVOP(OP_CONST, 0,
(PL_curstash
? newSVhek(HvNAME_HEK(PL_curstash))
- : &PL_sv_undef));
- TERM(THING);
+ : &PL_sv_undef))
+ );
case KEY___DATA__:
case KEY___END__: {
#else
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
#endif /* NETWARE */
-#ifdef PERLIO_IS_STDIO /* really? */
-# if defined(__BORLANDC__)
- /* XXX see note in do_binmode() */
- ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
-# endif
-#endif
if (loc > 0)
PerlIO_seek(PL_rsfp, loc, 0);
}
s += 2;
d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len, 0)))
+ if (!(tmp = keyword(PL_tokenbuf, len, 1)))
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
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_CHOP);
case KEY_continue:
- /* When 'use switch' is in effect, continue has a dual
- life as a control operator. */
- {
- if (!FEATURE_IS_ENABLED("switch"))
- PREBLOCK(CONTINUE);
- else {
/* We have to disambiguate the two senses of
"continue". If the next token is a '{' then
treat it as the start of a continue block;
PREBLOCK(CONTINUE);
else
FUN0(OP_CONTINUE);
- }
- }
case KEY_chdir:
/* may use HOME */
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);
missingterm(NULL);
PL_expect = XOPERATOR;
if (SvCUR(PL_lex_stuff)) {
- int warned = 0;
+ int warned_comma = !ckWARN(WARN_QW);
+ int warned_comment = warned_comma;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
for (; isSPACE(*d) && len; --len, ++d)
if (len) {
SV *sv;
const char *b = d;
- if (!warned && ckWARN(WARN_QW)) {
+ if (!warned_comma || !warned_comment) {
for (; !isSPACE(*d) && len; --len, ++d) {
- if (*d == ',') {
+ if (!warned_comma && *d == ',') {
Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to separate words with commas");
- ++warned;
+ ++warned_comma;
}
- else if (*d == '#') {
+ else if (!warned_comment && *d == '#') {
Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to put comments in qw() list");
- ++warned;
+ ++warned_comment;
}
}
}
/**/;
}
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)));
}
}
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:
*PL_tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
+ GV_ADD | (UTF ? SVf_UTF8 : 0));
else if (*s == '<')
yyerror("<> should be quotes");
}
SV *tmpwhite = 0;
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
- SV *subtoken = newSVpvn(tstart, s - tstart);
+ SV *subtoken = newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr));
PL_thistoken = 0;
d = s;
d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
#ifdef PERL_MAD
if (PL_madskills)
- nametoke = newSVpvn(s, d - s);
+ nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
#endif
if (memchr(tmpbuf, ':', len))
sv_setpvn(PL_subname, tmpbuf, len);
sv_catpvs(PL_subname,"::");
sv_catpvn(PL_subname,tmpbuf,len);
}
+ if (SvUTF8(PL_linestr))
+ SvUTF8_on(PL_subname);
have_name = TRUE;
#ifdef PERL_MAD
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);
yyerror(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
PL_tokenbuf));
- tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0);
+ tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
if (has_colon)
PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
pl_yylval.opval = newOP(OP_PADANY, 0);
- pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0);
+ pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
+ UTF ? SVf_UTF8 : 0);
return PRIVATEREF;
}
}
if (!has_colon) {
if (!PL_in_my)
- tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0);
+ tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
+ UTF ? SVf_UTF8 : 0);
if (tmp != NOT_IN_PAD) {
/* might be an "our" variable" */
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HEK * const stashname = HvNAME_HEK(stash);
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
- sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
+ sv_catsv(sym, newSVpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, SVs_TEMP | (UTF ? SVf_UTF8 : 0 )));
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
pl_yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchsv(sym,
*/
if (ckWARN(WARN_AMBIGUOUS) &&
pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
- SVt_PVAV);
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
+ ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
/* DO NOT warn for @- and @+ */
&& !( PL_tokenbuf[2] == '\0' &&
}
/* build ops for a bareword */
- pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
- tokenbuf_len - 1));
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
+ tokenbuf_len - 1,
+ UTF ? SVf_UTF8 : 0 ));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
- PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
+ (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
+ | ( UTF ? SVf_UTF8 : 0 ),
((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;
- }
+ gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
+ if (gv && GvCVu(gv))
+ return;
+ Perl_croak(aTHX_ "No comma allowed after %s", what);
+ }
+ }
+}
- case 'l':
- { /* until */
- return KEY_until;
- }
+/* Either returns sv, or mortalizes sv and returns a new SV*.
+ Best used as sv=new_constant(..., sv, ...).
+ If s, pv are NULL, calls subroutine with one argument,
+ and type is used with error messages only. */
- 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;
- }
+STATIC SV *
+S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
+ SV *sv, SV *pv, const char *type, STRLEN typelen)
+{
+ dVAR; dSP;
+ HV * const table = GvHV(PL_hintgv); /* ^H */
+ SV *res;
+ SV **cvp;
+ SV *cv, *typesv;
+ const char *why1 = "", *why2 = "", *why3 = "";
- goto unknown;
+ PERL_ARGS_ASSERT_NEW_CONSTANT;
- case 'g':
- if (name[4] == 'e' &&
- name[5] == 't')
- { /* msgget */
- return -KEY_msgget;
- }
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
+ SV *msg;
+
+ why2 = (const char *)
+ (strEQ(key,"charnames")
+ ? "(possibly a missing \"use charnames ...\")"
+ : "");
+ msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
+ (type ? type: "undef"), why2);
- 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);
- }
- }
-}
-
-/* Either returns sv, or mortalizes sv and returns a new SV*.
- Best used as sv=new_constant(..., sv, ...).
- If s, pv are NULL, calls subroutine with one argument,
- and type is used with error messages only. */
-
-STATIC SV *
-S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
- SV *sv, SV *pv, const char *type, STRLEN typelen)
-{
- dVAR; dSP;
- HV * const table = GvHV(PL_hintgv); /* ^H */
- SV *res;
- SV **cvp;
- SV *cv, *typesv;
- const char *why1 = "", *why2 = "", *why3 = "";
-
- PERL_ARGS_ASSERT_NEW_CONSTANT;
-
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- SV *msg;
-
- why2 = (const char *)
- (strEQ(key,"charnames")
- ? "(possibly a missing \"use charnames ...\")"
- : "");
- msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
- (type ? type: "undef"), why2);
-
- /* This is convoluted and evil ("goto considered harmful")
- * but I do not understand the intricacies of all the different
- * failure modes of %^H in here. The goal here is to make
- * the most probable error message user-friendly. --jhi */
+ /* This is convoluted and evil ("goto considered harmful")
+ * but I do not understand the intricacies of all the different
+ * failure modes of %^H in here. The goal here is to make
+ * the most probable error message user-friendly. --jhi */
goto msgdone;
const char * const brack =
(const char *)
((*s == '[') ? "[...]" : "{...}");
+ /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
bracket++;
PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
+ PL_lex_allbrackets++;
return s;
}
}
return s;
}
-static U32
-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 NONDESTRUCT_PAT_MOD: pmfl |= PMf_NONDESTRUCT; break;
- }
- return pmfl;
+static bool
+S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
+
+ /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
+ * the parse starting at 's', based on the subset that are valid in this
+ * context input to this routine in 'valid_flags'. Advances s. Returns
+ * TRUE if the input was a valid flag, so the next char may be as well;
+ * otherwise FALSE. 'charset' should point to a NUL upon first call on the
+ * current regex. This routine will set it to any charset modifier found.
+ * The caller shouldn't change it. This way, another charset modifier
+ * encountered in the parse can be detected as an error, as we have decided
+ * allow only one */
+
+ const char c = **s;
+
+ if (! strchr(valid_flags, c)) {
+ if (isALNUM(c)) {
+ goto deprecate;
+ }
+ return FALSE;
+ }
+
+ switch (c) {
+
+ 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 |= RXf_PMf_KEEPCOPY; break;
+ case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
+ case LOCALE_PAT_MOD:
+
+ /* In 5.14, qr//lt is legal but deprecated; the 't' means they
+ * can't be regex modifiers.
+ * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
+ * much as easily done. s///lei, for example, has to mean regex
+ * modifiers if it's not an error (as does any word character
+ * following the 'e'). Otherwise, we resolve to the backwards-
+ * compatible, but less likely 's/// le ...', i.e. as meaning
+ * less-than-or-equal. The reason it's not likely is that s//
+ * returns a number for code in the field (/r returns a string, but
+ * that wasn't added until the 5.13 series), and so '<=' should be
+ * used for comparing, not 'le'. */
+ if (*((*s) + 1) == 't') {
+ goto deprecate;
+ }
+ else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
+
+ /* 'e' is valid only for substitutes, s///e. If it is not
+ * valid in the current context, then 'm//le' must mean the
+ * comparison operator, so use the regular deprecation message.
+ */
+ if (! strchr(valid_flags, 'e')) {
+ goto deprecate;
+ }
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.16, it will be resolved the other way");
+ return FALSE;
+ }
+ if (*charset) {
+ goto multiple_charsets;
+ }
+ set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
+ *charset = c;
+ break;
+ case UNICODE_PAT_MOD:
+ /* In 5.14, qr//unless and qr//until are legal but deprecated; the
+ * 'n' means they can't be regex modifiers */
+ if (*((*s) + 1) == 'n') {
+ goto deprecate;
+ }
+ if (*charset) {
+ goto multiple_charsets;
+ }
+ set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
+ *charset = c;
+ break;
+ case ASCII_RESTRICT_PAT_MOD:
+ /* In 5.14, qr//and is legal but deprecated; the 'n' means they
+ * can't be regex modifiers */
+ if (*((*s) + 1) == 'n') {
+ goto deprecate;
+ }
+
+ if (! *charset) {
+ set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
+ }
+ else {
+
+ /* Error if previous modifier wasn't an 'a', but if it was, see
+ * if, and accept, a second occurrence (only) */
+ if (*charset != 'a'
+ || get_regex_charset(*pmfl)
+ != REGEX_ASCII_RESTRICTED_CHARSET)
+ {
+ goto multiple_charsets;
+ }
+ set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
+ }
+ *charset = c;
+ break;
+ case DEPENDS_PAT_MOD:
+ if (*charset) {
+ goto multiple_charsets;
+ }
+ set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
+ *charset = c;
+ break;
+ }
+
+ (*s)++;
+ return TRUE;
+
+ deprecate:
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+ "Having no space between pattern and following word is deprecated");
+ return FALSE;
+
+ multiple_charsets:
+ if (*charset != c) {
+ yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
+ }
+ else if (c == 'a') {
+ yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
+ }
+ else {
+ yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
+ }
+
+ /* Pretend that it worked, so will continue processing before dieing */
+ (*s)++;
+ return TRUE;
}
STATIC char *
char *s = scan_str(start,!!PL_madskills,FALSE);
const char * const valid_flags =
(const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
+ char charset = '\0'; /* character set modifier */
#ifdef PERL_MAD
char *modstart;
#endif
#ifdef PERL_MAD
modstart = s;
#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");
-
- }
+ while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
#ifdef PERL_MAD
if (PL_madskills && modstart != s) {
SV* tmptoken = newSVpvn(modstart, s - modstart);
S_scan_subst(pTHX_ char *start)
{
dVAR;
- register char *s;
+ char *s;
register PMOP *pm;
I32 first_start;
I32 es = 0;
+ char charset = '\0'; /* character set modifier */
#ifdef PERL_MAD
char *modstart;
#endif
s++;
es++;
}
- else if (strchr(S_PAT_MODS, *s))
- pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
- else {
- if (isALNUM(*s)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
- "Having no space between pattern and following word is deprecated");
-
- }
+ else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
+ {
break;
}
}
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) {
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
+ lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
sv_catsv(PL_linestr,herewas);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
/* try to find it in the pad for this block, otherwise find
add symbol table ops
*/
- const PADOFFSET tmp = pad_findmy(d, len, 0);
+ const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
if (tmp != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
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);
}
gv = gv_fetchpv(d,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADDMULTI),
+ : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
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,
/* If it's none of the above, it must be a literal filehandle
(<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
- GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
+ GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), 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));
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, including optional label, or a declaration that has
-compile-time effect. It is up to the caller to ensure that the dynamic
+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.
OP *
Perl_parse_fullstmt(pTHX_ U32 flags)
{
- OP *fullstmtop;
if (flags)
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
- ENTER;
- SAVEVPTR(PL_eval_root);
- PL_eval_root = NULL;
- if(yyparse(GRAMFULLSTMT) && !PL_parser->error_count)
+ 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"));
- fullstmtop = PL_eval_root;
- LEAVE;
- return fullstmtop;
+ return stmtseqop;
}
void
{
PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
deprecate("qw(...) as parentheses");
- force_next(')');
+ force_next((4<<24)|')');
if (qwlist->op_type == OP_STUB) {
op_free(qwlist);
}
NEXTVAL_NEXTTOKE.opval = qwlist;
force_next(THING);
}
- force_next('(');
+ force_next((2<<24)|'(');
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff