#include "EXTERN.h"
#define PERL_IN_TOKE_C
#include "perl.h"
+#include "dquote_static.c"
#define new_constant(a,b,c,d,e,f,g) \
S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
#define pl_yylval (PL_parser->yylval)
-/* YYINITDEPTH -- initial size of the parser's stacks. */
-#define YYINITDEPTH 200
-
/* XXX temporary backwards compatibility */
#define PL_lex_brackets (PL_parser->lex_brackets)
#define PL_lex_brackstack (PL_parser->lex_brackstack)
parser->old_parser = oparser = PL_parser;
PL_parser = parser;
- Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
- parser->ps = parser->stack;
- parser->stack_size = YYINITDEPTH;
-
- parser->stack->state = 0;
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
+ parser->stack = NULL;
+ parser->ps = NULL;
+ parser->stack_size = 0;
/* on scope exit, free this parser and restore any outer one */
SAVEPARSER(parser);
if (!len) {
parser->linestr = newSVpvs("\n;");
- } else if (SvREADONLY(line) || s[len-1] != ';') {
- parser->linestr = newSVsv(line);
+ } else if (SvREADONLY(line) || s[len-1] != ';' || !SvPOK(line)) {
+ /* avoid tie/overload weirdness */
+ parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
if (s[len-1] != ';')
sv_catpvs(parser->linestr, "\n;");
} else {
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
- Safefree(parser->stack);
Safefree(parser->lex_brackstack);
Safefree(parser->lex_casestack);
PL_parser = parser->old_parser;
#endif
}
+void
+Perl_yyunlex(pTHX)
+{
+ if (PL_parser->yychar != YYEMPTY) {
+ start_force(-1);
+ NEXTVAL_NEXTTOKE = PL_parser->yylval;
+ force_next(PL_parser->yychar);
+ PL_parser->yychar = YYEMPTY;
+ }
+}
+
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
curmad('X', newSVpvn(s,d-s));
}
#endif
- if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
+ if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
#ifdef USE_LOCALE_NUMERIC
char *loc = setlocale(LC_NUMERIC, "C");
s = (char *)scan_version(s, ver, 0);
version = newSVOP(OP_CONST, 0, ver);
}
- else if ( (*s != ';' && *s != '}' ) && (s = SKIPSPACE1(s), (*s != ';' && *s !='}' ))) {
+ else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
+ (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
+ {
PL_bufptr = s;
if (errstr)
yyerror(errstr); /* version required */
s++;
- /* deprecate \1 in strings and substitution replacements */
+ /* warn on \1 - \9 in substitution replacements, but note that \11
+ * is an octal; and \19 is \1 followed by '9' */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
goto default_action;
}
- /* eg. \132 indicates the octal constant 0x132 */
+ /* eg. \132 indicates the octal constant 0132 */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
}
goto NUM_ESCAPE_INSERT;
+ /* eg. \o{24} indicates the octal constant \024 */
+ case 'o':
+ {
+ STRLEN len;
+ const char* error;
+
+ bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
+ s += len;
+ if (! valid) {
+ yyerror(error);
+ continue;
+ }
+ goto NUM_ESCAPE_INSERT;
+ }
+
/* eg. \x24 indicates the hex constant 0x24 */
case 'x':
++s;
* should the trailing NUL be missing that this
* print won't run off the end of the string */
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s", i - s + 1, s, e - i, i + 1);
+ "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
+ (int)(i - s + 1), s, (int)(e - i), i + 1);
}
}
} /* End \N{NAME} */
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
- IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
- IoANY(datasv) = (void *)NULL;
sv_free(av_pop(PL_rsfp_filters));
return;
PL_thismad = 0;
/* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return S_pending_ident(aTHX);
/* previous token ate up our whitespace? */
SvREFCNT_dec(tmp);
} );
/* check if there's an identifier for us to look at */
- if (PL_pending_ident)
+ if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
return REPORT(S_pending_ident(aTHX));
/* no identifier pending identification */
}
}
- if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
+ if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
PL_tokenbuf[0] = '@';
s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
int result;
char *saved_bufptr = PL_bufptr;
PL_bufptr = s;
- result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
+ result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
s = PL_bufptr;
if (result == KEYWORD_PLUGIN_DECLINE) {
/* not a plugged-in keyword */
gvp = 0;
if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous call resolved as CORE::%s(), %s",
- GvENAME(hgv), "qualify as such or use &");
+ "Ambiguous call resolved as CORE::%s(), "
+ "qualify as such or use &",
+ GvENAME(hgv));
}
}
/* if we saw a global override before, get the right name */
+ sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
+ len ? len : strlen(PL_tokenbuf));
if (gvp) {
+ SV * const tmp_sv = sv;
sv = newSVpvs("CORE::GLOBAL::");
- sv_catpv(sv,PL_tokenbuf);
- }
- else {
- /* If len is 0, newSVpv does strlen(), which is correct.
- If len is non-zero, then it will be the true length,
- and so the scalar will be created correctly. */
- sv = newSVpv(PL_tokenbuf,len);
+ sv_catsv(sv, tmp_sv);
+ SvREFCNT_dec(tmp_sv);
}
+
#ifdef PERL_MAD
if (PL_madskills && !PL_thistoken) {
char *start = SvPVX(PL_linestr) + PL_realtokenstart;
#endif
/* Presume this is going to be a bareword of some sort. */
-
CLINE;
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
pl_yylval.opval->op_private = OPpCONST_BARE;
- /* UTF-8 package name? */
- if (UTF && !IN_BYTES &&
- is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
- SvUTF8_on(sv);
/* And if "Foo::", then that's what it certainly is. */
-
if (len)
goto safe_bareword;
const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
if (!protolen)
TERM(FUNC0SUB);
- if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
- OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
+ if (
+ (
+ (
+ *proto == '$' || *proto == '_'
+ || *proto == '*'
+ )
+ && proto[1] == '\0'
+ )
+ || (
+ *proto == '\\' && proto[1] && proto[2] == '\0'
+ )
+ )
+ OPERATOR(UNIOPSUB);
+ if (*proto == '\\' && proto[1] == '[') {
+ const char *p = proto + 2;
+ while(*p && *p != ']')
+ ++p;
+ if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
+ }
if (*proto == '&' && *s == '{') {
if (PL_curstash)
sv_setpvs(PL_subname, "__ANON__");
s = force_word(s,WORD,FALSE,TRUE,FALSE);
s = SKIPSPACE1(s);
s = force_strict_version(s);
+ PL_lex_expect = XBLOCK;
OPERATOR(PACKAGE);
case KEY_pipe:
case KEY_quotemeta:
UNI(OP_QUOTEMETA);
- case KEY_qw:
+ case KEY_qw: {
+ OP *words = NULL;
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
PL_expect = XOPERATOR;
- force_next(')');
if (SvCUR(PL_lex_stuff)) {
- OP *words = NULL;
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
newSVOP(OP_CONST, 0, tokeq(sv)));
}
}
- if (words) {
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = words;
- force_next(THING);
- }
}
+ if (!words)
+ words = newNULLLIST();
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
PL_lex_stuff = NULL;
}
- PL_expect = XTERM;
- TOKEN('(');
+ PL_expect = XOPERATOR;
+ pl_yylval.opval = sawparens(words);
+ TOKEN(QWLIST);
+ }
case KEY_qq:
s = scan_str(s,!!PL_madskills,FALSE);
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
tokenbuf_len - 1));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpvn_flags(
- PL_tokenbuf + 1, tokenbuf_len - 1,
- /* If the identifier refers to a stash, don't autovivify it.
- * Change 24660 had the side effect of causing symbol table
- * hashes to always be defined, even if they were freshly
- * created and the only reference in the entire program was
- * the single statement with the defined %foo::bar:: test.
- * It appears that all code in the wild doing this actually
- * wants to know whether sub-packages have been loaded, so
- * by avoiding auto-vivifying symbol tables, we ensure that
- * defined %foo::bar:: continues to be false, and the existing
- * tests still give the expected answers, even though what
- * they're actually testing has now changed subtly.
- */
- (*PL_tokenbuf == '%'
- && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
- && d[-1] == ':'
- ? 0
- : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
+ gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
+ PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
return WORD;
}
if (name[1] == 'i' &&
name[2] == 'e')
{ /* tie */
- return KEY_tie;
+ return -KEY_tie;
}
goto unknown;
case 'e':
if (name[3] == 'd')
{ /* tied */
- return KEY_tied;
+ return -KEY_tied;
}
goto unknown;
{
case 'e':
{ /* untie */
- return KEY_untie;
+ return -KEY_untie;
}
case 'l':
S_pmflag(U32 pmfl, const char ch) {
switch (ch) {
CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl);
- case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
- case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
- case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
- case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break;
+ case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
+ case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
+ case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
+ case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break;
+ case NONDESTRUCT_PAT_MOD: pmfl |= PMf_NONDESTRUCT; break;
}
return pmfl;
}
#endif
while (*s && strchr(valid_flags, *s))
pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
+
+ if (isALNUM(*s)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+ "Having no space between pattern and following word is deprecated");
+
+ }
#ifdef PERL_MAD
if (PL_madskills && modstart != s) {
SV* tmptoken = newSVpvn(modstart, s - modstart);
}
else if (strchr(S_PAT_MODS, *s))
pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
- else
+ else {
+ if (isALNUM(*s)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
+ "Having no space between pattern and following word is deprecated");
+
+ }
break;
+ }
}
#ifdef PERL_MAD
const char *base, *Base, *max;
/* check for hex */
- if (s[1] == 'x') {
+ if (s[1] == 'x' || s[1] == 'X') {
shift = 4;
s += 2;
just_zero = FALSE;
- } else if (s[1] == 'b') {
+ } else if (s[1] == 'b' || s[1] == 'B') {
shift = 1;
s += 2;
just_zero = FALSE;
switch (*s) {
- case '.':
- /* Dot here is historically concat, not a radix point.
- Deprecate that; it's confusing, and gets in the way of
- hex(ish) fractions... but '..' is OK. */
- if (s[1] != '.') {
- Perl_ck_warner_d(aTHX_
- packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Dot after %s literal is deprecated concatenation",
- base);
- }
- /* FALL THROUGH */
-
/* if we don't mention it, we're done */
default:
goto out;
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
- sv = newSV(0);
if (overflowed) {
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
- sv_setnv(sv, n);
+ sv = newSVnv(n);
}
else {
#if UVSIZE > 4
"%s number > %s non-portable",
Base, max);
#endif
- sv_setuv(sv, u);
+ sv = newSVuv(u);
}
if (just_zero && (PL_hints & HINT_NEW_INTEGER))
sv = new_constant(start, s - start, "integer",
}
- /* make an sv from the string */
- sv = newSV(0);
-
/*
We try to do an integer conversion first if no characters
indicating "float" have been found.
if (flags == IS_NUMBER_IN_UV) {
if (uv <= IV_MAX)
- sv_setiv(sv, uv); /* Prefer IVs over UVs. */
+ sv = newSViv(uv); /* Prefer IVs over UVs. */
else
- sv_setuv(sv, uv);
+ sv = newSVuv(uv);
} else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
if (uv <= (UV) IV_MIN)
- sv_setiv(sv, -(IV)uv);
+ sv = newSViv(-(IV)uv);
else
floatit = TRUE;
} else
/* terminate the string */
*d = '\0';
nv = Atof(PL_tokenbuf);
- sv_setnv(sv, nv);
+ sv = newSVnv(nv);
}
if ( floatit
const bool reverse = cBOOL(IoLINES(filter));
I32 retval;
+ PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
+
/* As we're automatically added, at the lowest level, and hence only called
from this file, we can be sure that we're not called in block mode. Hence
don't bother writing code to deal with block mode. */
{
SV *filter = filter_add(S_utf16_textfilter, NULL);
+ PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
+
IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
sv_setpvs(filter, "");
IoLINES(filter) = reversed;
}
/*
+=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
+parser state (L</PL_parser> et al) is correctly set to reflect the source
+of the code to be parsed and the lexical context for the statement.
+
+The op tree representing the statement is returned. This may be a
+null pointer if the statement is null, for example if it was actually
+a subroutine definition (which has compile-time side effects). If not
+null, it will be the result of a L</newSTATEOP> call, normally including
+a C<nextstate> or equivalent op.
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) is returned anyway. The error is reflected in
+the parser state, normally resulting in a single exception at the top
+level of parsing which covers all the compilation errors that occurred.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_fullstmt(pTHX_ U32 flags)
+{
+ 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)
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ fullstmtop = PL_eval_root;
+ LEAVE;
+ return fullstmtop;
+}
+
+void
+Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
+{
+ PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
+ deprecate("qw(...) as parentheses");
+ force_next(')');
+ if (qwlist->op_type == OP_STUB) {
+ op_free(qwlist);
+ }
+ else {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = qwlist;
+ force_next(THING);
+ }
+ force_next('(');
+}
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff