TOKENTYPE_IVAL,
TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
TOKENTYPE_PVAL,
- TOKENTYPE_OPVAL,
- TOKENTYPE_GVVAL
+ TOKENTYPE_OPVAL
};
static struct debug_tokens {
{ EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
+ { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
+ { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
{ FUNC, TOKENTYPE_OPNUM, "FUNC" },
{ FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
{ FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ { PEG, TOKENTYPE_NONE, "PEG" },
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
{ PREDEC, TOKENTYPE_NONE, "PREDEC" },
{ PREINC, TOKENTYPE_NONE, "PREINC" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
+ { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
{ RELOP, TOKENTYPE_OPNUM, "RELOP" },
+ { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SUB, TOKENTYPE_NONE, "SUB" },
{ THING, TOKENTYPE_OPVAL, "THING" },
Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
switch (type) {
case TOKENTYPE_NONE:
- case TOKENTYPE_GVVAL: /* doesn't appear to be used */
break;
case TOKENTYPE_IVAL:
Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
static void
strip_return(SV *sv)
{
- register const char *s = SvPVX_const(sv);
- register const char * const e = s + SvCUR(sv);
+ const char *s = SvPVX_const(sv);
+ const char * const e = s + SvCUR(sv);
PERL_ARGS_ASSERT_STRIP_RETURN;
while (s < e) {
if (*s++ == '\r' && *s == '\n') {
/* hit a CR-LF, need to copy the rest */
- register char *d = s - 1;
+ char *d = s - 1;
*d++ = *s++;
while (s < e) {
if (*s == '\r' && s[1] == '\n')
tokereport(type, &NEXTVAL_NEXTTOKE);
}
#endif
+ /* Don’t let opslab_force_free snatch it */
+ if (S_is_opval_token(type & 0xffff) && NEXTVAL_NEXTTOKE.opval) {
+ assert(!NEXTVAL_NEXTTOKE.opval->op_savefree);
+ NEXTVAL_NEXTTOKE.opval->op_savefree = 1;
+ }
#ifdef PERL_MAD
if (PL_curforce < 0)
start_force(PL_lasttoke);
S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
dVAR;
- register char *s;
+ char *s;
STRLEN len;
PERL_ARGS_ASSERT_FORCE_WORD;
S_tokeq(pTHX_ SV *sv)
{
dVAR;
- register char *s;
- register char *send;
- register char *d;
+ char *s;
+ char *send;
+ char *d;
STRLEN len = 0;
SV *pv = sv;
S_sublex_start(pTHX)
{
dVAR;
- register const I32 op_type = pl_yylval.ival;
+ const I32 op_type = pl_yylval.ival;
+ PL_sublex_info.super_bufptr = PL_bufptr;
+ PL_sublex_info.super_bufend = PL_bufend;
if (op_type == OP_NULL) {
pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_allbrackets);
+ SAVEI32(PL_lex_formbrack);
SAVEI8(PL_lex_fakeeof);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
SAVEFREESV(PL_linestr);
PL_lex_dojoin = FALSE;
- PL_lex_brackets = 0;
+ PL_lex_brackets = PL_lex_formbrack = 0;
PL_lex_allbrackets = 0;
PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
Newx(PL_lex_brackstack, 120, char);
S_scan_const(pTHX_ char *start)
{
dVAR;
- register char *send = PL_bufend; /* end of the constant */
+ char *send = PL_bufend; /* end of the constant */
SV *sv = newSV(send - start); /* sv for the constant. See
note below on sizing. */
- register char *s = start; /* start of the constant */
- register char *d = SvPVX(sv); /* destination for copies */
+ char *s = start; /* start of the constant */
+ 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? */
bool in_charclass = FALSE; /* within /[...]/ */
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
+ PL_expect = XTERM;
s = SKIPSPACE1(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
Perl_yylex(pTHX)
{
dVAR;
- register char *s = PL_bufptr;
- register char *d;
+ char *s = PL_bufptr;
+ char *d;
STRLEN len;
bool bof = FALSE;
+ U8 formbrack = 0;
U32 fake_eof = 0;
/* orig_keyword, gvp, and gv are initialized here because
PL_lex_allbrackets--;
next_type &= 0xffff;
}
+ if (S_is_opval_token(next_type) && pl_yylval.opval)
+ pl_yylval.opval->op_savefree = 0; /* release */
#ifdef PERL_MAD
/* FIXME - can these be merged? */
return next_type;
return yylex();
case LEX_FORMLINE:
- PL_lex_state = LEX_NORMAL;
s = scan_formline(PL_bufptr);
if (!PL_lex_formbrack)
+ {
+ formbrack = 1;
goto rightbracket;
- OPERATOR(';');
+ }
+ PL_bufptr = s;
+ return yylex();
}
s = PL_bufptr;
}
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
goto retry;
case '\r':
incline(s);
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
- return yylex();
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(FORMRBRACK);
+ TOKEN(';');
}
}
else {
}
TERM(']');
case '{':
- leftbracket:
s++;
+ leftbracket:
if (PL_lex_brackets > 100) {
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
}
switch (PL_expect) {
case XTERM:
- if (PL_lex_formbrack) {
- s--;
- PRETERMBLOCK(DO);
- }
if (PL_oldoldbufptr == PL_last_lop)
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
pl_yylval.ival = CopLINE(PL_curcop);
if (isSPACE(*s) || *s == '#')
PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN('{');
+ TOKEN(formbrack ? '=' : '{');
case '}':
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
TOKEN(0);
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) {
if (PL_lex_brackets == 0) {
if (PL_expect & XFAKEBRACK) {
curmad('X', newSVpvn(s-1,1));
CURMAD('_', PL_thiswhite);
}
- force_next('}');
+ force_next(formbrack ? '.' : '}');
+ if (formbrack) LEAVE;
#ifdef PERL_MAD
if (!PL_thistoken)
PL_thistoken = newSVpvs("");
#endif
+ if (formbrack == 2) { /* means . where arguments were expected */
+ start_force(PL_curforce);
+ force_next(';');
+ TOKEN(FORMRBRACK);
+ }
TOKEN(';');
case '&':
s++;
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
{
- if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
+ if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
+ || PL_lex_state != LEX_NORMAL) {
d = PL_bufend;
while (s < d) {
if (*s++ == '\n') {
goto retry;
}
}
- if (PL_lex_brackets < PL_lex_formbrack) {
+ if (PL_expect == XBLOCK) {
const char *t = s;
#ifdef PERL_STRICT_CR
while (SPACE_OR_TAB(*t))
#endif
t++;
if (*t == '\n' || *t == '#') {
- s--;
- PL_expect = XBLOCK;
+ formbrack = 1;
+ ENTER;
+ SAVEI8(PL_parser->form_lex_state);
+ SAVEI32(PL_lex_formbrack);
+ PL_parser->form_lex_state = PL_lex_state;
+ PL_lex_formbrack = PL_lex_brackets + 1;
goto leftbracket;
}
}
#endif
&& (s == PL_linestart || s[-1] == '\n') )
{
- PL_lex_formbrack = 0;
PL_expect = XSTATE;
+ formbrack = 2; /* dot seen where arguments expected */
goto rightbracket;
}
if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
case KEY_no:
s = tokenize_use(0, s);
- OPERATOR(USE);
+ TERM(USE);
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
}
if (key == KEY_format) {
- if (*s == '=')
- PL_lex_formbrack = PL_lex_brackets + 1;
#ifdef PERL_MAD
PL_thistoken = subtoken;
s = d;
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
#endif
- OPERATOR(FORMAT);
+ PREBLOCK(FORMAT);
}
/* Look for a prototype */
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
dVAR;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
PERL_ARGS_ASSERT_SCAN_WORD;
dVAR;
char *bracket = NULL;
char funny = *s++;
- register char *d = dest;
- register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+ char *d = dest;
+ char * const e = d + destlen - 3; /* two-character token, ending NUL */
PERL_ARGS_ASSERT_SCAN_IDENT;
{
dVAR;
char *s;
- register PMOP *pm;
+ PMOP *pm;
I32 first_start;
I32 es = 0;
char charset = '\0'; /* character set modifier */
if (es) {
SV * const repl = newSVpvs("");
- PL_sublex_info.super_bufptr = s;
- PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0) {
S_scan_trans(pTHX_ char *start)
{
dVAR;
- register char* s;
+ char* s;
OP *o;
U8 squash;
U8 del;
return s;
}
+/* scan_heredoc
+ Takes a pointer to the first < in <<FOO.
+ Returns a pointer to the byte following <<FOO.
+
+ This function scans a heredoc, which involves different methods
+ depending on whether we are in a string eval, quoted construct, etc.
+ This is because PL_linestr could containing a single line of input, or
+ a whole string being evalled, or the contents of the current quote-
+ like operator.
+
+ The three methods are:
+ - Steal lines from the input stream (stream)
+ - Scan the heredoc in PL_linestr and remove it therefrom (linestr)
+ - Peek at the PL_linestr of the outer lexing scope (peek)
+
+ They are used in these cases:
+ file scope or filtered eval stream
+ string eval linestr
+ multiline quoted construct linestr
+ single-line quoted construct in file stream
+ single-line quoted construct in eval peek
+
+ Single-line also applies to heredocs that begin on the last line of a
+ quote-like operator.
+*/
+
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
I32 len;
SV *tmpstr;
char term;
- const char *found_newline;
- register char *d;
- register char *e;
+ const char *found_newline = 0;
+ char *d;
+ char *e;
char *peek;
- const int outer = (PL_rsfp || PL_parser->filtered)
- && !(PL_lex_inwhat == OP_SCALAR);
+ const bool infile = PL_rsfp || PL_parser->filtered;
#ifdef PERL_MAD
I32 stuffstart = s - SvPVX(PL_linestr);
char *tstart;
PERL_ARGS_ASSERT_SCAN_HEREDOC;
s += 2;
- d = PL_tokenbuf;
+ d = PL_tokenbuf + 1;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
- if (!outer)
- *d++ = '\n';
+ *PL_tokenbuf = '\n';
peek = s;
while (SPACE_OR_TAB(*peek))
peek++;
#ifdef PERL_MAD
if (PL_madskills) {
- tstart = PL_tokenbuf + !outer;
- PL_thisclose = newSVpvn(tstart, len - !outer);
+ tstart = PL_tokenbuf + 1;
+ PL_thisclose = newSVpvn(tstart, len - 1);
tstart = SvPVX(PL_linestr) + stuffstart;
PL_thisopen = newSVpvn(tstart, s - tstart);
stuffstart = s - SvPVX(PL_linestr);
s = olds;
}
#endif
-#ifdef PERL_MAD
- found_newline = 0;
-#endif
- if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
+ if ((infile && !PL_lex_inwhat)
+ || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s))) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
CLINE;
PL_multi_start = CopLINE(PL_curcop);
PL_multi_open = PL_multi_close = '<';
- term = *PL_tokenbuf;
- if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp
- && !PL_parser->filtered) {
+ if (!infile && PL_lex_inwhat && !found_newline) {
char * const bufptr = PL_sublex_info.super_bufptr;
char * const bufend = PL_sublex_info.super_bufend;
char * const olds = s - SvCUR(herewas);
+ term = *PL_tokenbuf;
s = strchr(bufptr, '\n');
if (!s)
s = bufend;
}
if (s >= bufend) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
sv_setpvn(herewas,bufptr,d-bufptr+1);
sv_setpvn(tmpstr,d+1,s-d);
s = olds;
goto retval;
}
- else if (!outer) {
+ else if (!infile || found_newline) {
+ term = *PL_tokenbuf;
d = s;
while (s < PL_bufend &&
(*s != term || memNE(s,PL_tokenbuf,len)) ) {
}
if (s >= PL_bufend) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
sv_setpvn(tmpstr,d+1,s-d);
#ifdef PERL_MAD
}
else
sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
+ term = PL_tokenbuf[1];
+ len--;
while (s >= PL_bufend) { /* multiple line string? */
#ifdef PERL_MAD
if (PL_madskills) {
#endif
PL_bufptr = s;
CopLINE_inc(PL_curcop);
- if (!outer || !lex_next_chunk(0)) {
+ if (!lex_next_chunk(0)) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- missingterm(PL_tokenbuf);
+ missingterm(PL_tokenbuf + 1);
}
CopLINE_dec(PL_curcop);
s = PL_bufptr;
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (*s == term && memEQ(s,PL_tokenbuf,len)) {
+ if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
S_scan_inputsymbol(pTHX_ char *start)
{
dVAR;
- register char *s = start; /* current position in buffer */
+ char *s = start; /* current position in buffer */
char *end;
I32 len;
char *d = PL_tokenbuf; /* start of temp holding space */
dVAR;
SV *sv; /* scalar value: string */
const char *tmps; /* temp string, used for delimiter matching */
- register char *s = start; /* current position in the buffer */
- register char term; /* terminating character */
- register char *to; /* current position in the sv's data */
+ char *s = start; /* current position in the buffer */
+ char term; /* terminating character */
+ char *to; /* current position in the sv's data */
I32 brackets = 1; /* bracket nesting level */
bool has_utf8 = FALSE; /* is there any utf8 content? */
I32 termcode; /* terminating char. code */
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
dVAR;
- register const char *s = start; /* current position in buffer */
- register char *d; /* destination in temp buffer */
- register char *e; /* end of temp buffer */
+ const char *s = start; /* current position in buffer */
+ char *d; /* destination in temp buffer */
+ char *e; /* end of temp buffer */
NV nv; /* number read, as a double */
SV *sv = NULL; /* place to put the converted number */
bool floatit; /* boolean: int or float? */
S_scan_formline(pTHX_ register char *s)
{
dVAR;
- register char *eol;
- register char *t;
+ char *eol;
+ char *t;
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
break;
}
}
- if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
- eol = (char *) memchr(s,'\n',PL_bufend-s);
- if (!eol++)
+ eol = (char *) memchr(s,'\n',PL_bufend-s);
+ if (!eol++)
eol = PL_bufend;
- }
- else
- eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
if (*s != '#') {
for (t = s; t < eol; t++) {
if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
break;
}
s = (char*)eol;
- if (PL_rsfp || PL_parser->filtered) {
+ if ((PL_rsfp || PL_parser->filtered)
+ && PL_parser->form_lex_state == LEX_NORMAL) {
bool got_some;
#ifdef PERL_MAD
if (PL_madskills) {
incline(s);
}
enough:
+ if (!SvCUR(stuff) || needargs)
+ PL_lex_state = PL_parser->form_lex_state;
if (SvCUR(stuff)) {
- PL_expect = XTERM;
+ PL_expect = XSTATE;
if (needargs) {
- PL_lex_state = LEX_NORMAL;
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
+ force_next(FORMLBRACK);
}
- else
- PL_lex_state = LEX_FORMLINE;
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
SvUTF8_on(stuff);
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
- force_next(LSTOP);
}
else {
SvREFCNT_dec(stuff);
if (eofmt)
PL_lex_formbrack = 0;
- PL_bufptr = s;
}
#ifdef PERL_MAD
if (PL_madskills) {
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
- if (PL_compcv) {
- assert(SvTYPE(PL_compcv) == SVt_PVCV);
- }
SAVEI32(PL_subline);
save_item(PL_subname);
SAVESPTR(PL_compcv);
https://perl5.git.perl.org / perl5.git / blobdiff