#define PL_last_lop_op (PL_parser->last_lop_op)
#define PL_lex_state (PL_parser->lex_state)
#define PL_rsfp (PL_parser->rsfp)
+#define PL_rsfp_filters (PL_parser->rsfp_filters)
+#define PL_in_my (PL_parser->in_my)
+#define PL_in_my_stash (PL_parser->in_my_stash)
+#define PL_tokenbuf (PL_parser->tokenbuf)
+#define PL_multi_end (PL_parser->multi_end)
+#define PL_error_count (PL_parser->error_count)
#ifdef PERL_MAD
# define PL_endwhite (PL_parser->endwhite)
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
-static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
/*
* 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).
*/
void
-Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
{
dVAR;
const char *s = NULL;
STRLEN len;
- yy_parser *parser;
+ yy_parser *parser, *oparser;
/* create and initialise a parser */
Newxz(parser, 1, yy_parser);
- parser->old_parser = PL_parser;
+ parser->old_parser = oparser = PL_parser;
PL_parser = parser;
Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
/* on scope exit, free this parser and restore any outer one */
SAVEPARSER(parser);
+ parser->saved_curcop = PL_curcop;
/* initialise lexer state */
- SAVECOPLINE(PL_curcop);
-
#ifdef PERL_MAD
parser->curforce = -1;
#else
parser->nexttoke = 0;
#endif
parser->copline = NOLINE;
- PL_lex_state = LEX_NORMAL;
+ parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
+ parser->rsfp_filters = (new_filter || !oparser) ? newAV()
+ : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
void
Perl_parser_free(pTHX_ const yy_parser *parser)
{
+ PL_curcop = parser->saved_curcop;
SvREFCNT_dec(parser->linestr);
if (parser->rsfp == PerlIO_stdin())
else if (parser->rsfp && parser->old_parser
&& parser->rsfp != parser->old_parser->rsfp)
PerlIO_close(parser->rsfp);
+ SvREFCNT_dec(parser->rsfp_filters);
Safefree(parser->stack);
Safefree(parser->lex_brackstack);
/* keep a slot open for the head of the list? */
if (slot != '_' && *where && (*where)->mad_key == '^') {
(*where)->mad_key = slot;
- sv_free((*where)->mad_val);
+ sv_free((SV*)((*where)->mad_val));
(*where)->mad_val = (void*)sv;
}
else
if (!funcp)
return NULL;
+ if (!PL_parser)
+ return NULL;
+
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
FPTR2DPTR(void*, funcp)));
#endif
- if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
+ if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
#endif
: maxlen;
- if (!PL_rsfp_filters)
+ if (!PL_parser || !PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
}
- else {
- set_csh();
- }
}
#ifdef PERL_MAD
else
Perl_croak(aTHX_ "panic: yylex");
if (PL_madskills) {
- SV* const tmpsv = newSVpvs("");
- Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
+ SV* const tmpsv = newSVpvs("\\ ");
+ /* replace the space with the character we want to escape
+ */
+ SvPVX(tmpsv)[1] = *s;
curmad('_', tmpsv);
}
PL_bufptr = s + 1;
default:
if (isIDFIRST_lazy_if(s,UTF))
goto keylookup;
- Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
+ len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
+ Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
case 4:
case 26:
goto fake_eof; /* emulate EOF on ^D or ^Z */
switch (tmp) {
case KEY_or:
case KEY_and:
- case KEY_err:
case KEY_for:
case KEY_unless:
case KEY_if:
sv_free(sv);
CvMETHOD_on(PL_compcv);
}
- else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
- sv_free(sv);
- CvASSERTION_on(PL_compcv);
- }
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
--PL_lex_brackets;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
- if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
PL_lex_state = LEX_INTERPEND;
}
}
d++;
if (*d == ')' && (sv = gv_const_sv(gv))) {
s = d + 1;
-#ifdef PERL_MAD
- if (PL_madskills) {
- char *par = SvPVX(PL_linestr) + PL_realtokenstart;
- sv_catpvn(PL_thistoken, par, s - par);
- if (PL_nextwhite) {
- sv_free(PL_nextwhite);
- PL_nextwhite = 0;
- }
- }
- else
-#endif
- goto its_constant;
+ goto its_constant;
}
}
#ifdef PERL_MAD
"Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
- if ((sv = gv_const_sv(gv)) && !PL_madskills) {
+ if ((sv = gv_const_sv(gv))) {
its_constant:
SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
case KEY_eof:
UNI(OP_EOF);
- case KEY_err:
- OPERATOR(DOROP);
-
case KEY_exp:
UNI(OP_EXP);
UNI(OP_EACH);
case KEY_exec:
- set_csh();
LOP(OP_EXEC,XREF);
case KEY_endhostent:
OPERATOR(GIVEN);
case KEY_glob:
- set_csh();
LOP(OP_GLOB,XTERM);
case KEY_hex:
UNI(OP_READDIR);
case KEY_readline:
- set_csh();
UNIDOR(OP_READLINE);
case KEY_readpipe:
- set_csh();
UNIDOR(OP_BACKTICK);
case KEY_rewinddir:
}
case KEY_system:
- set_csh();
LOP(OP_SYSTEM,XREF);
case KEY_symlink:
goto unknown;
- case 'r':
- if (name[2] == 'r')
- { /* err */
- return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
- }
-
- goto unknown;
-
case 'x':
if (name[2] == 'p')
{ /* exp */
PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
- while (es-- > 0)
- sv_catpv(repl, (const char *)(es ? "eval " : "do "));
+ while (es-- > 0) {
+ if (es)
+ sv_catpvs(repl, "eval ");
+ else
+ sv_catpvs(repl, "do ");
+ }
sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
if (strchr(SvPVX(PL_lex_repl), '#'))
if (d - PL_tokenbuf != len) {
yylval.ival = OP_GLOB;
- set_csh();
s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
}
-STATIC void
-S_set_csh(pTHX)
-{
-#ifdef CSH
- dVAR;
- if (!PL_cshlen)
- PL_cshlen = strlen(PL_cshname);
-#else
-#if defined(USE_ITHREADS)
- PERL_UNUSED_CONTEXT;
-#endif
-#endif
-}
-
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
SV * const where_sv = sv_2mortal(newSVpvs("next char "));
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
- else if (isPRINT_LC(yychar))
- Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
+ else if (isPRINT_LC(yychar)) {
+ const unsigned char string = (unsigned char) yychar;
+ sv_catpvn(where_sv, &string, 1);
+ }
else
Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
where = SvPVX_const(where_sv);
(int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
PL_multi_end = 0;
}
- if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
+ if (PL_in_eval & EVAL_WARNONLY) {
+ if (ckWARN_d(WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
+ }
else
qerror(msg);
if (PL_error_count >= 10) {
https://perl5.git.perl.org / perl5.git / blobdiff