3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_dojoin (PL_parser->lex_dojoin)
56 #define PL_lex_formbrack (PL_parser->lex_formbrack)
57 #define PL_lex_inpat (PL_parser->lex_inpat)
58 #define PL_lex_inwhat (PL_parser->lex_inwhat)
59 #define PL_lex_op (PL_parser->lex_op)
60 #define PL_lex_repl (PL_parser->lex_repl)
61 #define PL_lex_starts (PL_parser->lex_starts)
62 #define PL_lex_stuff (PL_parser->lex_stuff)
63 #define PL_multi_start (PL_parser->multi_start)
64 #define PL_multi_open (PL_parser->multi_open)
65 #define PL_multi_close (PL_parser->multi_close)
66 #define PL_preambled (PL_parser->preambled)
67 #define PL_linestr (PL_parser->linestr)
68 #define PL_expect (PL_parser->expect)
69 #define PL_copline (PL_parser->copline)
70 #define PL_bufptr (PL_parser->bufptr)
71 #define PL_oldbufptr (PL_parser->oldbufptr)
72 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
73 #define PL_linestart (PL_parser->linestart)
74 #define PL_bufend (PL_parser->bufend)
75 #define PL_last_uni (PL_parser->last_uni)
76 #define PL_last_lop (PL_parser->last_lop)
77 #define PL_last_lop_op (PL_parser->last_lop_op)
78 #define PL_lex_state (PL_parser->lex_state)
79 #define PL_rsfp (PL_parser->rsfp)
80 #define PL_rsfp_filters (PL_parser->rsfp_filters)
81 #define PL_in_my (PL_parser->in_my)
82 #define PL_in_my_stash (PL_parser->in_my_stash)
83 #define PL_tokenbuf (PL_parser->tokenbuf)
84 #define PL_multi_end (PL_parser->multi_end)
85 #define PL_error_count (PL_parser->error_count)
87 # define PL_nexttoke (PL_parser->nexttoke)
88 # define PL_nexttype (PL_parser->nexttype)
89 # define PL_nextval (PL_parser->nextval)
92 #define SvEVALED(sv) \
93 (SvTYPE(sv) >= SVt_PVNV \
94 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
96 static const char* const ident_too_long = "Identifier too long";
98 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
100 #define XENUMMASK 0x3f
101 #define XFAKEEOF 0x40
102 #define XFAKEBRACK 0x80
104 #ifdef USE_UTF8_SCRIPTS
105 # define UTF cBOOL(!IN_BYTES)
107 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
110 /* The maximum number of characters preceding the unrecognized one to display */
111 #define UNRECOGNIZED_PRECEDE_COUNT 10
113 /* In variables named $^X, these are the legal values for X.
114 * 1999-02-27 mjd-perl-patch@plover.com */
115 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
117 #define SPACE_OR_TAB(c) isBLANK_A(c)
119 #define HEXFP_PEEK(s) \
121 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
122 isALPHA_FOLD_EQ(s[0], 'p'))
124 /* LEX_* are values for PL_lex_state, the state of the lexer.
125 * They are arranged oddly so that the guard on the switch statement
126 * can get by with a single comparison (if the compiler is smart enough).
128 * These values refer to the various states within a sublex parse,
129 * i.e. within a double quotish string
132 /* #define LEX_NOTPARSING 11 is done in perl.h. */
134 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
135 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
136 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
137 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
138 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
140 /* at end of code, eg "$x" followed by: */
141 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
142 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
144 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
145 string or after \E, $foo, etc */
146 #define LEX_INTERPCONST 2 /* NOT USED */
147 #define LEX_FORMLINE 1 /* expecting a format line */
151 static const char* const lex_state_names[] = {
166 #include "keywords.h"
168 /* CLINE is a macro that ensures PL_copline has a sane value */
170 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
173 * Convenience functions to return different tokens and prime the
174 * lexer for the next token. They all take an argument.
176 * TOKEN : generic token (used for '(', DOLSHARP, etc)
177 * OPERATOR : generic operator
178 * AOPERATOR : assignment operator
179 * PREBLOCK : beginning the block after an if, while, foreach, ...
180 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
181 * PREREF : *EXPR where EXPR is not a simple identifier
182 * TERM : expression term
183 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
184 * LOOPX : loop exiting command (goto, last, dump, etc)
185 * FTST : file test operator
186 * FUN0 : zero-argument function
187 * FUN0OP : zero-argument function, with its op created in this file
188 * FUN1 : not used, except for not, which isn't a UNIOP
189 * BOop : bitwise or or xor
191 * BCop : bitwise complement
192 * SHop : shift operator
193 * PWop : power operator
194 * PMop : pattern-matching operator
195 * Aop : addition-level operator
196 * AopNOASSIGN : addition-level operator that is never part of .=
197 * Mop : multiplication-level operator
198 * Eop : equality-testing operator
199 * Rop : relational operator <= != gt
201 * Also see LOP and lop() below.
204 #ifdef DEBUGGING /* Serve -DT. */
205 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
207 # define REPORT(retval) (retval)
210 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
211 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
212 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
213 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
214 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
216 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
217 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
218 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
220 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
222 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
223 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
224 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
225 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
226 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
227 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
228 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
230 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
231 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
232 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
233 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
234 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
235 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
236 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
237 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
239 /* This bit of chicanery makes a unary function followed by
240 * a parenthesis into a function with one argument, highest precedence.
241 * The UNIDOR macro is for unary functions that can be followed by the //
242 * operator (such as C<shift // 0>).
244 #define UNI3(f,x,have_x) { \
245 pl_yylval.ival = f; \
246 if (have_x) PL_expect = x; \
248 PL_last_uni = PL_oldbufptr; \
249 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
251 return REPORT( (int)FUNC1 ); \
253 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
255 #define UNI(f) UNI3(f,XTERM,1)
256 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
257 #define UNIPROTO(f,optional) { \
258 if (optional) PL_last_uni = PL_oldbufptr; \
262 #define UNIBRACK(f) UNI3(f,0,0)
264 /* grandfather return to old style */
267 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
268 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
269 pl_yylval.ival = (f); \
275 #define COPLINE_INC_WITH_HERELINES \
277 CopLINE_inc(PL_curcop); \
278 if (PL_parser->herelines) \
279 CopLINE(PL_curcop) += PL_parser->herelines, \
280 PL_parser->herelines = 0; \
282 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
283 * is no sublex_push to follow. */
284 #define COPLINE_SET_FROM_MULTI_END \
286 CopLINE_set(PL_curcop, PL_multi_end); \
287 if (PL_multi_end != PL_multi_start) \
288 PL_parser->herelines = 0; \
294 /* how to interpret the pl_yylval associated with the token */
298 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
303 static struct debug_tokens {
305 enum token_type type;
307 } const debug_tokens[] =
309 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
310 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
311 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
312 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
313 { ARROW, TOKENTYPE_NONE, "ARROW" },
314 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
315 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
316 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
317 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
318 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
319 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
320 { DO, TOKENTYPE_NONE, "DO" },
321 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
322 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
323 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
324 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
325 { ELSE, TOKENTYPE_NONE, "ELSE" },
326 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
327 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
328 { FOR, TOKENTYPE_IVAL, "FOR" },
329 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
330 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
331 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
332 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
333 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
334 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
335 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
336 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
337 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
338 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
339 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
340 { IF, TOKENTYPE_IVAL, "IF" },
341 { LABEL, TOKENTYPE_PVAL, "LABEL" },
342 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
343 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
344 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
345 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
346 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
347 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
348 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
349 { MY, TOKENTYPE_IVAL, "MY" },
350 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
351 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
352 { OROP, TOKENTYPE_IVAL, "OROP" },
353 { OROR, TOKENTYPE_NONE, "OROR" },
354 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
355 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
356 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
357 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
358 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
359 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
360 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
361 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
362 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
363 { PREINC, TOKENTYPE_NONE, "PREINC" },
364 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
365 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
366 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
367 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
368 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
369 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
370 { SUB, TOKENTYPE_NONE, "SUB" },
371 { THING, TOKENTYPE_OPVAL, "THING" },
372 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
373 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
374 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
375 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
376 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
377 { USE, TOKENTYPE_IVAL, "USE" },
378 { WHEN, TOKENTYPE_IVAL, "WHEN" },
379 { WHILE, TOKENTYPE_IVAL, "WHILE" },
380 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
381 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
382 { 0, TOKENTYPE_NONE, NULL }
385 /* dump the returned token in rv, plus any optional arg in pl_yylval */
388 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
390 PERL_ARGS_ASSERT_TOKEREPORT;
393 const char *name = NULL;
394 enum token_type type = TOKENTYPE_NONE;
395 const struct debug_tokens *p;
396 SV* const report = newSVpvs("<== ");
398 for (p = debug_tokens; p->token; p++) {
399 if (p->token == (int)rv) {
406 Perl_sv_catpv(aTHX_ report, name);
407 else if (isGRAPH(rv))
409 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
411 sv_catpvs(report, " (pending identifier)");
414 sv_catpvs(report, "EOF");
416 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
421 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
423 case TOKENTYPE_OPNUM:
424 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
425 PL_op_name[lvalp->ival]);
428 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
430 case TOKENTYPE_OPVAL:
432 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
433 PL_op_name[lvalp->opval->op_type]);
434 if (lvalp->opval->op_type == OP_CONST) {
435 Perl_sv_catpvf(aTHX_ report, " %s",
436 SvPEEK(cSVOPx_sv(lvalp->opval)));
441 sv_catpvs(report, "(opval=null)");
444 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
450 /* print the buffer with suitable escapes */
453 S_printbuf(pTHX_ const char *const fmt, const char *const s)
455 SV* const tmp = newSVpvs("");
457 PERL_ARGS_ASSERT_PRINTBUF;
459 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
460 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
470 * This subroutine looks for an '=' next to the operator that has just been
471 * parsed and turns it into an ASSIGNOP if it finds one.
475 S_ao(pTHX_ int toketype)
477 if (*PL_bufptr == '=') {
479 if (toketype == ANDAND)
480 pl_yylval.ival = OP_ANDASSIGN;
481 else if (toketype == OROR)
482 pl_yylval.ival = OP_ORASSIGN;
483 else if (toketype == DORDOR)
484 pl_yylval.ival = OP_DORASSIGN;
487 return REPORT(toketype);
492 * When Perl expects an operator and finds something else, no_op
493 * prints the warning. It always prints "<something> found where
494 * operator expected. It prints "Missing semicolon on previous line?"
495 * if the surprise occurs at the start of the line. "do you need to
496 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
497 * where the compiler doesn't know if foo is a method call or a function.
498 * It prints "Missing operator before end of line" if there's nothing
499 * after the missing operator, or "... before <...>" if there is something
500 * after the missing operator.
502 * PL_bufptr is expected to point to the start of the thing that was found,
503 * and s after the next token or partial token.
507 S_no_op(pTHX_ const char *const what, char *s)
509 char * const oldbp = PL_bufptr;
510 const bool is_first = (PL_oldbufptr == PL_linestart);
512 PERL_ARGS_ASSERT_NO_OP;
518 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
519 if (ckWARN_d(WARN_SYNTAX)) {
521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
522 "\t(Missing semicolon on previous line?)\n");
523 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
528 for (t = PL_oldoldbufptr;
529 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
530 t += UTF ? UTF8SKIP(t) : 1)
534 if (t < PL_bufptr && isSPACE(*t))
535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
536 "\t(Do you need to predeclare %" UTF8f "?)\n",
537 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
541 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
542 "\t(Missing operator before %" UTF8f "?)\n",
543 UTF8fARG(UTF, s - oldbp, oldbp));
551 * Complain about missing quote/regexp/heredoc terminator.
552 * If it's called with NULL then it cauterizes the line buffer.
553 * If we're in a delimited string and the delimiter is a control
554 * character, it's reformatted into a two-char sequence like ^C.
559 S_missingterm(pTHX_ char *s)
561 char tmpbuf[UTF8_MAXBYTES + 1];
566 char * const nl = strrchr(s,'\n');
571 else if (PL_multi_close < 32) {
573 tmpbuf[1] = (char)toCTRL(PL_multi_close);
578 if (LIKELY(PL_multi_close < 256)) {
579 *tmpbuf = (char)PL_multi_close;
584 *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0;
588 q = strchr(s,'"') ? '\'' : '"';
589 sv = sv_2mortal(newSVpv(s,0));
592 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf
593 "%c anywhere before EOF",q,SVfARG(sv),q);
599 * Check whether the named feature is enabled.
602 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
604 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
606 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
608 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
610 if (namelen > MAX_FEATURE_LEN)
612 memcpy(&he_name[8], name, namelen);
614 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
615 REFCOUNTED_HE_EXISTS));
619 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
620 * utf16-to-utf8-reversed.
623 #ifdef PERL_CR_FILTER
627 const char *s = SvPVX_const(sv);
628 const char * const e = s + SvCUR(sv);
630 PERL_ARGS_ASSERT_STRIP_RETURN;
632 /* outer loop optimized to do nothing if there are no CR-LFs */
634 if (*s++ == '\r' && *s == '\n') {
635 /* hit a CR-LF, need to copy the rest */
639 if (*s == '\r' && s[1] == '\n')
650 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
652 const I32 count = FILTER_READ(idx+1, sv, maxlen);
653 if (count > 0 && !maxlen)
660 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
662 Creates and initialises a new lexer/parser state object, supplying
663 a context in which to lex and parse from a new source of Perl code.
664 A pointer to the new state object is placed in L</PL_parser>. An entry
665 is made on the save stack so that upon unwinding, the new state object
666 will be destroyed and the former value of L</PL_parser> will be restored.
667 Nothing else need be done to clean up the parsing context.
669 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
670 non-null, provides a string (in SV form) containing code to be parsed.
671 A copy of the string is made, so subsequent modification of C<line>
672 does not affect parsing. C<rsfp>, if non-null, provides an input stream
673 from which code will be read to be parsed. If both are non-null, the
674 code in C<line> comes first and must consist of complete lines of input,
675 and C<rsfp> supplies the remainder of the source.
677 The C<flags> parameter is reserved for future use. Currently it is only
678 used by perl internally, so extensions should always pass zero.
683 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
684 can share filters with the current parser.
685 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
686 caller, hence isn't owned by the parser, so shouldn't be closed on parser
687 destruction. This is used to handle the case of defaulting to reading the
688 script from the standard input because no filename was given on the command
689 line (without getting confused by situation where STDIN has been closed, so
690 the script handle is opened on fd 0) */
693 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
695 const char *s = NULL;
696 yy_parser *parser, *oparser;
698 if (flags && flags & ~LEX_START_FLAGS)
699 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
701 /* create and initialise a parser */
703 Newxz(parser, 1, yy_parser);
704 parser->old_parser = oparser = PL_parser;
707 parser->stack = NULL;
708 parser->stack_max1 = NULL;
711 /* on scope exit, free this parser and restore any outer one */
713 parser->saved_curcop = PL_curcop;
715 /* initialise lexer state */
717 parser->nexttoke = 0;
718 parser->error_count = oparser ? oparser->error_count : 0;
719 parser->copline = parser->preambling = NOLINE;
720 parser->lex_state = LEX_NORMAL;
721 parser->expect = XSTATE;
723 parser->recheck_utf8_validity = FALSE;
724 parser->rsfp_filters =
725 !(flags & LEX_START_SAME_FILTER) || !oparser
727 : MUTABLE_AV(SvREFCNT_inc(
728 oparser->rsfp_filters
729 ? oparser->rsfp_filters
730 : (oparser->rsfp_filters = newAV())
733 Newx(parser->lex_brackstack, 120, char);
734 Newx(parser->lex_casestack, 12, char);
735 *parser->lex_casestack = '\0';
736 Newxz(parser->lex_shared, 1, LEXSHARED);
740 const U8* first_bad_char_loc;
742 s = SvPV_const(line, len);
745 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
747 &first_bad_char_loc)))
749 _force_out_malformed_utf8_message(first_bad_char_loc,
750 (U8 *) s + SvCUR(line),
752 1 /* 1 means die */ );
753 NOT_REACHED; /* NOTREACHED */
756 parser->linestr = flags & LEX_START_COPIED
757 ? SvREFCNT_inc_simple_NN(line)
758 : newSVpvn_flags(s, len, SvUTF8(line));
760 sv_catpvs(parser->linestr, "\n;");
762 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
765 parser->oldoldbufptr =
768 parser->linestart = SvPVX(parser->linestr);
769 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
770 parser->last_lop = parser->last_uni = NULL;
772 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
773 |LEX_DONT_CLOSE_RSFP));
774 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
775 |LEX_DONT_CLOSE_RSFP));
777 parser->in_pod = parser->filtered = 0;
781 /* delete a parser object */
784 Perl_parser_free(pTHX_ const yy_parser *parser)
786 PERL_ARGS_ASSERT_PARSER_FREE;
788 PL_curcop = parser->saved_curcop;
789 SvREFCNT_dec(parser->linestr);
791 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
792 PerlIO_clearerr(parser->rsfp);
793 else if (parser->rsfp && (!parser->old_parser
794 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
795 PerlIO_close(parser->rsfp);
796 SvREFCNT_dec(parser->rsfp_filters);
797 SvREFCNT_dec(parser->lex_stuff);
798 SvREFCNT_dec(parser->lex_sub_repl);
800 Safefree(parser->lex_brackstack);
801 Safefree(parser->lex_casestack);
802 Safefree(parser->lex_shared);
803 PL_parser = parser->old_parser;
808 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
810 I32 nexttoke = parser->nexttoke;
811 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
813 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
814 && parser->nextval[nexttoke].opval
815 && parser->nextval[nexttoke].opval->op_slabbed
816 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
817 op_free(parser->nextval[nexttoke].opval);
818 parser->nextval[nexttoke].opval = NULL;
825 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
827 Buffer scalar containing the chunk currently under consideration of the
828 text currently being lexed. This is always a plain string scalar (for
829 which C<SvPOK> is true). It is not intended to be used as a scalar by
830 normal scalar means; instead refer to the buffer directly by the pointer
831 variables described below.
833 The lexer maintains various C<char*> pointers to things in the
834 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
835 reallocated, all of these pointers must be updated. Don't attempt to
836 do this manually, but rather use L</lex_grow_linestr> if you need to
837 reallocate the buffer.
839 The content of the text chunk in the buffer is commonly exactly one
840 complete line of input, up to and including a newline terminator,
841 but there are situations where it is otherwise. The octets of the
842 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
843 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
844 flag on this scalar, which may disagree with it.
846 For direct examination of the buffer, the variable
847 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
848 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
849 of these pointers is usually preferable to examination of the scalar
850 through normal scalar means.
852 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
854 Direct pointer to the end of the chunk of text currently being lexed, the
855 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
856 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
857 always located at the end of the buffer, and does not count as part of
858 the buffer's contents.
860 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
862 Points to the current position of lexing inside the lexer buffer.
863 Characters around this point may be freely examined, within
864 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
865 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
866 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
868 Lexing code (whether in the Perl core or not) moves this pointer past
869 the characters that it consumes. It is also expected to perform some
870 bookkeeping whenever a newline character is consumed. This movement
871 can be more conveniently performed by the function L</lex_read_to>,
872 which handles newlines appropriately.
874 Interpretation of the buffer's octets can be abstracted out by
875 using the slightly higher-level functions L</lex_peek_unichar> and
876 L</lex_read_unichar>.
878 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
880 Points to the start of the current line inside the lexer buffer.
881 This is useful for indicating at which column an error occurred, and
882 not much else. This must be updated by any lexing code that consumes
883 a newline; the function L</lex_read_to> handles this detail.
889 =for apidoc Amx|bool|lex_bufutf8
891 Indicates whether the octets in the lexer buffer
892 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
893 of Unicode characters. If not, they should be interpreted as Latin-1
894 characters. This is analogous to the C<SvUTF8> flag for scalars.
896 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
897 contains valid UTF-8. Lexing code must be robust in the face of invalid
900 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
901 is significant, but not the whole story regarding the input character
902 encoding. Normally, when a file is being read, the scalar contains octets
903 and its C<SvUTF8> flag is off, but the octets should be interpreted as
904 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
905 however, the scalar may have the C<SvUTF8> flag on, and in this case its
906 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
907 is in effect. This logic may change in the future; use this function
908 instead of implementing the logic yourself.
914 Perl_lex_bufutf8(pTHX)
920 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
922 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
923 at least C<len> octets (including terminating C<NUL>). Returns a
924 pointer to the reallocated buffer. This is necessary before making
925 any direct modification of the buffer that would increase its length.
926 L</lex_stuff_pvn> provides a more convenient way to insert text into
929 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
930 this function updates all of the lexer's variables that point directly
937 Perl_lex_grow_linestr(pTHX_ STRLEN len)
941 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
942 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
945 linestr = PL_parser->linestr;
946 buf = SvPVX(linestr);
947 if (len <= SvLEN(linestr))
950 /* Is the lex_shared linestr SV the same as the current linestr SV?
951 * Only in this case does re_eval_start need adjusting, since it
952 * points within lex_shared->ls_linestr's buffer */
953 current = ( !PL_parser->lex_shared->ls_linestr
954 || linestr == PL_parser->lex_shared->ls_linestr);
956 bufend_pos = PL_parser->bufend - buf;
957 bufptr_pos = PL_parser->bufptr - buf;
958 oldbufptr_pos = PL_parser->oldbufptr - buf;
959 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
960 linestart_pos = PL_parser->linestart - buf;
961 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
962 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
963 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
964 PL_parser->lex_shared->re_eval_start - buf : 0;
966 buf = sv_grow(linestr, len);
968 PL_parser->bufend = buf + bufend_pos;
969 PL_parser->bufptr = buf + bufptr_pos;
970 PL_parser->oldbufptr = buf + oldbufptr_pos;
971 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
972 PL_parser->linestart = buf + linestart_pos;
973 if (PL_parser->last_uni)
974 PL_parser->last_uni = buf + last_uni_pos;
975 if (PL_parser->last_lop)
976 PL_parser->last_lop = buf + last_lop_pos;
977 if (current && PL_parser->lex_shared->re_eval_start)
978 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
983 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
985 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
986 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
987 reallocating the buffer if necessary. This means that lexing code that
988 runs later will see the characters as if they had appeared in the input.
989 It is not recommended to do this as part of normal parsing, and most
990 uses of this facility run the risk of the inserted characters being
991 interpreted in an unintended manner.
993 The string to be inserted is represented by C<len> octets starting
994 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
995 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
996 The characters are recoded for the lexer buffer, according to how the
997 buffer is currently being interpreted (L</lex_bufutf8>). If a string
998 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
999 function is more convenient.
1005 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1009 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1010 if (flags & ~(LEX_STUFF_UTF8))
1011 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1013 if (flags & LEX_STUFF_UTF8) {
1016 STRLEN highhalf = 0; /* Count of variants */
1017 const char *p, *e = pv+len;
1018 for (p = pv; p != e; p++) {
1019 if (! UTF8_IS_INVARIANT(*p)) {
1025 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1026 bufptr = PL_parser->bufptr;
1027 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1028 SvCUR_set(PL_parser->linestr,
1029 SvCUR(PL_parser->linestr) + len+highhalf);
1030 PL_parser->bufend += len+highhalf;
1031 for (p = pv; p != e; p++) {
1033 if (! UTF8_IS_INVARIANT(c)) {
1034 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1035 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1037 *bufptr++ = (char)c;
1042 if (flags & LEX_STUFF_UTF8) {
1043 STRLEN highhalf = 0;
1044 const char *p, *e = pv+len;
1045 for (p = pv; p != e; p++) {
1047 if (UTF8_IS_ABOVE_LATIN1(c)) {
1048 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1049 "non-Latin-1 character into Latin-1 input");
1050 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1053 } else assert(UTF8_IS_INVARIANT(c));
1057 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1058 bufptr = PL_parser->bufptr;
1059 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1060 SvCUR_set(PL_parser->linestr,
1061 SvCUR(PL_parser->linestr) + len-highhalf);
1062 PL_parser->bufend += len-highhalf;
1065 if (UTF8_IS_INVARIANT(*p)) {
1071 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1077 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1078 bufptr = PL_parser->bufptr;
1079 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1080 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1081 PL_parser->bufend += len;
1082 Copy(pv, bufptr, len, char);
1088 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1090 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1091 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1092 reallocating the buffer if necessary. This means that lexing code that
1093 runs later will see the characters as if they had appeared in the input.
1094 It is not recommended to do this as part of normal parsing, and most
1095 uses of this facility run the risk of the inserted characters being
1096 interpreted in an unintended manner.
1098 The string to be inserted is represented by octets starting at C<pv>
1099 and continuing to the first nul. These octets are interpreted as either
1100 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1101 in C<flags>. The characters are recoded for the lexer buffer, according
1102 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1103 If it is not convenient to nul-terminate a string to be inserted, the
1104 L</lex_stuff_pvn> function is more appropriate.
1110 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1112 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1113 lex_stuff_pvn(pv, strlen(pv), flags);
1117 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1119 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1120 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1121 reallocating the buffer if necessary. This means that lexing code that
1122 runs later will see the characters as if they had appeared in the input.
1123 It is not recommended to do this as part of normal parsing, and most
1124 uses of this facility run the risk of the inserted characters being
1125 interpreted in an unintended manner.
1127 The string to be inserted is the string value of C<sv>. The characters
1128 are recoded for the lexer buffer, according to how the buffer is currently
1129 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1130 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1131 need to construct a scalar.
1137 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1141 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1143 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1145 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1149 =for apidoc Amx|void|lex_unstuff|char *ptr
1151 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1152 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1153 This hides the discarded text from any lexing code that runs later,
1154 as if the text had never appeared.
1156 This is not the normal way to consume lexed text. For that, use
1163 Perl_lex_unstuff(pTHX_ char *ptr)
1167 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1168 buf = PL_parser->bufptr;
1170 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1173 bufend = PL_parser->bufend;
1175 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1176 unstuff_len = ptr - buf;
1177 Move(ptr, buf, bufend+1-ptr, char);
1178 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1179 PL_parser->bufend = bufend - unstuff_len;
1183 =for apidoc Amx|void|lex_read_to|char *ptr
1185 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1186 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1187 performing the correct bookkeeping whenever a newline character is passed.
1188 This is the normal way to consume lexed text.
1190 Interpretation of the buffer's octets can be abstracted out by
1191 using the slightly higher-level functions L</lex_peek_unichar> and
1192 L</lex_read_unichar>.
1198 Perl_lex_read_to(pTHX_ char *ptr)
1201 PERL_ARGS_ASSERT_LEX_READ_TO;
1202 s = PL_parser->bufptr;
1203 if (ptr < s || ptr > PL_parser->bufend)
1204 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1205 for (; s != ptr; s++)
1207 COPLINE_INC_WITH_HERELINES;
1208 PL_parser->linestart = s+1;
1210 PL_parser->bufptr = ptr;
1214 =for apidoc Amx|void|lex_discard_to|char *ptr
1216 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1217 up to C<ptr>. The remaining content of the buffer will be moved, and
1218 all pointers into the buffer updated appropriately. C<ptr> must not
1219 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1220 it is not permitted to discard text that has yet to be lexed.
1222 Normally it is not necessarily to do this directly, because it suffices to
1223 use the implicit discarding behaviour of L</lex_next_chunk> and things
1224 based on it. However, if a token stretches across multiple lines,
1225 and the lexing code has kept multiple lines of text in the buffer for
1226 that purpose, then after completion of the token it would be wise to
1227 explicitly discard the now-unneeded earlier lines, to avoid future
1228 multi-line tokens growing the buffer without bound.
1234 Perl_lex_discard_to(pTHX_ char *ptr)
1238 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1239 buf = SvPVX(PL_parser->linestr);
1241 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1244 if (ptr > PL_parser->bufptr)
1245 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1246 discard_len = ptr - buf;
1247 if (PL_parser->oldbufptr < ptr)
1248 PL_parser->oldbufptr = ptr;
1249 if (PL_parser->oldoldbufptr < ptr)
1250 PL_parser->oldoldbufptr = ptr;
1251 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1252 PL_parser->last_uni = NULL;
1253 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1254 PL_parser->last_lop = NULL;
1255 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1256 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1257 PL_parser->bufend -= discard_len;
1258 PL_parser->bufptr -= discard_len;
1259 PL_parser->oldbufptr -= discard_len;
1260 PL_parser->oldoldbufptr -= discard_len;
1261 if (PL_parser->last_uni)
1262 PL_parser->last_uni -= discard_len;
1263 if (PL_parser->last_lop)
1264 PL_parser->last_lop -= discard_len;
1268 Perl_notify_parser_that_changed_to_utf8(pTHX)
1270 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1271 * off to on. At compile time, this has the effect of entering a 'use
1272 * utf8' section. This means that any input was not previously checked for
1273 * UTF-8 (because it was off), but now we do need to check it, or our
1274 * assumptions about the input being sane could be wrong, and we could
1275 * segfault. This routine just sets a flag so that the next time we look
1276 * at the input we do the well-formed UTF-8 check. If we aren't in the
1277 * proper phase, there may not be a parser object, but if there is, setting
1278 * the flag is harmless */
1281 PL_parser->recheck_utf8_validity = TRUE;
1286 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1288 Reads in the next chunk of text to be lexed, appending it to
1289 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1290 looked to the end of the current chunk and wants to know more. It is
1291 usual, but not necessary, for lexing to have consumed the entirety of
1292 the current chunk at this time.
1294 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1295 chunk (i.e., the current chunk has been entirely consumed), normally the
1296 current chunk will be discarded at the same time that the new chunk is
1297 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1298 will not be discarded. If the current chunk has not been entirely
1299 consumed, then it will not be discarded regardless of the flag.
1301 Returns true if some new text was added to the buffer, or false if the
1302 buffer has reached the end of the input text.
1307 #define LEX_FAKE_EOF 0x80000000
1308 #define LEX_NO_TERM 0x40000000 /* here-doc */
1311 Perl_lex_next_chunk(pTHX_ U32 flags)
1315 STRLEN old_bufend_pos, new_bufend_pos;
1316 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1317 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1318 bool got_some_for_debugger = 0;
1321 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1322 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1323 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1325 linestr = PL_parser->linestr;
1326 buf = SvPVX(linestr);
1327 if (!(flags & LEX_KEEP_PREVIOUS)
1328 && PL_parser->bufptr == PL_parser->bufend)
1330 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1332 if (PL_parser->last_uni != PL_parser->bufend)
1333 PL_parser->last_uni = NULL;
1334 if (PL_parser->last_lop != PL_parser->bufend)
1335 PL_parser->last_lop = NULL;
1336 last_uni_pos = last_lop_pos = 0;
1340 old_bufend_pos = PL_parser->bufend - buf;
1341 bufptr_pos = PL_parser->bufptr - buf;
1342 oldbufptr_pos = PL_parser->oldbufptr - buf;
1343 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1344 linestart_pos = PL_parser->linestart - buf;
1345 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1346 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1348 if (flags & LEX_FAKE_EOF) {
1350 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1352 } else if (filter_gets(linestr, old_bufend_pos)) {
1354 got_some_for_debugger = 1;
1355 } else if (flags & LEX_NO_TERM) {
1358 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1361 /* End of real input. Close filehandle (unless it was STDIN),
1362 * then add implicit termination.
1364 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1365 PerlIO_clearerr(PL_parser->rsfp);
1366 else if (PL_parser->rsfp)
1367 (void)PerlIO_close(PL_parser->rsfp);
1368 PL_parser->rsfp = NULL;
1369 PL_parser->in_pod = PL_parser->filtered = 0;
1370 if (!PL_in_eval && PL_minus_p) {
1372 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1373 PL_minus_n = PL_minus_p = 0;
1374 } else if (!PL_in_eval && PL_minus_n) {
1375 sv_catpvs(linestr, /*{*/";}");
1378 sv_catpvs(linestr, ";");
1381 buf = SvPVX(linestr);
1382 new_bufend_pos = SvCUR(linestr);
1383 PL_parser->bufend = buf + new_bufend_pos;
1384 PL_parser->bufptr = buf + bufptr_pos;
1387 const U8* first_bad_char_loc;
1388 if (UNLIKELY(! is_utf8_string_loc(
1389 (U8 *) PL_parser->bufptr,
1390 PL_parser->bufend - PL_parser->bufptr,
1391 &first_bad_char_loc)))
1393 _force_out_malformed_utf8_message(first_bad_char_loc,
1394 (U8 *) PL_parser->bufend,
1396 1 /* 1 means die */ );
1397 NOT_REACHED; /* NOTREACHED */
1401 PL_parser->oldbufptr = buf + oldbufptr_pos;
1402 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1403 PL_parser->linestart = buf + linestart_pos;
1404 if (PL_parser->last_uni)
1405 PL_parser->last_uni = buf + last_uni_pos;
1406 if (PL_parser->last_lop)
1407 PL_parser->last_lop = buf + last_lop_pos;
1408 if (PL_parser->preambling != NOLINE) {
1409 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1410 PL_parser->preambling = NOLINE;
1412 if ( got_some_for_debugger
1413 && PERLDB_LINE_OR_SAVESRC
1414 && PL_curstash != PL_debstash)
1416 /* debugger active and we're not compiling the debugger code,
1417 * so store the line into the debugger's array of lines
1419 update_debugger_info(NULL, buf+old_bufend_pos,
1420 new_bufend_pos-old_bufend_pos);
1426 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1428 Looks ahead one (Unicode) character in the text currently being lexed.
1429 Returns the codepoint (unsigned integer value) of the next character,
1430 or -1 if lexing has reached the end of the input text. To consume the
1431 peeked character, use L</lex_read_unichar>.
1433 If the next character is in (or extends into) the next chunk of input
1434 text, the next chunk will be read in. Normally the current chunk will be
1435 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1436 bit set, then the current chunk will not be discarded.
1438 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1439 is encountered, an exception is generated.
1445 Perl_lex_peek_unichar(pTHX_ U32 flags)
1449 if (flags & ~(LEX_KEEP_PREVIOUS))
1450 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1451 s = PL_parser->bufptr;
1452 bufend = PL_parser->bufend;
1458 if (!lex_next_chunk(flags))
1460 s = PL_parser->bufptr;
1461 bufend = PL_parser->bufend;
1464 if (UTF8_IS_INVARIANT(head))
1466 if (UTF8_IS_START(head)) {
1467 len = UTF8SKIP(&head);
1468 while ((STRLEN)(bufend-s) < len) {
1469 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1471 s = PL_parser->bufptr;
1472 bufend = PL_parser->bufend;
1475 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1476 if (retlen == (STRLEN)-1) {
1477 _force_out_malformed_utf8_message((U8 *) s,
1480 1 /* 1 means die */ );
1481 NOT_REACHED; /* NOTREACHED */
1486 if (!lex_next_chunk(flags))
1488 s = PL_parser->bufptr;
1495 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1497 Reads the next (Unicode) character in the text currently being lexed.
1498 Returns the codepoint (unsigned integer value) of the character read,
1499 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1500 if lexing has reached the end of the input text. To non-destructively
1501 examine the next character, use L</lex_peek_unichar> instead.
1503 If the next character is in (or extends into) the next chunk of input
1504 text, the next chunk will be read in. Normally the current chunk will be
1505 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1506 bit set, then the current chunk will not be discarded.
1508 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1509 is encountered, an exception is generated.
1515 Perl_lex_read_unichar(pTHX_ U32 flags)
1518 if (flags & ~(LEX_KEEP_PREVIOUS))
1519 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1520 c = lex_peek_unichar(flags);
1523 COPLINE_INC_WITH_HERELINES;
1525 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1527 ++(PL_parser->bufptr);
1533 =for apidoc Amx|void|lex_read_space|U32 flags
1535 Reads optional spaces, in Perl style, in the text currently being
1536 lexed. The spaces may include ordinary whitespace characters and
1537 Perl-style comments. C<#line> directives are processed if encountered.
1538 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1539 at a non-space character (or the end of the input text).
1541 If spaces extend into the next chunk of input text, the next chunk will
1542 be read in. Normally the current chunk will be discarded at the same
1543 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1544 chunk will not be discarded.
1549 #define LEX_NO_INCLINE 0x40000000
1550 #define LEX_NO_NEXT_CHUNK 0x80000000
1553 Perl_lex_read_space(pTHX_ U32 flags)
1556 const bool can_incline = !(flags & LEX_NO_INCLINE);
1557 bool need_incline = 0;
1558 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1559 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1560 s = PL_parser->bufptr;
1561 bufend = PL_parser->bufend;
1567 } while (!(c == '\n' || (c == 0 && s == bufend)));
1568 } else if (c == '\n') {
1571 PL_parser->linestart = s;
1577 } else if (isSPACE(c)) {
1579 } else if (c == 0 && s == bufend) {
1582 if (flags & LEX_NO_NEXT_CHUNK)
1584 PL_parser->bufptr = s;
1585 l = CopLINE(PL_curcop);
1586 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1587 got_more = lex_next_chunk(flags);
1588 CopLINE_set(PL_curcop, l);
1589 s = PL_parser->bufptr;
1590 bufend = PL_parser->bufend;
1593 if (can_incline && need_incline && PL_parser->rsfp) {
1603 PL_parser->bufptr = s;
1608 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1610 This function performs syntax checking on a prototype, C<proto>.
1611 If C<warn> is true, any illegal characters or mismatched brackets
1612 will trigger illegalproto warnings, declaring that they were
1613 detected in the prototype for C<name>.
1615 The return value is C<true> if this is a valid prototype, and
1616 C<false> if it is not, regardless of whether C<warn> was C<true> or
1619 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1626 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1628 STRLEN len, origlen;
1630 bool bad_proto = FALSE;
1631 bool in_brackets = FALSE;
1632 bool after_slash = FALSE;
1633 char greedy_proto = ' ';
1634 bool proto_after_greedy_proto = FALSE;
1635 bool must_be_last = FALSE;
1636 bool underscore = FALSE;
1637 bool bad_proto_after_underscore = FALSE;
1639 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1644 p = SvPV(proto, len);
1646 for (; len--; p++) {
1649 proto_after_greedy_proto = TRUE;
1651 if (!strchr(";@%", *p))
1652 bad_proto_after_underscore = TRUE;
1655 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1662 in_brackets = FALSE;
1663 else if ((*p == '@' || *p == '%')
1667 must_be_last = TRUE;
1676 after_slash = FALSE;
1681 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1684 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1685 origlen, UNI_DISPLAY_ISPRINT)
1686 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1688 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1689 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1690 sv_catpvs(name2, "::");
1691 sv_catsv(name2, (SV *)name);
1695 if (proto_after_greedy_proto)
1696 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1697 "Prototype after '%c' for %" SVf " : %s",
1698 greedy_proto, SVfARG(name), p);
1700 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1701 "Missing ']' in prototype for %" SVf " : %s",
1704 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1705 "Illegal character in prototype for %" SVf " : %s",
1707 if (bad_proto_after_underscore)
1708 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1709 "Illegal character after '_' in prototype for %" SVf " : %s",
1713 return (! (proto_after_greedy_proto || bad_proto) );
1718 * This subroutine has nothing to do with tilting, whether at windmills
1719 * or pinball tables. Its name is short for "increment line". It
1720 * increments the current line number in CopLINE(PL_curcop) and checks
1721 * to see whether the line starts with a comment of the form
1722 * # line 500 "foo.pm"
1723 * If so, it sets the current line number and file to the values in the comment.
1727 S_incline(pTHX_ const char *s)
1735 PERL_ARGS_ASSERT_INCLINE;
1737 COPLINE_INC_WITH_HERELINES;
1738 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1739 && s+1 == PL_bufend && *s == ';') {
1740 /* fake newline in string eval */
1741 CopLINE_dec(PL_curcop);
1746 while (SPACE_OR_TAB(*s))
1748 if (strEQs(s, "line"))
1752 if (SPACE_OR_TAB(*s))
1756 while (SPACE_OR_TAB(*s))
1764 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1766 while (SPACE_OR_TAB(*s))
1768 if (*s == '"' && (t = strchr(s+1, '"'))) {
1774 while (*t && !isSPACE(*t))
1778 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1780 if (*e != '\n' && *e != '\0')
1781 return; /* false alarm */
1783 if (!grok_atoUV(n, &uv, &e))
1785 line_num = ((line_t)uv) - 1;
1788 const STRLEN len = t - s;
1790 if (!PL_rsfp && !PL_parser->filtered) {
1791 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1792 * to *{"::_<newfilename"} */
1793 /* However, the long form of evals is only turned on by the
1794 debugger - usually they're "(eval %lu)" */
1795 GV * const cfgv = CopFILEGV(PL_curcop);
1798 STRLEN tmplen2 = len;
1802 if (tmplen2 + 2 <= sizeof smallbuf)
1805 Newx(tmpbuf2, tmplen2 + 2, char);
1810 memcpy(tmpbuf2 + 2, s, tmplen2);
1813 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1815 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1816 /* adjust ${"::_<newfilename"} to store the new file name */
1817 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1818 /* The line number may differ. If that is the case,
1819 alias the saved lines that are in the array.
1820 Otherwise alias the whole array. */
1821 if (CopLINE(PL_curcop) == line_num) {
1822 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1823 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1825 else if (GvAV(cfgv)) {
1826 AV * const av = GvAV(cfgv);
1827 const I32 start = CopLINE(PL_curcop)+1;
1828 I32 items = AvFILLp(av) - start;
1830 AV * const av2 = GvAVn(gv2);
1831 SV **svp = AvARRAY(av) + start;
1832 I32 l = (I32)line_num+1;
1834 av_store(av2, l++, SvREFCNT_inc(*svp++));
1839 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1842 CopFILE_free(PL_curcop);
1843 CopFILE_setn(PL_curcop, s, len);
1845 CopLINE_set(PL_curcop, line_num);
1849 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1851 AV *av = CopFILEAVx(PL_curcop);
1854 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1856 sv = *av_fetch(av, 0, 1);
1857 SvUPGRADE(sv, SVt_PVMG);
1859 if (!SvPOK(sv)) SvPVCLEAR(sv);
1861 sv_catsv(sv, orig_sv);
1863 sv_catpvn(sv, buf, len);
1868 if (PL_parser->preambling == NOLINE)
1869 av_store(av, CopLINE(PL_curcop), sv);
1875 * Called to gobble the appropriate amount and type of whitespace.
1876 * Skips comments as well.
1877 * Returns the next character after the whitespace that is skipped.
1880 * Same thing, but look ahead without incrementing line numbers or
1881 * adjusting PL_linestart.
1884 #define skipspace(s) skipspace_flags(s, 0)
1885 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1888 S_skipspace_flags(pTHX_ char *s, U32 flags)
1890 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1891 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1892 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1895 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1897 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1898 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1899 LEX_NO_NEXT_CHUNK : 0));
1901 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1902 if (PL_linestart > PL_bufptr)
1903 PL_bufptr = PL_linestart;
1911 * Check the unary operators to ensure there's no ambiguity in how they're
1912 * used. An ambiguous piece of code would be:
1914 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1915 * the +5 is its argument.
1924 if (PL_oldoldbufptr != PL_last_uni)
1926 while (isSPACE(*PL_last_uni))
1929 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1930 s += UTF ? UTF8SKIP(s) : 1;
1931 if ((t = strchr(s, '(')) && t < PL_bufptr)
1934 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1935 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1936 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1940 * LOP : macro to build a list operator. Its behaviour has been replaced
1941 * with a subroutine, S_lop() for which LOP is just another name.
1944 #define LOP(f,x) return lop(f,x,s)
1948 * Build a list operator (or something that might be one). The rules:
1949 * - if we have a next token, then it's a list operator (no parens) for
1950 * which the next token has already been parsed; e.g.,
1953 * - if the next thing is an opening paren, then it's a function
1954 * - else it's a list operator
1958 S_lop(pTHX_ I32 f, U8 x, char *s)
1960 PERL_ARGS_ASSERT_LOP;
1965 PL_last_lop = PL_oldbufptr;
1966 PL_last_lop_op = (OPCODE)f;
1971 return REPORT(FUNC);
1974 return REPORT(FUNC);
1977 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1978 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1979 return REPORT(LSTOP);
1985 * When the lexer realizes it knows the next token (for instance,
1986 * it is reordering tokens for the parser) then it can call S_force_next
1987 * to know what token to return the next time the lexer is called. Caller
1988 * will need to set PL_nextval[] and possibly PL_expect to ensure
1989 * the lexer handles the token correctly.
1993 S_force_next(pTHX_ I32 type)
1997 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1998 tokereport(type, &NEXTVAL_NEXTTOKE);
2001 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2002 PL_nexttype[PL_nexttoke] = type;
2009 * This subroutine handles postfix deref syntax after the arrow has already
2010 * been emitted. @* $* etc. are emitted as two separate token right here.
2011 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2012 * only the first, leaving yylex to find the next.
2016 S_postderef(pTHX_ int const funny, char const next)
2018 assert(funny == DOLSHARP || strchr("$@%&*", funny));
2020 PL_expect = XOPERATOR;
2021 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2022 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2023 PL_lex_state = LEX_INTERPEND;
2025 force_next(POSTJOIN);
2031 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2032 && !PL_lex_brackets)
2034 PL_expect = XOPERATOR;
2043 int yyc = PL_parser->yychar;
2044 if (yyc != YYEMPTY) {
2046 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2047 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2048 PL_lex_allbrackets--;
2050 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2051 } else if (yyc == '('/*)*/) {
2052 PL_lex_allbrackets--;
2057 PL_parser->yychar = YYEMPTY;
2062 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2064 SV * const sv = newSVpvn_utf8(start, len,
2067 && !is_utf8_invariant_string((const U8*)start, len)
2068 && is_utf8_string((const U8*)start, len));
2074 * When the lexer knows the next thing is a word (for instance, it has
2075 * just seen -> and it knows that the next char is a word char, then
2076 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2080 * char *start : buffer position (must be within PL_linestr)
2081 * int token : PL_next* will be this type of bare word
2082 * (e.g., METHOD,BAREWORD)
2083 * int check_keyword : if true, Perl checks to make sure the word isn't
2084 * a keyword (do this if the word is a label, e.g. goto FOO)
2085 * int allow_pack : if true, : characters will also be allowed (require,
2086 * use, etc. do this)
2090 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2095 PERL_ARGS_ASSERT_FORCE_WORD;
2097 start = skipspace(start);
2099 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2100 || (allow_pack && *s == ':' && s[1] == ':') )
2102 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2103 if (check_keyword) {
2104 char *s2 = PL_tokenbuf;
2106 if (allow_pack && len > 6 && strEQs(s2, "CORE::"))
2108 if (keyword(s2, len2, 0))
2111 if (token == METHOD) {
2116 PL_expect = XOPERATOR;
2119 NEXTVAL_NEXTTOKE.opval
2120 = newSVOP(OP_CONST,0,
2121 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2122 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2130 * Called when the lexer wants $foo *foo &foo etc, but the program
2131 * text only contains the "foo" portion. The first argument is a pointer
2132 * to the "foo", and the second argument is the type symbol to prefix.
2133 * Forces the next token to be a "BAREWORD".
2134 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2138 S_force_ident(pTHX_ const char *s, int kind)
2140 PERL_ARGS_ASSERT_FORCE_IDENT;
2143 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2144 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2145 UTF ? SVf_UTF8 : 0));
2146 NEXTVAL_NEXTTOKE.opval = o;
2147 force_next(BAREWORD);
2149 o->op_private = OPpCONST_ENTERED;
2150 /* XXX see note in pp_entereval() for why we forgo typo
2151 warnings if the symbol must be introduced in an eval.
2153 gv_fetchpvn_flags(s, len,
2154 (PL_in_eval ? GV_ADDMULTI
2155 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2156 kind == '$' ? SVt_PV :
2157 kind == '@' ? SVt_PVAV :
2158 kind == '%' ? SVt_PVHV :
2166 S_force_ident_maybe_lex(pTHX_ char pit)
2168 NEXTVAL_NEXTTOKE.ival = pit;
2173 Perl_str_to_version(pTHX_ SV *sv)
2178 const char *start = SvPV_const(sv,len);
2179 const char * const end = start + len;
2180 const bool utf = cBOOL(SvUTF8(sv));
2182 PERL_ARGS_ASSERT_STR_TO_VERSION;
2184 while (start < end) {
2188 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2193 retval += ((NV)n)/nshift;
2202 * Forces the next token to be a version number.
2203 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2204 * and if "guessing" is TRUE, then no new token is created (and the caller
2205 * must use an alternative parsing method).
2209 S_force_version(pTHX_ char *s, int guessing)
2214 PERL_ARGS_ASSERT_FORCE_VERSION;
2222 while (isDIGIT(*d) || *d == '_' || *d == '.')
2224 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2226 s = scan_num(s, &pl_yylval);
2227 version = pl_yylval.opval;
2228 ver = cSVOPx(version)->op_sv;
2229 if (SvPOK(ver) && !SvNIOK(ver)) {
2230 SvUPGRADE(ver, SVt_PVNV);
2231 SvNV_set(ver, str_to_version(ver));
2232 SvNOK_on(ver); /* hint that it is a version */
2235 else if (guessing) {
2240 /* NOTE: The parser sees the package name and the VERSION swapped */
2241 NEXTVAL_NEXTTOKE.opval = version;
2242 force_next(BAREWORD);
2248 * S_force_strict_version
2249 * Forces the next token to be a version number using strict syntax rules.
2253 S_force_strict_version(pTHX_ char *s)
2256 const char *errstr = NULL;
2258 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2260 while (isSPACE(*s)) /* leading whitespace */
2263 if (is_STRICT_VERSION(s,&errstr)) {
2265 s = (char *)scan_version(s, ver, 0);
2266 version = newSVOP(OP_CONST, 0, ver);
2268 else if ((*s != ';' && *s != '{' && *s != '}' )
2269 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2273 yyerror(errstr); /* version required */
2277 /* NOTE: The parser sees the package name and the VERSION swapped */
2278 NEXTVAL_NEXTTOKE.opval = version;
2279 force_next(BAREWORD);
2286 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2287 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2288 * unchanged, and a new SV containing the modified input is returned.
2292 S_tokeq(pTHX_ SV *sv)
2299 PERL_ARGS_ASSERT_TOKEQ;
2303 assert (!SvIsCOW(sv));
2304 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2308 /* This is relying on the SV being "well formed" with a trailing '\0' */
2309 while (s < send && !(*s == '\\' && s[1] == '\\'))
2314 if ( PL_hints & HINT_NEW_STRING ) {
2315 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2316 SVs_TEMP | SvUTF8(sv));
2320 if (s + 1 < send && (s[1] == '\\'))
2321 s++; /* all that, just for this */
2326 SvCUR_set(sv, d - SvPVX_const(sv));
2328 if ( PL_hints & HINT_NEW_STRING )
2329 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2334 * Now come three functions related to double-quote context,
2335 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2336 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2337 * interact with PL_lex_state, and create fake ( ... ) argument lists
2338 * to handle functions and concatenation.
2342 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2347 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2349 * Pattern matching will set PL_lex_op to the pattern-matching op to
2350 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2352 * OP_CONST is easy--just make the new op and return.
2354 * Everything else becomes a FUNC.
2356 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2357 * had an OP_CONST. This just sets us up for a
2358 * call to S_sublex_push().
2362 S_sublex_start(pTHX)
2364 const I32 op_type = pl_yylval.ival;
2366 if (op_type == OP_NULL) {
2367 pl_yylval.opval = PL_lex_op;
2371 if (op_type == OP_CONST) {
2372 SV *sv = PL_lex_stuff;
2373 PL_lex_stuff = NULL;
2376 if (SvTYPE(sv) == SVt_PVIV) {
2377 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2379 const char * const p = SvPV_const(sv, len);
2380 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2384 pl_yylval.opval = newSVOP(op_type, 0, sv);
2388 PL_parser->lex_super_state = PL_lex_state;
2389 PL_parser->lex_sub_inwhat = (U16)op_type;
2390 PL_parser->lex_sub_op = PL_lex_op;
2391 PL_lex_state = LEX_INTERPPUSH;
2395 pl_yylval.opval = PL_lex_op;
2405 * Create a new scope to save the lexing state. The scope will be
2406 * ended in S_sublex_done. Returns a '(', starting the function arguments
2407 * to the uc, lc, etc. found before.
2408 * Sets PL_lex_state to LEX_INTERPCONCAT.
2415 const bool is_heredoc = PL_multi_close == '<';
2418 PL_lex_state = PL_parser->lex_super_state;
2419 SAVEI8(PL_lex_dojoin);
2420 SAVEI32(PL_lex_brackets);
2421 SAVEI32(PL_lex_allbrackets);
2422 SAVEI32(PL_lex_formbrack);
2423 SAVEI8(PL_lex_fakeeof);
2424 SAVEI32(PL_lex_casemods);
2425 SAVEI32(PL_lex_starts);
2426 SAVEI8(PL_lex_state);
2427 SAVESPTR(PL_lex_repl);
2428 SAVEVPTR(PL_lex_inpat);
2429 SAVEI16(PL_lex_inwhat);
2432 SAVECOPLINE(PL_curcop);
2433 SAVEI32(PL_multi_end);
2434 SAVEI32(PL_parser->herelines);
2435 PL_parser->herelines = 0;
2437 SAVEIV(PL_multi_close);
2438 SAVEPPTR(PL_bufptr);
2439 SAVEPPTR(PL_bufend);
2440 SAVEPPTR(PL_oldbufptr);
2441 SAVEPPTR(PL_oldoldbufptr);
2442 SAVEPPTR(PL_last_lop);
2443 SAVEPPTR(PL_last_uni);
2444 SAVEPPTR(PL_linestart);
2445 SAVESPTR(PL_linestr);
2446 SAVEGENERICPV(PL_lex_brackstack);
2447 SAVEGENERICPV(PL_lex_casestack);
2448 SAVEGENERICPV(PL_parser->lex_shared);
2449 SAVEBOOL(PL_parser->lex_re_reparsing);
2450 SAVEI32(PL_copline);
2452 /* The here-doc parser needs to be able to peek into outer lexing
2453 scopes to find the body of the here-doc. So we put PL_linestr and
2454 PL_bufptr into lex_shared, to ‘share’ those values.
2456 PL_parser->lex_shared->ls_linestr = PL_linestr;
2457 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2459 PL_linestr = PL_lex_stuff;
2460 PL_lex_repl = PL_parser->lex_sub_repl;
2461 PL_lex_stuff = NULL;
2462 PL_parser->lex_sub_repl = NULL;
2464 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2465 set for an inner quote-like operator and then an error causes scope-
2466 popping. We must not have a PL_lex_stuff value left dangling, as
2467 that breaks assumptions elsewhere. See bug #123617. */
2468 SAVEGENERICSV(PL_lex_stuff);
2469 SAVEGENERICSV(PL_parser->lex_sub_repl);
2471 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2472 = SvPVX(PL_linestr);
2473 PL_bufend += SvCUR(PL_linestr);
2474 PL_last_lop = PL_last_uni = NULL;
2475 SAVEFREESV(PL_linestr);
2476 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2478 PL_lex_dojoin = FALSE;
2479 PL_lex_brackets = PL_lex_formbrack = 0;
2480 PL_lex_allbrackets = 0;
2481 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2482 Newx(PL_lex_brackstack, 120, char);
2483 Newx(PL_lex_casestack, 12, char);
2484 PL_lex_casemods = 0;
2485 *PL_lex_casestack = '\0';
2487 PL_lex_state = LEX_INTERPCONCAT;
2489 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2490 PL_copline = NOLINE;
2492 Newxz(shared, 1, LEXSHARED);
2493 shared->ls_prev = PL_parser->lex_shared;
2494 PL_parser->lex_shared = shared;
2496 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2497 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2498 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2499 PL_lex_inpat = PL_parser->lex_sub_op;
2501 PL_lex_inpat = NULL;
2503 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2504 PL_in_eval &= ~EVAL_RE_REPARSING;
2511 * Restores lexer state after a S_sublex_push.
2517 if (!PL_lex_starts++) {
2518 SV * const sv = newSVpvs("");
2519 if (SvUTF8(PL_linestr))
2521 PL_expect = XOPERATOR;
2522 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2526 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2527 PL_lex_state = LEX_INTERPCASEMOD;
2531 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2532 assert(PL_lex_inwhat != OP_TRANSR);
2534 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2535 PL_linestr = PL_lex_repl;
2537 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2538 PL_bufend += SvCUR(PL_linestr);
2539 PL_last_lop = PL_last_uni = NULL;
2540 PL_lex_dojoin = FALSE;
2541 PL_lex_brackets = 0;
2542 PL_lex_allbrackets = 0;
2543 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2544 PL_lex_casemods = 0;
2545 *PL_lex_casestack = '\0';
2547 if (SvEVALED(PL_lex_repl)) {
2548 PL_lex_state = LEX_INTERPNORMAL;
2550 /* we don't clear PL_lex_repl here, so that we can check later
2551 whether this is an evalled subst; that means we rely on the
2552 logic to ensure sublex_done() is called again only via the
2553 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2556 PL_lex_state = LEX_INTERPCONCAT;
2559 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2560 CopLINE(PL_curcop) +=
2561 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2562 + PL_parser->herelines;
2563 PL_parser->herelines = 0;
2568 const line_t l = CopLINE(PL_curcop);
2570 if (PL_multi_close == '<')
2571 PL_parser->herelines += l - PL_multi_end;
2572 PL_bufend = SvPVX(PL_linestr);
2573 PL_bufend += SvCUR(PL_linestr);
2574 PL_expect = XOPERATOR;
2580 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2582 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2583 * interior, hence to the "}". Finds what the name resolves to, returning
2584 * an SV* containing it; NULL if no valid one found */
2586 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2593 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2595 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2598 SvREFCNT_dec_NN(res);
2599 /* diag_listed_as: Unknown charname '%s' */
2600 yyerror("Unknown charname ''");
2604 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2605 /* include the <}> */
2606 e - backslash_ptr + 1);
2608 SvREFCNT_dec_NN(res);
2612 /* See if the charnames handler is the Perl core's, and if so, we can skip
2613 * the validation needed for a user-supplied one, as Perl's does its own
2615 table = GvHV(PL_hintgv); /* ^H */
2616 cvp = hv_fetchs(table, "charnames", FALSE);
2617 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2618 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2620 const char * const name = HvNAME(stash);
2621 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2622 && strEQ(name, "_charnames")) {
2627 /* Here, it isn't Perl's charname handler. We can't rely on a
2628 * user-supplied handler to validate the input name. For non-ut8 input,
2629 * look to see that the first character is legal. Then loop through the
2630 * rest checking that each is a continuation */
2632 /* This code makes the reasonable assumption that the only Latin1-range
2633 * characters that begin a character name alias are alphabetic, otherwise
2634 * would have to create a isCHARNAME_BEGIN macro */
2637 if (! isALPHAU(*s)) {
2642 if (! isCHARNAME_CONT(*s)) {
2645 if (*s == ' ' && *(s-1) == ' ') {
2652 /* Similarly for utf8. For invariants can check directly; for other
2653 * Latin1, can calculate their code point and check; otherwise use a
2655 if (UTF8_IS_INVARIANT(*s)) {
2656 if (! isALPHAU(*s)) {
2660 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2661 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2667 if (! PL_utf8_charname_begin) {
2668 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2669 PL_utf8_charname_begin = _core_swash_init("utf8",
2670 "_Perl_Charname_Begin",
2672 1, 0, NULL, &flags);
2674 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2681 if (UTF8_IS_INVARIANT(*s)) {
2682 if (! isCHARNAME_CONT(*s)) {
2685 if (*s == ' ' && *(s-1) == ' ') {
2690 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2691 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2698 if (! PL_utf8_charname_continue) {
2699 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2700 PL_utf8_charname_continue = _core_swash_init("utf8",
2701 "_Perl_Charname_Continue",
2703 1, 0, NULL, &flags);
2705 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2712 if (*(s-1) == ' ') {
2713 /* diag_listed_as: charnames alias definitions may not contain
2714 trailing white-space; marked by <-- HERE in %s
2718 "charnames alias definitions may not contain trailing "
2719 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2720 (int)(s - backslash_ptr + 1), backslash_ptr,
2721 (int)(e - s + 1), s + 1
2723 UTF ? SVf_UTF8 : 0);
2727 if (SvUTF8(res)) { /* Don't accept malformed input */
2728 const U8* first_bad_char_loc;
2730 const char* const str = SvPV_const(res, len);
2731 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2732 &first_bad_char_loc)))
2734 _force_out_malformed_utf8_message(first_bad_char_loc,
2735 (U8 *) PL_parser->bufend,
2737 0 /* 0 means don't die */ );
2738 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2739 immediately after '%s' */
2742 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2743 (int) (e - backslash_ptr + 1), backslash_ptr,
2744 (int) ((char *) first_bad_char_loc - str), str
2755 /* The final %.*s makes sure that should the trailing NUL be missing
2756 * that this print won't run off the end of the string */
2757 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2761 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2762 (int)(s - backslash_ptr + 1), backslash_ptr,
2763 (int)(e - s + 1), s + 1
2765 UTF ? SVf_UTF8 : 0);
2770 /* diag_listed_as: charnames alias definitions may not contain a
2771 sequence of multiple spaces; marked by <-- HERE
2775 "charnames alias definitions may not contain a sequence of "
2776 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2777 (int)(s - backslash_ptr + 1), backslash_ptr,
2778 (int)(e - s + 1), s + 1
2780 UTF ? SVf_UTF8 : 0);
2787 Extracts the next constant part of a pattern, double-quoted string,
2788 or transliteration. This is terrifying code.
2790 For example, in parsing the double-quoted string "ab\x63$d", it would
2791 stop at the '$' and return an OP_CONST containing 'abc'.
2793 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2794 processing a pattern (PL_lex_inpat is true), a transliteration
2795 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2797 Returns a pointer to the character scanned up to. If this is
2798 advanced from the start pointer supplied (i.e. if anything was
2799 successfully parsed), will leave an OP_CONST for the substring scanned
2800 in pl_yylval. Caller must intuit reason for not parsing further
2801 by looking at the next characters herself.
2805 \N{FOO} => \N{U+hex_for_character_FOO}
2806 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2809 all other \-char, including \N and \N{ apart from \N{ABC}
2812 @ and $ where it appears to be a var, but not for $ as tail anchor
2816 In transliterations:
2817 characters are VERY literal, except for - not at the start or end
2818 of the string, which indicates a range. However some backslash sequences
2819 are recognized: \r, \n, and the like
2820 \007 \o{}, \x{}, \N{}
2821 If all elements in the transliteration are below 256,
2822 scan_const expands the range to the full set of intermediate
2823 characters. If the range is in utf8, the hyphen is replaced with
2824 a certain range mark which will be handled by pmtrans() in op.c.
2826 In double-quoted strings:
2828 all those recognized in transliterations
2829 deprecated backrefs: \1 (in substitution replacements)
2830 case and quoting: \U \Q \E
2833 scan_const does *not* construct ops to handle interpolated strings.
2834 It stops processing as soon as it finds an embedded $ or @ variable
2835 and leaves it to the caller to work out what's going on.
2837 embedded arrays (whether in pattern or not) could be:
2838 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2840 $ in double-quoted strings must be the symbol of an embedded scalar.
2842 $ in pattern could be $foo or could be tail anchor. Assumption:
2843 it's a tail anchor if $ is the last thing in the string, or if it's
2844 followed by one of "()| \r\n\t"
2846 \1 (backreferences) are turned into $1 in substitutions
2848 The structure of the code is
2849 while (there's a character to process) {
2850 handle transliteration ranges
2851 skip regexp comments /(?#comment)/ and codes /(?{code})/
2852 skip #-initiated comments in //x patterns
2853 check for embedded arrays
2854 check for embedded scalars
2856 deprecate \1 in substitution replacements
2857 handle string-changing backslashes \l \U \Q \E, etc.
2858 switch (what was escaped) {
2859 handle \- in a transliteration (becomes a literal -)
2860 if a pattern and not \N{, go treat as regular character
2861 handle \132 (octal characters)
2862 handle \x15 and \x{1234} (hex characters)
2863 handle \N{name} (named characters, also \N{3,5} in a pattern)
2864 handle \cV (control characters)
2865 handle printf-style backslashes (\f, \r, \n, etc)
2868 } (end if backslash)
2869 handle regular character
2870 } (end while character to read)
2875 S_scan_const(pTHX_ char *start)
2877 char *send = PL_bufend; /* end of the constant */
2878 SV *sv = newSV(send - start); /* sv for the constant. See note below
2880 char *s = start; /* start of the constant */
2881 char *d = SvPVX(sv); /* destination for copies */
2882 bool dorange = FALSE; /* are we in a translit range? */
2883 bool didrange = FALSE; /* did we just finish a range? */
2884 bool in_charclass = FALSE; /* within /[...]/ */
2885 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2886 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2887 UTF8? But, this can show as true
2888 when the source isn't utf8, as for
2889 example when it is entirely composed
2891 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2892 number of characters found so far
2893 that will expand (into 2 bytes)
2894 should we have to convert to
2896 SV *res; /* result from charnames */
2897 STRLEN offset_to_max; /* The offset in the output to where the range
2898 high-end character is temporarily placed */
2900 /* Does something require special handling in tr/// ? This avoids extra
2901 * work in a less likely case. As such, khw didn't feel it was worth
2902 * adding any branches to the more mainline code to handle this, which
2903 * means that this doesn't get set in some circumstances when things like
2904 * \x{100} get expanded out. As a result there needs to be extra testing
2905 * done in the tr code */
2906 bool has_above_latin1 = FALSE;
2908 /* Note on sizing: The scanned constant is placed into sv, which is
2909 * initialized by newSV() assuming one byte of output for every byte of
2910 * input. This routine expects newSV() to allocate an extra byte for a
2911 * trailing NUL, which this routine will append if it gets to the end of
2912 * the input. There may be more bytes of input than output (eg., \N{LATIN
2913 * CAPITAL LETTER A}), or more output than input if the constant ends up
2914 * recoded to utf8, but each time a construct is found that might increase
2915 * the needed size, SvGROW() is called. Its size parameter each time is
2916 * based on the best guess estimate at the time, namely the length used so
2917 * far, plus the length the current construct will occupy, plus room for
2918 * the trailing NUL, plus one byte for every input byte still unscanned */
2920 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2923 int backslash_N = 0; /* ? was the character from \N{} */
2924 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2925 platform-specific like \x65 */
2928 PERL_ARGS_ASSERT_SCAN_CONST;
2930 assert(PL_lex_inwhat != OP_TRANSR);
2931 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2932 /* If we are doing a trans and we know we want UTF8 set expectation */
2933 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2934 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2937 /* Protect sv from errors and fatal warnings. */
2938 ENTER_with_name("scan_const");
2942 || dorange /* Handle tr/// range at right edge of input */
2945 /* get transliterations out of the way (they're most literal) */
2946 if (PL_lex_inwhat == OP_TRANS) {
2948 /* But there isn't any special handling necessary unless there is a
2949 * range, so for most cases we just drop down and handle the value
2950 * as any other. There are two exceptions.
2952 * 1. A hyphen indicates that we are actually going to have a
2953 * range. In this case, skip the '-', set a flag, then drop
2954 * down to handle what should be the end range value.
2955 * 2. After we've handled that value, the next time through, that
2956 * flag is set and we fix up the range.
2958 * Ranges entirely within Latin1 are expanded out entirely, in
2959 * order to make the transliteration a simple table look-up.
2960 * Ranges that extend above Latin1 have to be done differently, so
2961 * there is no advantage to expanding them here, so they are
2962 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2963 * signifies a hyphen without any possible ambiguity. On EBCDIC
2964 * machines, if the range is expressed as Unicode, the Latin1
2965 * portion is expanded out even if the range extends above
2966 * Latin1. This is because each code point in it has to be
2967 * processed here individually to get its native translation */
2971 /* Here, we don't think we're in a range. If the new character
2972 * is not a hyphen; or if it is a hyphen, but it's too close to
2973 * either edge to indicate a range, or if we haven't output any
2974 * characters yet then it's a regular character. */
2975 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
2977 /* A regular character. Process like any other, but first
2978 * clear any flags */
2982 non_portable_endpoint = 0;
2985 /* The tests here for being above Latin1 and similar ones
2986 * in the following 'else' suffice to find all such
2987 * occurences in the constant, except those added by a
2988 * backslash escape sequence, like \x{100}. Mostly, those
2989 * set 'has_above_latin1' as appropriate */
2990 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
2991 has_above_latin1 = TRUE;
2994 /* Drops down to generic code to process current byte */
2996 else { /* Is a '-' in the context where it means a range */
2997 if (didrange) { /* Something like y/A-C-Z// */
2998 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3004 s++; /* Skip past the hyphen */
3006 /* d now points to where the end-range character will be
3007 * placed. Save it so won't have to go finding it later,
3008 * and drop down to get that character. (Actually we
3009 * instead save the offset, to handle the case where a
3010 * realloc in the meantime could change the actual
3011 * pointer). We'll finish processing the range the next
3012 * time through the loop */
3013 offset_to_max = d - SvPVX_const(sv);
3015 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3016 has_above_latin1 = TRUE;
3019 /* Drops down to generic code to process current byte */
3021 } /* End of not a range */
3023 /* Here we have parsed a range. Now must handle it. At this
3025 * 'sv' is a SV* that contains the output string we are
3026 * constructing. The final two characters in that string
3027 * are the range start and range end, in order.
3028 * 'd' points to just beyond the range end in the 'sv' string,
3029 * where we would next place something
3030 * 'offset_to_max' is the offset in 'sv' at which the character
3031 * (the range's maximum end point) before 'd' begins.
3033 char * max_ptr = SvPVX(sv) + offset_to_max;
3036 IV range_max; /* last character in range */
3038 Size_t offset_to_min = 0;
3041 bool convert_unicode;
3042 IV real_range_max = 0;
3044 /* Get the code point values of the range ends. */
3046 /* We know the utf8 is valid, because we just constructed
3047 * it ourselves in previous loop iterations */
3048 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3049 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3050 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3052 /* This compensates for not all code setting
3053 * 'has_above_latin1', so that we don't skip stuff that
3054 * should be executed */
3055 if (range_max > 255) {
3056 has_above_latin1 = TRUE;
3060 min_ptr = max_ptr - 1;
3061 range_min = * (U8*) min_ptr;
3062 range_max = * (U8*) max_ptr;
3065 /* If the range is just a single code point, like tr/a-a/.../,
3066 * that code point is already in the output, twice. We can
3067 * just back up over the second instance and avoid all the rest
3068 * of the work. But if it is a variant character, it's been
3069 * counted twice, so decrement. (This unlikely scenario is
3070 * special cased, like the one for a range of 2 code points
3071 * below, only because the main-line code below needs a range
3072 * of 3 or more to work without special casing. Might as well
3073 * get it out of the way now.) */
3074 if (UNLIKELY(range_max == range_min)) {
3076 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3077 utf8_variant_count--;
3083 /* On EBCDIC platforms, we may have to deal with portable
3084 * ranges. These happen if at least one range endpoint is a
3085 * Unicode value (\N{...}), or if the range is a subset of
3086 * [A-Z] or [a-z], and both ends are literal characters,
3087 * like 'A', and not like \x{C1} */
3089 cBOOL(backslash_N) /* \N{} forces Unicode,
3090 hence portable range */
3091 || ( ! non_portable_endpoint
3092 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3093 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3094 if (convert_unicode) {
3096 /* Special handling is needed for these portable ranges.
3097 * They are defined to be in Unicode terms, which includes
3098 * all the Unicode code points between the end points.
3099 * Convert to Unicode to get the Unicode range. Later we
3100 * will convert each code point in the range back to
3102 range_min = NATIVE_TO_UNI(range_min);
3103 range_max = NATIVE_TO_UNI(range_max);
3107 if (range_min > range_max) {
3109 if (convert_unicode) {
3110 /* Need to convert back to native for meaningful
3111 * messages for this platform */
3112 range_min = UNI_TO_NATIVE(range_min);
3113 range_max = UNI_TO_NATIVE(range_max);
3116 /* Use the characters themselves for the error message if
3117 * ASCII printables; otherwise some visible representation
3119 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3121 "Invalid range \"%c-%c\" in transliteration operator",
3122 (char)range_min, (char)range_max);
3125 else if (convert_unicode) {
3126 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3128 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3129 UVXf "}\" in transliteration operator",
3130 range_min, range_max);
3134 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3136 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3137 " in transliteration operator",
3138 range_min, range_max);
3142 /* If the range is exactly two code points long, they are
3143 * already both in the output */
3144 if (UNLIKELY(range_min + 1 == range_max)) {
3148 /* Here the range contains at least 3 code points */
3152 /* If everything in the transliteration is below 256, we
3153 * can avoid special handling later. A translation table
3154 * for each of those bytes is created by op.c. So we
3155 * expand out all ranges to their constituent code points.
3156 * But if we've encountered something above 255, the
3157 * expanding won't help, so skip doing that. But if it's
3158 * EBCDIC, we may have to look at each character below 256
3159 * if we have to convert to/from Unicode values */
3160 if ( has_above_latin1
3162 && (range_min > 255 || ! convert_unicode)
3165 /* Move the high character one byte to the right; then
3166 * insert between it and the range begin, an illegal
3167 * byte which serves to indicate this is a range (using
3168 * a '-' would be ambiguous). */
3170 while (e-- > max_ptr) {
3173 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3177 /* Here, we're going to expand out the range. For EBCDIC
3178 * the range can extend above 255 (not so in ASCII), so
3179 * for EBCDIC, split it into the parts above and below
3182 if (range_max > 255) {
3183 real_range_max = range_max;
3189 /* Here we need to expand out the string to contain each
3190 * character in the range. Grow the output to handle this.
3191 * For non-UTF8, we need a byte for each code point in the
3192 * range, minus the three that we've already allocated for: the
3193 * hyphen, the min, and the max. For UTF-8, we need this
3194 * plus an extra byte for each code point that occupies two
3195 * bytes (is variant) when in UTF-8 (except we've already
3196 * allocated for the end points, including if they are
3197 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3198 * platforms, it's easy to calculate a precise number. To
3199 * start, we count the variants in the range, which we need
3200 * elsewhere in this function anyway. (For the case where it
3201 * isn't easy to calculate, 'extras' has been initialized to 0,
3202 * and the calculation is done in a loop further down.) */
3204 if (convert_unicode)
3207 /* This is executed unconditionally on ASCII, and for
3208 * Unicode ranges on EBCDIC. Under these conditions, all
3209 * code points above a certain value are variant; and none
3210 * under that value are. We just need to find out how much
3211 * of the range is above that value. We don't count the
3212 * end points here, as they will already have been counted
3213 * as they were parsed. */
3214 if (range_min >= UTF_CONTINUATION_MARK) {
3216 /* The whole range is made up of variants */
3217 extras = (range_max - 1) - (range_min + 1) + 1;
3219 else if (range_max >= UTF_CONTINUATION_MARK) {
3221 /* Only the higher portion of the range is variants */
3222 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3225 utf8_variant_count += extras;
3228 /* The base growth is the number of code points in the range,
3229 * not including the endpoints, which have already been sized
3230 * for (and output). We don't subtract for the hyphen, as it
3231 * has been parsed but not output, and the SvGROW below is
3232 * based only on what's been output plus what's left to parse.
3234 grow = (range_max - 1) - (range_min + 1) + 1;
3238 /* In some cases in EBCDIC, we haven't yet calculated a
3239 * precise amount needed for the UTF-8 variants. Just
3240 * assume the worst case, that everything will expand by a
3242 if (! convert_unicode) {
3248 /* Otherwise we know exactly how many variants there
3249 * are in the range. */
3254 /* Grow, but position the output to overwrite the range min end
3255 * point, because in some cases we overwrite that */
3256 SvCUR_set(sv, d - SvPVX_const(sv));
3257 offset_to_min = min_ptr - SvPVX_const(sv);
3259 /* See Note on sizing above. */
3260 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3263 + 1 /* Trailing NUL */ );
3265 /* Now, we can expand out the range. */
3267 if (convert_unicode) {
3270 /* Recall that the min and max are now in Unicode terms, so
3271 * we have to convert each character to its native
3274 for (i = range_min; i <= range_max; i++) {
3275 append_utf8_from_native_byte(
3276 LATIN1_TO_NATIVE((U8) i),
3281 for (i = range_min; i <= range_max; i++) {
3282 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3288 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3290 /* Here, no conversions are necessary, which means that the
3291 * first character in the range is already in 'd' and
3292 * valid, so we can skip overwriting it */
3296 for (i = range_min + 1; i <= range_max; i++) {
3297 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3303 assert(range_min + 1 <= range_max);
3304 for (i = range_min + 1; i < range_max; i++) {
3306 /* In this case on EBCDIC, we haven't calculated
3307 * the variants. Do it here, as we go along */
3308 if (! UVCHR_IS_INVARIANT(i)) {
3309 utf8_variant_count++;
3315 /* The range_max is done outside the loop so as to
3316 * avoid having to special case not incrementing
3317 * 'utf8_variant_count' on EBCDIC (it's already been
3318 * counted when originally parsed) */
3319 *d++ = (char) range_max;
3324 /* If the original range extended above 255, add in that
3326 if (real_range_max) {
3327 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3328 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3329 if (real_range_max > 0x100) {
3330 if (real_range_max > 0x101) {
3331 *d++ = (char) ILLEGAL_UTF8_BYTE;
3333 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3339 /* mark the range as done, and continue */
3343 non_portable_endpoint = 0;
3347 } /* End of is a range */
3348 } /* End of transliteration. Joins main code after these else's */
3349 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3352 while (s1 >= start && *s1-- == '\\')
3355 in_charclass = TRUE;
3357 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3360 while (s1 >= start && *s1-- == '\\')
3363 in_charclass = FALSE;
3365 /* skip for regexp comments /(?#comment)/, except for the last
3366 * char, which will be done separately. Stop on (?{..}) and
3368 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3370 while (s+1 < send && *s != ')')
3373 else if (!PL_lex_casemods
3374 && ( s[2] == '{' /* This should match regcomp.c */
3375 || (s[2] == '?' && s[3] == '{')))
3380 /* likewise skip #-initiated comments in //x patterns */
3384 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3386 while (s < send && *s != '\n')
3389 /* no further processing of single-quoted regex */
3390 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3391 goto default_action;
3393 /* check for embedded arrays
3394 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3396 else if (*s == '@' && s[1]) {
3398 ? isIDFIRST_utf8_safe(s+1, send)
3399 : isWORDCHAR_A(s[1]))
3403 if (strchr(":'{$", s[1]))
3405 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3406 break; /* in regexp, neither @+ nor @- are interpolated */
3408 /* check for embedded scalars. only stop if we're sure it's a
3410 else if (*s == '$') {
3411 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3413 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3415 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3416 "Possible unintended interpolation of $\\ in regex");
3418 break; /* in regexp, $ might be tail anchor */
3422 /* End of else if chain - OP_TRANS rejoin rest */
3424 if (UNLIKELY(s >= send)) {
3430 if (*s == '\\' && s+1 < send) {
3431 char* e; /* Can be used for ending '}', etc. */
3435 /* warn on \1 - \9 in substitution replacements, but note that \11
3436 * is an octal; and \19 is \1 followed by '9' */
3437 if (PL_lex_inwhat == OP_SUBST
3443 /* diag_listed_as: \%d better written as $%d */
3444 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3449 /* string-change backslash escapes */
3450 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3454 /* In a pattern, process \N, but skip any other backslash escapes.
3455 * This is because we don't want to translate an escape sequence
3456 * into a meta symbol and have the regex compiler use the meta
3457 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3458 * in spite of this, we do have to process \N here while the proper
3459 * charnames handler is in scope. See bugs #56444 and #62056.
3461 * There is a complication because \N in a pattern may also stand
3462 * for 'match a non-nl', and not mean a charname, in which case its
3463 * processing should be deferred to the regex compiler. To be a
3464 * charname it must be followed immediately by a '{', and not look
3465 * like \N followed by a curly quantifier, i.e., not something like
3466 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3468 else if (PL_lex_inpat
3471 || regcurly(s + 1)))
3474 goto default_action;
3480 if ((isALPHANUMERIC(*s)))
3481 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3482 "Unrecognized escape \\%c passed through",
3484 /* default action is to copy the quoted character */
3485 goto default_action;
3488 /* eg. \132 indicates the octal constant 0132 */
3489 case '0': case '1': case '2': case '3':
3490 case '4': case '5': case '6': case '7':
3492 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3494 uv = grok_oct(s, &len, &flags, NULL);
3496 if (len < 3 && s < send && isDIGIT(*s)
3497 && ckWARN(WARN_MISC))
3499 Perl_warner(aTHX_ packWARN(WARN_MISC),
3500 "%s", form_short_octal_warning(s, len));
3503 goto NUM_ESCAPE_INSERT;
3505 /* eg. \o{24} indicates the octal constant \024 */
3510 bool valid = grok_bslash_o(&s, &uv, &error,
3511 TRUE, /* Output warning */
3512 FALSE, /* Not strict */
3513 TRUE, /* Output warnings for
3518 uv = 0; /* drop through to ensure range ends are set */
3520 goto NUM_ESCAPE_INSERT;
3523 /* eg. \x24 indicates the hex constant 0x24 */
3528 bool valid = grok_bslash_x(&s, &uv, &error,
3529 TRUE, /* Output warning */
3530 FALSE, /* Not strict */
3531 TRUE, /* Output warnings for
3536 uv = 0; /* drop through to ensure range ends are set */
3541 /* Insert oct or hex escaped character. */
3543 /* Here uv is the ordinal of the next character being added */
3544 if (UVCHR_IS_INVARIANT(uv)) {
3548 if (!has_utf8 && uv > 255) {
3550 /* Here, 'uv' won't fit unless we convert to UTF-8.
3551 * If we've only seen invariants so far, all we have to
3552 * do is turn on the flag */
3553 if (utf8_variant_count == 0) {
3557 SvCUR_set(sv, d - SvPVX_const(sv));
3561 sv_utf8_upgrade_flags_grow(
3563 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3565 /* Since we're having to grow here,
3566 * make sure we have enough room for
3567 * this escape and a NUL, so the
3568 * code immediately below won't have
3569 * to actually grow again */
3571 + (STRLEN)(send - s) + 1);
3572 d = SvPVX(sv) + SvCUR(sv);
3575 has_above_latin1 = TRUE;
3581 utf8_variant_count++;
3584 /* Usually, there will already be enough room in 'sv'
3585 * since such escapes are likely longer than any UTF-8
3586 * sequence they can end up as. This isn't the case on
3587 * EBCDIC where \x{40000000} contains 12 bytes, and the
3588 * UTF-8 for it contains 14. And, we have to allow for
3589 * a trailing NUL. It probably can't happen on ASCII
3590 * platforms, but be safe. See Note on sizing above. */
3591 const STRLEN needed = d - SvPVX(sv)
3595 if (UNLIKELY(needed > SvLEN(sv))) {
3596 SvCUR_set(sv, d - SvPVX_const(sv));
3597 d = SvCUR(sv) + SvGROW(sv, needed);
3600 d = (char*)uvchr_to_utf8((U8*)d, uv);
3601 if (PL_lex_inwhat == OP_TRANS
3602 && PL_parser->lex_sub_op)
3604 PL_parser->lex_sub_op->op_private |=
3605 (PL_lex_repl ? OPpTRANS_FROM_UTF
3611 non_portable_endpoint++;
3616 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3617 * named character, like \N{LATIN SMALL LETTER A}, or a named
3618 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3619 * GRAVE} (except y/// can't handle the latter, croaking). For
3620 * convenience all three forms are referred to as "named
3621 * characters" below.
3623 * For patterns, \N also can mean to match a non-newline. Code
3624 * before this 'switch' statement should already have handled
3625 * this situation, and hence this code only has to deal with
3626 * the named character cases.
3628 * For non-patterns, the named characters are converted to
3629 * their string equivalents. In patterns, named characters are
3630 * not converted to their ultimate forms for the same reasons
3631 * that other escapes aren't (mainly that the ultimate
3632 * character could be considered a meta-symbol by the regex
3633 * compiler). Instead, they are converted to the \N{U+...}
3634 * form to get the value from the charnames that is in effect
3635 * right now, while preserving the fact that it was a named
3636 * character, so that the regex compiler knows this.
3638 * The structure of this section of code (besides checking for
3639 * errors and upgrading to utf8) is:
3640 * If the named character is of the form \N{U+...}, pass it
3641 * through if a pattern; otherwise convert the code point
3643 * Otherwise must be some \N{NAME}: convert to
3644 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3646 * Transliteration is an exception. The conversion to utf8 is
3647 * only done if the code point requires it to be representable.
3649 * Here, 's' points to the 'N'; the test below is guaranteed to
3650 * succeed if we are being called on a pattern, as we already
3651 * know from a test above that the next character is a '{'. A
3652 * non-pattern \N must mean 'named character', which requires
3656 yyerror("Missing braces on \\N{}");
3662 /* If there is no matching '}', it is an error. */
3663 if (! (e = strchr(s, '}'))) {
3664 if (! PL_lex_inpat) {
3665 yyerror("Missing right brace on \\N{}");
3667 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3669 yyquit(); /* Have exhausted the input. */
3672 /* Here it looks like a named character */
3674 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3675 s += 2; /* Skip to next char after the 'U+' */
3678 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3679 /* Check the syntax. */
3682 if (!isXDIGIT(*s)) {
3685 "Invalid hexadecimal number in \\N{U+...}"
3694 else if ((*s == '.' || *s == '_')
3700 /* Pass everything through unchanged.
3701 * +1 is for the '}' */
3702 Copy(orig_s, d, e - orig_s + 1, char);
3703 d += e - orig_s + 1;
3705 else { /* Not a pattern: convert the hex to string */
3706 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3707 | PERL_SCAN_SILENT_ILLDIGIT
3708 | PERL_SCAN_DISALLOW_PREFIX;
3710 uv = grok_hex(s, &len, &flags, NULL);
3711 if (len == 0 || (len != (STRLEN)(e - s)))
3714 /* For non-tr///, if the destination is not in utf8,
3715 * unconditionally recode it to be so. This is
3716 * because \N{} implies Unicode semantics, and scalars
3717 * have to be in utf8 to guarantee those semantics.
3718 * tr/// doesn't care about Unicode rules, so no need
3719 * there to upgrade to UTF-8 for small enough code
3721 if (! has_utf8 && ( uv > 0xFF
3722 || PL_lex_inwhat != OP_TRANS))
3724 /* See Note on sizing above. */
3725 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3727 SvCUR_set(sv, d - SvPVX_const(sv));
3731 if (utf8_variant_count == 0) {
3733 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3736 sv_utf8_upgrade_flags_grow(
3738 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3740 d = SvPVX(sv) + SvCUR(sv);
3744 has_above_latin1 = TRUE;
3747 /* Add the (Unicode) code point to the output. */
3748 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3749 *d++ = (char) LATIN1_TO_NATIVE(uv);
3752 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3756 else /* Here is \N{NAME} but not \N{U+...}. */
3757 if ((res = get_and_check_backslash_N_name(s, e)))
3760 const char *str = SvPV_const(res, len);
3763 if (! len) { /* The name resolved to an empty string */
3764 Copy("\\N{}", d, 4, char);
3768 /* In order to not lose information for the regex
3769 * compiler, pass the result in the specially made
3770 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3771 * the code points in hex of each character
3772 * returned by charnames */
3774 const char *str_end = str + len;
3775 const STRLEN off = d - SvPVX_const(sv);
3777 if (! SvUTF8(res)) {
3778 /* For the non-UTF-8 case, we can determine the
3779 * exact length needed without having to parse
3780 * through the string. Each character takes up
3781 * 2 hex digits plus either a trailing dot or
3783 const char initial_text[] = "\\N{U+";
3784 const STRLEN initial_len = sizeof(initial_text)
3786 d = off + SvGROW(sv, off
3789 /* +1 for trailing NUL */
3792 + (STRLEN)(send - e));
3793 Copy(initial_text, d, initial_len, char);
3795 while (str < str_end) {
3798 my_snprintf(hex_string,
3802 /* The regex compiler is
3803 * expecting Unicode, not
3805 NATIVE_TO_LATIN1(*str));
3806 PERL_MY_SNPRINTF_POST_GUARD(len,
3807 sizeof(hex_string));
3808 Copy(hex_string, d, 3, char);
3812 d--; /* Below, we will overwrite the final
3813 dot with a right brace */
3816 STRLEN char_length; /* cur char's byte length */
3818 /* and the number of bytes after this is
3819 * translated into hex digits */
3820 STRLEN output_length;
3822 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3823 * for max('U+', '.'); and 1 for NUL */
3824 char hex_string[2 * UTF8_MAXBYTES + 5];
3826 /* Get the first character of the result. */
3827 U32 uv = utf8n_to_uvchr((U8 *) str,
3831 /* Convert first code point to Unicode hex,
3832 * including the boiler plate before it. */
3834 my_snprintf(hex_string, sizeof(hex_string),
3836 (unsigned int) NATIVE_TO_UNI(uv));
3838 /* Make sure there is enough space to hold it */
3839 d = off + SvGROW(sv, off
3841 + (STRLEN)(send - e)
3842 + 2); /* '}' + NUL */
3844 Copy(hex_string, d, output_length, char);
3847 /* For each subsequent character, append dot and
3848 * its Unicode code point in hex */
3849 while ((str += char_length) < str_end) {
3850 const STRLEN off = d - SvPVX_const(sv);
3851 U32 uv = utf8n_to_uvchr((U8 *) str,
3856 my_snprintf(hex_string,
3859 (unsigned int) NATIVE_TO_UNI(uv));
3861 d = off + SvGROW(sv, off
3863 + (STRLEN)(send - e)
3864 + 2); /* '}' + NUL */
3865 Copy(hex_string, d, output_length, char);
3870 *d++ = '}'; /* Done. Add the trailing brace */
3873 else { /* Here, not in a pattern. Convert the name to a
3876 if (PL_lex_inwhat == OP_TRANS) {
3877 str = SvPV_const(res, len);
3878 if (len > ((SvUTF8(res))
3882 yyerror(Perl_form(aTHX_
3883 "%.*s must not be a named sequence"
3884 " in transliteration operator",
3885 /* +1 to include the "}" */
3886 (int) (e + 1 - start), start));
3888 goto end_backslash_N;
3891 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3892 has_above_latin1 = TRUE;
3896 else if (! SvUTF8(res)) {
3897 /* Make sure \N{} return is UTF-8. This is because
3898 * \N{} implies Unicode semantics, and scalars have
3899 * to be in utf8 to guarantee those semantics; but
3900 * not needed in tr/// */
3901 sv_utf8_upgrade_flags(res, 0);
3902 str = SvPV_const(res, len);
3905 /* Upgrade destination to be utf8 if this new
3907 if (! has_utf8 && SvUTF8(res)) {
3908 /* See Note on sizing above. */
3909 const STRLEN extra = len + (send - s) + 1;
3911 SvCUR_set(sv, d - SvPVX_const(sv));
3915 if (utf8_variant_count == 0) {
3917 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3920 sv_utf8_upgrade_flags_grow(sv,
3921 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3923 d = SvPVX(sv) + SvCUR(sv);
3926 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3928 /* See Note on sizing above. (NOTE: SvCUR() is not
3929 * set correctly here). */
3930 const STRLEN extra = len + (send - e) + 1;
3931 const STRLEN off = d - SvPVX_const(sv);
3932 d = off + SvGROW(sv, off + extra);
3934 Copy(str, d, len, char);
3940 } /* End \N{NAME} */
3944 backslash_N++; /* \N{} is defined to be Unicode */
3946 s = e + 1; /* Point to just after the '}' */
3949 /* \c is a control character */
3953 *d++ = grok_bslash_c(*s, 1);
3956 yyerror("Missing control char name in \\c");
3957 yyquit(); /* Are at end of input, no sense continuing */
3960 non_portable_endpoint++;
3964 /* printf-style backslashes, formfeeds, newlines, etc */
3990 } /* end if (backslash) */
3993 /* Just copy the input to the output, though we may have to convert
3996 * If the input has the same representation in UTF-8 as not, it will be
3997 * a single byte, and we don't care about UTF8ness; just copy the byte */
3998 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4001 else if (! this_utf8 && ! has_utf8) {
4002 /* If neither source nor output is UTF-8, is also a single byte,
4003 * just copy it; but this byte counts should we later have to
4004 * convert to UTF-8 */
4006 utf8_variant_count++;
4008 else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
4009 const STRLEN len = UTF8SKIP(s);
4011 /* We expect the source to have already been checked for
4013 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4015 Copy(s, d, len, U8);
4019 else { /* UTF8ness matters and doesn't match, need to convert */
4021 const UV nextuv = (this_utf8)
4022 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
4024 STRLEN need = UVCHR_SKIP(nextuv);
4027 SvCUR_set(sv, d - SvPVX_const(sv));
4031 /* See Note on sizing above. */
4032 need += (STRLEN)(send - s) + 1;
4034 if (utf8_variant_count == 0) {
4036 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4039 sv_utf8_upgrade_flags_grow(sv,
4040 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4042 d = SvPVX(sv) + SvCUR(sv);
4045 } else if (need > len) {
4046 /* encoded value larger than old, may need extra space (NOTE:
4047 * SvCUR() is not set correctly here). See Note on sizing
4049 const STRLEN extra = need + (send - s) + 1;
4050 const STRLEN off = d - SvPVX_const(sv);
4051 d = off + SvGROW(sv, off + extra);
4055 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
4057 } /* while loop to process each character */
4059 /* terminate the string and set up the sv */
4061 SvCUR_set(sv, d - SvPVX_const(sv));
4062 if (SvCUR(sv) >= SvLEN(sv))
4063 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
4064 " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
4069 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4070 PL_parser->lex_sub_op->op_private |=
4071 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4075 /* shrink the sv if we allocated more than we used */
4076 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4077 SvPV_shrink_to_cur(sv);
4080 /* return the substring (via pl_yylval) only if we parsed anything */
4083 for (; s2 < s; s2++) {
4085 COPLINE_INC_WITH_HERELINES;
4087 SvREFCNT_inc_simple_void_NN(sv);
4088 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4089 && ! PL_parser->lex_re_reparsing)
4091 const char *const key = PL_lex_inpat ? "qr" : "q";
4092 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4096 if (PL_lex_inwhat == OP_TRANS) {
4099 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4102 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4110 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4113 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4115 LEAVE_with_name("scan_const");
4120 * Returns TRUE if there's more to the expression (e.g., a subscript),
4123 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4125 * ->[ and ->{ return TRUE
4126 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4127 * { and [ outside a pattern are always subscripts, so return TRUE
4128 * if we're outside a pattern and it's not { or [, then return FALSE
4129 * if we're in a pattern and the first char is a {
4130 * {4,5} (any digits around the comma) returns FALSE
4131 * if we're in a pattern and the first char is a [
4133 * [SOMETHING] has a funky algorithm to decide whether it's a
4134 * character class or not. It has to deal with things like
4135 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4136 * anything else returns TRUE
4139 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4142 S_intuit_more(pTHX_ char *s)
4144 PERL_ARGS_ASSERT_INTUIT_MORE;
4146 if (PL_lex_brackets)
4148 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4150 if (*s == '-' && s[1] == '>'
4151 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4152 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4153 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4155 if (*s != '{' && *s != '[')
4160 /* In a pattern, so maybe we have {n,m}. */
4168 /* On the other hand, maybe we have a character class */
4171 if (*s == ']' || *s == '^')
4174 /* this is terrifying, and it works */
4177 const char * const send = strchr(s,']');
4178 unsigned char un_char, last_un_char;
4179 char tmpbuf[sizeof PL_tokenbuf * 4];
4181 if (!send) /* has to be an expression */
4183 weight = 2; /* let's weigh the evidence */
4187 else if (isDIGIT(*s)) {
4189 if (isDIGIT(s[1]) && s[2] == ']')
4195 Zero(seen,256,char);
4197 for (; s < send; s++) {
4198 last_un_char = un_char;
4199 un_char = (unsigned char)*s;
4204 weight -= seen[un_char] * 10;
4205 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4207 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4208 len = (int)strlen(tmpbuf);
4209 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4210 UTF ? SVf_UTF8 : 0, SVt_PV))
4217 && strchr("[#!%*<>()-=",s[1]))
4219 if (/*{*/ strchr("])} =",s[2]))
4228 if (strchr("wds]",s[1]))
4230 else if (seen[(U8)'\''] || seen[(U8)'"'])
4232 else if (strchr("rnftbxcav",s[1]))
4234 else if (isDIGIT(s[1])) {
4236 while (s[1] && isDIGIT(s[1]))
4246 if (strchr("aA01! ",last_un_char))
4248 if (strchr("zZ79~",s[1]))
4250 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4251 weight -= 5; /* cope with negative subscript */
4254 if (!isWORDCHAR(last_un_char)
4255 && !(last_un_char == '$' || last_un_char == '@'
4256 || last_un_char == '&')
4257 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4261 if (keyword(d, s - d, 0))
4264 if (un_char == last_un_char + 1)
4266 weight -= seen[un_char];
4271 if (weight >= 0) /* probably a character class */
4281 * Does all the checking to disambiguate
4283 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4284 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4286 * First argument is the stuff after the first token, e.g. "bar".
4288 * Not a method if foo is a filehandle.
4289 * Not a method if foo is a subroutine prototyped to take a filehandle.
4290 * Not a method if it's really "Foo $bar"
4291 * Method if it's "foo $bar"
4292 * Not a method if it's really "print foo $bar"
4293 * Method if it's really "foo package::" (interpreted as package->foo)
4294 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4295 * Not a method if bar is a filehandle or package, but is quoted with
4300 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4302 char *s = start + (*start == '$');
4303 char tmpbuf[sizeof PL_tokenbuf];
4306 /* Mustn't actually add anything to a symbol table.
4307 But also don't want to "initialise" any placeholder
4308 constants that might already be there into full
4309 blown PVGVs with attached PVCV. */
4311 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4313 PERL_ARGS_ASSERT_INTUIT_METHOD;
4315 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4317 if (cv && SvPOK(cv)) {
4318 const char *proto = CvPROTO(cv);
4320 while (*proto && (isSPACE(*proto) || *proto == ';'))
4327 if (*start == '$') {
4328 SSize_t start_off = start - SvPVX(PL_linestr);
4329 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4330 || isUPPER(*PL_tokenbuf))
4332 /* this could be $# */
4335 PL_bufptr = SvPVX(PL_linestr) + start_off;
4337 return *s == '(' ? FUNCMETH : METHOD;
4340 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4341 /* start is the beginning of the possible filehandle/object,
4342 * and s is the end of it
4343 * tmpbuf is a copy of it (but with single quotes as double colons)
4346 if (!keyword(tmpbuf, len, 0)) {
4347 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4352 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4353 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4355 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4356 && (!isGV(indirgv) || GvCVu(indirgv)))
4358 /* filehandle or package name makes it a method */
4359 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4361 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4362 return 0; /* no assumptions -- "=>" quotes bareword */
4364 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4365 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4366 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4368 force_next(BAREWORD);
4370 return *s == '(' ? FUNCMETH : METHOD;
4376 /* Encoded script support. filter_add() effectively inserts a
4377 * 'pre-processing' function into the current source input stream.
4378 * Note that the filter function only applies to the current source file
4379 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4381 * The datasv parameter (which may be NULL) can be used to pass
4382 * private data to this instance of the filter. The filter function
4383 * can recover the SV using the FILTER_DATA macro and use it to
4384 * store private buffers and state information.
4386 * The supplied datasv parameter is upgraded to a PVIO type
4387 * and the IoDIRP/IoANY field is used to store the function pointer,
4388 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4389 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4390 * private use must be set using malloc'd pointers.
4394 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4402 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4403 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4405 if (!PL_rsfp_filters)
4406 PL_rsfp_filters = newAV();
4409 SvUPGRADE(datasv, SVt_PVIO);
4410 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4411 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4412 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4413 FPTR2DPTR(void *, IoANY(datasv)),
4414 SvPV_nolen(datasv)));
4415 av_unshift(PL_rsfp_filters, 1);
4416 av_store(PL_rsfp_filters, 0, datasv) ;
4418 !PL_parser->filtered
4419 && PL_parser->lex_flags & LEX_EVALBYTES
4420 && PL_bufptr < PL_bufend
4422 const char *s = PL_bufptr;
4423 while (s < PL_bufend) {
4425 SV *linestr = PL_parser->linestr;
4426 char *buf = SvPVX(linestr);
4427 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4428 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4429 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4430 STRLEN const linestart_pos = PL_parser->linestart - buf;
4431 STRLEN const last_uni_pos =
4432 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4433 STRLEN const last_lop_pos =
4434 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4435 av_push(PL_rsfp_filters, linestr);
4436 PL_parser->linestr =
4437 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4438 buf = SvPVX(PL_parser->linestr);
4439 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4440 PL_parser->bufptr = buf + bufptr_pos;
4441 PL_parser->oldbufptr = buf + oldbufptr_pos;
4442 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4443 PL_parser->linestart = buf + linestart_pos;
4444 if (PL_parser->last_uni)
4445 PL_parser->last_uni = buf + last_uni_pos;
4446 if (PL_parser->last_lop)
4447 PL_parser->last_lop = buf + last_lop_pos;
4448 SvLEN_set(linestr, SvCUR(linestr));
4449 SvCUR_set(linestr, s - SvPVX(linestr));
4450 PL_parser->filtered = 1;
4460 /* Delete most recently added instance of this filter function. */
4462 Perl_filter_del(pTHX_ filter_t funcp)
4466 PERL_ARGS_ASSERT_FILTER_DEL;
4469 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4470 FPTR2DPTR(void*, funcp)));
4472 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4474 /* if filter is on top of stack (usual case) just pop it off */
4475 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4476 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4477 sv_free(av_pop(PL_rsfp_filters));
4481 /* we need to search for the correct entry and clear it */
4482 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4486 /* Invoke the idxth filter function for the current rsfp. */
4487 /* maxlen 0 = read one text line */
4489 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4493 /* This API is bad. It should have been using unsigned int for maxlen.
4494 Not sure if we want to change the API, but if not we should sanity
4495 check the value here. */
4496 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4498 PERL_ARGS_ASSERT_FILTER_READ;
4500 if (!PL_parser || !PL_rsfp_filters)
4502 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4503 /* Provide a default input filter to make life easy. */
4504 /* Note that we append to the line. This is handy. */
4505 DEBUG_P(PerlIO_printf(Perl_debug_log,
4506 "filter_read %d: from rsfp\n", idx));
4507 if (correct_length) {
4510 const int old_len = SvCUR(buf_sv);
4512 /* ensure buf_sv is large enough */
4513 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4514 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4515 correct_length)) <= 0) {
4516 if (PerlIO_error(PL_rsfp))
4517 return -1; /* error */
4519 return 0 ; /* end of file */
4521 SvCUR_set(buf_sv, old_len + len) ;
4522 SvPVX(buf_sv)[old_len + len] = '\0';
4525 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4526 if (PerlIO_error(PL_rsfp))
4527 return -1; /* error */
4529 return 0 ; /* end of file */
4532 return SvCUR(buf_sv);
4534 /* Skip this filter slot if filter has been deleted */
4535 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4536 DEBUG_P(PerlIO_printf(Perl_debug_log,
4537 "filter_read %d: skipped (filter deleted)\n",
4539 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4541 if (SvTYPE(datasv) != SVt_PVIO) {
4542 if (correct_length) {
4544 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4545 if (!remainder) return 0; /* eof */
4546 if (correct_length > remainder) correct_length = remainder;
4547 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4548 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4551 const char *s = SvEND(datasv);
4552 const char *send = SvPVX(datasv) + SvLEN(datasv);
4560 if (s == send) return 0; /* eof */
4561 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4562 SvCUR_set(datasv, s-SvPVX(datasv));
4564 return SvCUR(buf_sv);
4566 /* Get function pointer hidden within datasv */
4567 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4568 DEBUG_P(PerlIO_printf(Perl_debug_log,
4569 "filter_read %d: via function %p (%s)\n",
4570 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4571 /* Call function. The function is expected to */
4572 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4573 /* Return: <0:error, =0:eof, >0:not eof */
4574 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4578 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4580 PERL_ARGS_ASSERT_FILTER_GETS;
4582 #ifdef PERL_CR_FILTER
4583 if (!PL_rsfp_filters) {
4584 filter_add(S_cr_textfilter,NULL);
4587 if (PL_rsfp_filters) {
4589 SvCUR_set(sv, 0); /* start with empty line */
4590 if (FILTER_READ(0, sv, 0) > 0)
4591 return ( SvPVX(sv) ) ;
4596 return (sv_gets(sv, PL_rsfp, append));
4600 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4604 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4606 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4610 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4611 && (gv = gv_fetchpvn_flags(pkgname,
4613 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4615 return GvHV(gv); /* Foo:: */
4618 /* use constant CLASS => 'MyClass' */
4619 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4620 if (gv && GvCV(gv)) {
4621 SV * const sv = cv_const_sv(GvCV(gv));
4623 return gv_stashsv(sv, 0);
4626 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4631 S_tokenize_use(pTHX_ int is_use, char *s) {
4632 PERL_ARGS_ASSERT_TOKENIZE_USE;
4634 if (PL_expect != XSTATE)
4635 /* diag_listed_as: "use" not allowed in expression */
4636 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4637 is_use ? "use" : "no"));
4640 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4641 s = force_version(s, TRUE);
4642 if (*s == ';' || *s == '}'
4643 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4644 NEXTVAL_NEXTTOKE.opval = NULL;
4645 force_next(BAREWORD);
4647 else if (*s == 'v') {
4648 s = force_word(s,BAREWORD,FALSE,TRUE);
4649 s = force_version(s, FALSE);
4653 s = force_word(s,BAREWORD,FALSE,TRUE);
4654 s = force_version(s, FALSE);
4656 pl_yylval.ival = is_use;
4660 static const char* const exp_name[] =
4661 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4662 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4663 "SIGVAR", "TERMORDORDOR"
4667 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4669 S_word_takes_any_delimiter(char *p, STRLEN len)
4671 return (len == 1 && strchr("msyq", p[0]))
4673 && ((p[0] == 't' && p[1] == 'r')
4674 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4678 S_check_scalar_slice(pTHX_ char *s)
4681 while (SPACE_OR_TAB(*s)) s++;
4682 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4688 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4689 || (*s && strchr(" \t$#+-'\"", *s)))
4691 s += UTF ? UTF8SKIP(s) : 1;
4693 if (*s == '}' || *s == ']')
4694 pl_yylval.ival = OPpSLICEWARNING;
4697 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4699 S_lex_token_boundary(pTHX)
4701 PL_oldoldbufptr = PL_oldbufptr;
4702 PL_oldbufptr = PL_bufptr;
4705 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4707 S_vcs_conflict_marker(pTHX_ char *s)
4709 lex_token_boundary();
4711 yyerror("Version control conflict marker");
4712 while (s < PL_bufend && *s != '\n')
4720 Works out what to call the token just pulled out of the input
4721 stream. The yacc parser takes care of taking the ops we return and
4722 stitching them into a tree.
4725 The type of the next token
4728 Check if we have already built the token; if so, use it.
4729 Switch based on the current state:
4730 - if we have a case modifier in a string, deal with that
4731 - handle other cases of interpolation inside a string
4732 - scan the next line if we are inside a format
4733 In the normal state, switch on the next character:
4735 if alphabetic, go to key lookup
4736 unrecognized character - croak
4737 - 0/4/26: handle end-of-line or EOF
4738 - cases for whitespace
4739 - \n and #: handle comments and line numbers
4740 - various operators, brackets and sigils
4743 - 'v': vstrings (or go to key lookup)
4744 - 'x' repetition operator (or go to key lookup)
4745 - other ASCII alphanumerics (key lookup begins here):
4748 scan built-in keyword (but do nothing with it yet)
4749 check for statement label
4750 check for lexical subs
4751 goto just_a_word if there is one
4752 see whether built-in keyword is overridden
4753 switch on keyword number:
4754 - default: just_a_word:
4755 not a built-in keyword; handle bareword lookup
4756 disambiguate between method and sub call
4757 fall back to bareword
4758 - cases for built-in keywords
4766 char *s = PL_bufptr;
4770 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4774 /* orig_keyword, gvp, and gv are initialized here because
4775 * jump to the label just_a_word_zero can bypass their
4776 * initialization later. */
4777 I32 orig_keyword = 0;
4781 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4782 const U8* first_bad_char_loc;
4783 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4784 PL_bufend - PL_bufptr,
4785 &first_bad_char_loc)))
4787 _force_out_malformed_utf8_message(first_bad_char_loc,
4790 1 /* 1 means die */ );
4791 NOT_REACHED; /* NOTREACHED */
4793 PL_parser->recheck_utf8_validity = FALSE;
4796 SV* tmp = newSVpvs("");
4797 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4798 (IV)CopLINE(PL_curcop),
4799 lex_state_names[PL_lex_state],
4800 exp_name[PL_expect],
4801 pv_display(tmp, s, strlen(s), 0, 60));
4805 /* when we've already built the next token, just pull it out of the queue */
4808 pl_yylval = PL_nextval[PL_nexttoke];
4811 next_type = PL_nexttype[PL_nexttoke];
4812 if (next_type & (7<<24)) {
4813 if (next_type & (1<<24)) {
4814 if (PL_lex_brackets > 100)
4815 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4816 PL_lex_brackstack[PL_lex_brackets++] =
4817 (char) ((next_type >> 16) & 0xff);
4819 if (next_type & (2<<24))
4820 PL_lex_allbrackets++;
4821 if (next_type & (4<<24))
4822 PL_lex_allbrackets--;
4823 next_type &= 0xffff;
4825 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4829 switch (PL_lex_state) {
4831 case LEX_INTERPNORMAL:
4834 /* interpolated case modifiers like \L \U, including \Q and \E.
4835 when we get here, PL_bufptr is at the \
4837 case LEX_INTERPCASEMOD:
4839 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4841 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4842 PL_bufptr, PL_bufend, *PL_bufptr);
4844 /* handle \E or end of string */
4845 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4847 if (PL_lex_casemods) {
4848 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4849 PL_lex_casestack[PL_lex_casemods] = '\0';
4851 if (PL_bufptr != PL_bufend
4852 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4853 || oldmod == 'F')) {
4855 PL_lex_state = LEX_INTERPCONCAT;
4857 PL_lex_allbrackets--;
4860 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4861 /* Got an unpaired \E */
4862 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4863 "Useless use of \\E");
4865 if (PL_bufptr != PL_bufend)
4867 PL_lex_state = LEX_INTERPCONCAT;
4871 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4872 "### Saw case modifier\n"); });
4874 if (s[1] == '\\' && s[2] == 'E') {
4876 PL_lex_state = LEX_INTERPCONCAT;
4881 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4882 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4883 if ((*s == 'L' || *s == 'U' || *s == 'F')
4884 && (strpbrk(PL_lex_casestack, "LUF")))
4886 PL_lex_casestack[--PL_lex_casemods] = '\0';
4887 PL_lex_allbrackets--;
4890 if (PL_lex_casemods > 10)
4891 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4892 PL_lex_casestack[PL_lex_casemods++] = *s;
4893 PL_lex_casestack[PL_lex_casemods] = '\0';
4894 PL_lex_state = LEX_INTERPCONCAT;
4895 NEXTVAL_NEXTTOKE.ival = 0;
4896 force_next((2<<24)|'(');
4898 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4900 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4902 NEXTVAL_NEXTTOKE.ival = OP_LC;
4904 NEXTVAL_NEXTTOKE.ival = OP_UC;
4906 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4908 NEXTVAL_NEXTTOKE.ival = OP_FC;
4910 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4914 if (PL_lex_starts) {
4917 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4918 if (PL_lex_casemods == 1 && PL_lex_inpat)
4921 AopNOASSIGN(OP_CONCAT);
4927 case LEX_INTERPPUSH:
4928 return REPORT(sublex_push());
4930 case LEX_INTERPSTART:
4931 if (PL_bufptr == PL_bufend)
4932 return REPORT(sublex_done());
4933 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4934 "### Interpolated variable\n"); });
4936 /* for /@a/, we leave the joining for the regex engine to do
4937 * (unless we're within \Q etc) */
4938 PL_lex_dojoin = (*PL_bufptr == '@'
4939 && (!PL_lex_inpat || PL_lex_casemods));
4940 PL_lex_state = LEX_INTERPNORMAL;
4941 if (PL_lex_dojoin) {
4942 NEXTVAL_NEXTTOKE.ival = 0;
4944 force_ident("\"", '$');
4945 NEXTVAL_NEXTTOKE.ival = 0;
4947 NEXTVAL_NEXTTOKE.ival = 0;
4948 force_next((2<<24)|'(');
4949 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4952 /* Convert (?{...}) and friends to 'do {...}' */
4953 if (PL_lex_inpat && *PL_bufptr == '(') {
4954 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4956 if (*PL_bufptr != '{')
4958 PL_expect = XTERMBLOCK;
4962 if (PL_lex_starts++) {
4964 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4965 if (!PL_lex_casemods && PL_lex_inpat)
4968 AopNOASSIGN(OP_CONCAT);
4972 case LEX_INTERPENDMAYBE:
4973 if (intuit_more(PL_bufptr)) {
4974 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4980 if (PL_lex_dojoin) {
4981 const U8 dojoin_was = PL_lex_dojoin;
4982 PL_lex_dojoin = FALSE;
4983 PL_lex_state = LEX_INTERPCONCAT;
4984 PL_lex_allbrackets--;
4985 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
4987 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4988 && SvEVALED(PL_lex_repl))
4990 if (PL_bufptr != PL_bufend)
4991 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4994 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4995 re_eval_str. If the here-doc body’s length equals the previous
4996 value of re_eval_start, re_eval_start will now be null. So
4997 check re_eval_str as well. */
4998 if (PL_parser->lex_shared->re_eval_start
4999 || PL_parser->lex_shared->re_eval_str) {
5001 if (*PL_bufptr != ')')
5002 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5004 /* having compiled a (?{..}) expression, return the original
5005 * text too, as a const */
5006 if (PL_parser->lex_shared->re_eval_str) {
5007 sv = PL_parser->lex_shared->re_eval_str;
5008 PL_parser->lex_shared->re_eval_str = NULL;
5010 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5011 SvPV_shrink_to_cur(sv);
5013 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5014 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5015 NEXTVAL_NEXTTOKE.opval =
5016 newSVOP(OP_CONST, 0,
5019 PL_parser->lex_shared->re_eval_start = NULL;
5025 case LEX_INTERPCONCAT:
5027 if (PL_lex_brackets)
5028 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5029 (long) PL_lex_brackets);
5031 if (PL_bufptr == PL_bufend)
5032 return REPORT(sublex_done());
5034 /* m'foo' still needs to be parsed for possible (?{...}) */
5035 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5036 SV *sv = newSVsv(PL_linestr);
5038 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5042 int save_error_count = PL_error_count;
5044 s = scan_const(PL_bufptr);
5046 /* Set flag if this was a pattern and there were errors. op.c will
5047 * refuse to compile a pattern with this flag set. Otherwise, we
5048 * could get segfaults, etc. */
5049 if (PL_lex_inpat && PL_error_count > save_error_count) {
5050 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5053 PL_lex_state = LEX_INTERPCASEMOD;
5055 PL_lex_state = LEX_INTERPSTART;
5058 if (s != PL_bufptr) {
5059 NEXTVAL_NEXTTOKE = pl_yylval;
5062 if (PL_lex_starts++) {
5063 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5064 if (!PL_lex_casemods && PL_lex_inpat)
5067 AopNOASSIGN(OP_CONCAT);
5077 assert(PL_lex_formbrack);
5078 s = scan_formline(PL_bufptr);
5079 if (!PL_lex_formbrack)
5088 /* We really do *not* want PL_linestr ever becoming a COW. */
5089 assert (!SvIsCOW(PL_linestr));
5091 PL_oldoldbufptr = PL_oldbufptr;
5093 PL_parser->saw_infix_sigil = 0;
5095 if (PL_in_my == KEY_sigvar) {
5096 /* we expect the sigil and optional var name part of a
5097 * signature element here. Since a '$' is not necessarily
5098 * followed by a var name, handle it specially here; the general
5099 * yylex code would otherwise try to interpret whatever follows
5100 * as a var; e.g. ($, ...) would be seen as the var '$,'
5107 PL_bufptr = s; /* for error reporting */
5112 /* spot stuff that looks like an prototype */
5113 if (strchr("$:@%&*;\\[]", *s)) {
5114 yyerror("Illegal character following sigil in a subroutine signature");
5117 /* '$#' is banned, while '$ # comment' isn't */
5119 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5123 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5124 char *dest = PL_tokenbuf + 1;
5125 /* read var name, including sigil, into PL_tokenbuf */
5126 PL_tokenbuf[0] = sigil;
5127 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5128 0, cBOOL(UTF), FALSE);
5130 assert(PL_tokenbuf[1]); /* we have a variable name */
5138 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
5139 * as the ASSIGNOP, and exclude other tokens that start with =
5141 if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
5142 /* save now to report with the same context as we did when
5143 * all ASSIGNOPS were accepted */
5147 NEXTVAL_NEXTTOKE.ival = 0;
5148 force_next(ASSIGNOP);
5151 else if (*s == ',' || *s == ')') {
5152 PL_expect = XOPERATOR;
5155 /* make sure the context shows the unexpected character and
5156 * hopefully a bit more */
5158 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5160 PL_bufptr = s; /* for error reporting */
5161 yyerror("Illegal operator following parameter in a subroutine signature");
5165 NEXTVAL_NEXTTOKE.ival = sigil;
5166 force_next('p'); /* force a signature pending identifier */
5173 case ',': /* handle ($a,,$b) */
5178 yyerror("A signature parameter must start with '$', '@' or '%'");
5179 /* very crude error recovery: skip to likely next signature
5181 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5192 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5196 else if (isALNUMC(*s)) {
5200 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5203 STRLEN skiplen = UTF8SKIP(s);
5204 STRLEN stravail = PL_bufend - s;
5205 c = sv_uni_display(dsv, newSVpvn_flags(s,
5206 skiplen > stravail ? stravail : skiplen,
5207 SVs_TEMP | SVf_UTF8),
5208 10, UNI_DISPLAY_ISPRINT);
5211 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5214 if (s >= PL_linestart) {
5218 /* somehow (probably due to a parse failure), PL_linestart has advanced
5219 * pass PL_bufptr, get a reasonable beginning of line
5222 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
5225 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
5226 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5227 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
5230 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5231 UTF8fARG(UTF, (s - d), d),
5236 goto fake_eof; /* emulate EOF on ^D or ^Z */
5238 if ((!PL_rsfp || PL_lex_inwhat)
5239 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5243 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5245 yyerror((const char *)
5247 ? "Format not terminated"
5248 : "Missing right curly or square bracket"));
5250 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5251 "### Tokener got EOF\n");
5255 if (s++ < PL_bufend)
5256 goto retry; /* ignore stray nulls */
5259 if (!PL_in_eval && !PL_preambled) {
5260 PL_preambled = TRUE;
5262 /* Generate a string of Perl code to load the debugger.
5263 * If PERL5DB is set, it will return the contents of that,
5264 * otherwise a compile-time require of perl5db.pl. */
5266 const char * const pdb = PerlEnv_getenv("PERL5DB");
5269 sv_setpv(PL_linestr, pdb);
5270 sv_catpvs(PL_linestr,";");
5272 SETERRNO(0,SS_NORMAL);
5273 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5275 PL_parser->preambling = CopLINE(PL_curcop);
5277 SvPVCLEAR(PL_linestr);
5278 if (PL_preambleav) {
5279 SV **svp = AvARRAY(PL_preambleav);
5280 SV **const end = svp + AvFILLp(PL_preambleav);
5282 sv_catsv(PL_linestr, *svp);
5284 sv_catpvs(PL_linestr, ";");
5286 sv_free(MUTABLE_SV(PL_preambleav));
5287 PL_preambleav = NULL;
5290 sv_catpvs(PL_linestr,
5291 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5292 if (PL_minus_n || PL_minus_p) {
5293 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5295 sv_catpvs(PL_linestr,"chomp;");
5298 if ( ( *PL_splitstr == '/'
5299 || *PL_splitstr == '\''
5300 || *PL_splitstr == '"')
5301 && strchr(PL_splitstr + 1, *PL_splitstr))
5302 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5304 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5305 bytes can be used as quoting characters. :-) */
5306 const char *splits = PL_splitstr;
5307 sv_catpvs(PL_linestr, "our @F=split(q\0");
5310 if (*splits == '\\')
5311 sv_catpvn(PL_linestr, splits, 1);
5312 sv_catpvn(PL_linestr, splits, 1);
5313 } while (*splits++);
5314 /* This loop will embed the trailing NUL of
5315 PL_linestr as the last thing it does before
5317 sv_catpvs(PL_linestr, ");");
5321 sv_catpvs(PL_linestr,"our @F=split(' ');");
5324 sv_catpvs(PL_linestr, "\n");
5325 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5326 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5327 PL_last_lop = PL_last_uni = NULL;
5328 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5329 update_debugger_info(PL_linestr, NULL, 0);
5334 bof = cBOOL(PL_rsfp);
5337 fake_eof = LEX_FAKE_EOF;
5339 PL_bufptr = PL_bufend;
5340 COPLINE_INC_WITH_HERELINES;
5341 if (!lex_next_chunk(fake_eof)) {
5342 CopLINE_dec(PL_curcop);
5344 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5346 CopLINE_dec(PL_curcop);
5348 /* If it looks like the start of a BOM or raw UTF-16,
5349 * check if it in fact is. */
5352 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5356 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5357 bof = (offset == (Off_t)SvCUR(PL_linestr));
5358 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5359 /* offset may include swallowed CR */
5361 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5364 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5365 s = swallow_bom((U8*)s);
5368 if (PL_parser->in_pod) {
5369 /* Incest with pod. */
5370 if (*s == '=' && strEQs(s, "=cut") && !isALPHA(s[4])) {
5371 SvPVCLEAR(PL_linestr);
5372 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5373 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5374 PL_last_lop = PL_last_uni = NULL;
5375 PL_parser->in_pod = 0;
5378 if (PL_rsfp || PL_parser->filtered)
5380 } while (PL_parser->in_pod);
5381 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5382 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5383 PL_last_lop = PL_last_uni = NULL;
5384 if (CopLINE(PL_curcop) == 1) {
5385 while (s < PL_bufend && isSPACE(*s))
5387 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5391 if (*s == '#' && *(s+1) == '!')
5393 #ifdef ALTERNATE_SHEBANG
5395 static char const as[] = ALTERNATE_SHEBANG;
5396 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5397 d = s + (sizeof(as) - 1);
5399 #endif /* ALTERNATE_SHEBANG */
5408 while (*d && !isSPACE(*d))
5412 #ifdef ARG_ZERO_IS_SCRIPT
5413 if (ipathend > ipath) {
5415 * HP-UX (at least) sets argv[0] to the script name,
5416 * which makes $^X incorrect. And Digital UNIX and Linux,
5417 * at least, set argv[0] to the basename of the Perl
5418 * interpreter. So, having found "#!", we'll set it right.
5420 SV* copfilesv = CopFILESV(PL_curcop);
5423 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5425 assert(SvPOK(x) || SvGMAGICAL(x));
5426 if (sv_eq(x, copfilesv)) {
5427 sv_setpvn(x, ipath, ipathend - ipath);
5433 const char *bstart = SvPV_const(copfilesv, blen);
5434 const char * const lstart = SvPV_const(x, llen);
5436 bstart += blen - llen;
5437 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5438 sv_setpvn(x, ipath, ipathend - ipath);
5445 /* Anything to do if no copfilesv? */
5447 TAINT_NOT; /* $^X is always tainted, but that's OK */
5449 #endif /* ARG_ZERO_IS_SCRIPT */
5454 d = instr(s,"perl -");
5456 d = instr(s,"perl");
5458 /* avoid getting into infinite loops when shebang
5459 * line contains "Perl" rather than "perl" */
5461 for (d = ipathend-4; d >= ipath; --d) {
5462 if (isALPHA_FOLD_EQ(*d, 'p')
5463 && !ibcmp(d, "perl", 4))
5473 #ifdef ALTERNATE_SHEBANG
5475 * If the ALTERNATE_SHEBANG on this system starts with a
5476 * character that can be part of a Perl expression, then if
5477 * we see it but not "perl", we're probably looking at the
5478 * start of Perl code, not a request to hand off to some
5479 * other interpreter. Similarly, if "perl" is there, but
5480 * not in the first 'word' of the line, we assume the line
5481 * contains the start of the Perl program.
5483 if (d && *s != '#') {
5484 const char *c = ipath;
5485 while (*c && !strchr("; \t\r\n\f\v#", *c))
5488 d = NULL; /* "perl" not in first word; ignore */
5490 *s = '#'; /* Don't try to parse shebang line */
5492 #endif /* ALTERNATE_SHEBANG */
5497 && !instr(s,"indir")
5498 && instr(PL_origargv[0],"perl"))
5505 while (s < PL_bufend && isSPACE(*s))
5507 if (s < PL_bufend) {
5508 Newx(newargv,PL_origargc+3,char*);
5510 while (s < PL_bufend && !isSPACE(*s))
5513 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5516 newargv = PL_origargv;
5519 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5521 Perl_croak(aTHX_ "Can't exec %s", ipath);
5524 while (*d && !isSPACE(*d))
5526 while (SPACE_OR_TAB(*d))
5530 const bool switches_done = PL_doswitches;
5531 const U32 oldpdb = PL_perldb;
5532 const bool oldn = PL_minus_n;
5533 const bool oldp = PL_minus_p;
5537 bool baduni = FALSE;
5539 const char *d2 = d1 + 1;
5540 if (parse_unicode_opts((const char **)&d2)
5544 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5545 const char * const m = d1;
5546 while (*d1 && !isSPACE(*d1))
5548 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5551 d1 = moreswitches(d1);
5553 if (PL_doswitches && !switches_done) {
5554 int argc = PL_origargc;
5555 char **argv = PL_origargv;
5558 } while (argc && argv[0][0] == '-' && argv[0][1]);
5559 init_argv_symbols(argc,argv);
5561 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5562 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5563 /* if we have already added "LINE: while (<>) {",
5564 we must not do it again */
5566 SvPVCLEAR(PL_linestr);
5567 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5568 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5569 PL_last_lop = PL_last_uni = NULL;
5570 PL_preambled = FALSE;
5571 if (PERLDB_LINE_OR_SAVESRC)
5572 (void)gv_fetchfile(PL_origfilename);
5579 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5580 PL_lex_state = LEX_FORMLINE;
5581 force_next(FORMRBRACK);
5586 #ifdef PERL_STRICT_CR
5587 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5589 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5591 case ' ': case '\t': case '\f': case '\v':
5596 if (PL_lex_state != LEX_NORMAL
5597 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5599 const bool in_comment = *s == '#';
5600 if (*s == '#' && s == PL_linestart && PL_in_eval
5601 && !PL_rsfp && !PL_parser->filtered) {
5602 /* handle eval qq[#line 1 "foo"\n ...] */
5603 CopLINE_dec(PL_curcop);
5607 while (d < PL_bufend && *d != '\n')
5612 if (in_comment && d == PL_bufend
5613 && PL_lex_state == LEX_INTERPNORMAL
5614 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5615 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5618 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5619 PL_lex_state = LEX_FORMLINE;
5620 force_next(FORMRBRACK);
5625 while (s < PL_bufend && *s != '\n')
5636 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5644 while (s < PL_bufend && SPACE_OR_TAB(*s))
5647 if (strEQs(s,"=>")) {
5648 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5649 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5650 OPERATOR('-'); /* unary minus */
5653 case 'r': ftst = OP_FTEREAD; break;
5654 case 'w': ftst = OP_FTEWRITE; break;
5655 case 'x': ftst = OP_FTEEXEC; break;
5656 case 'o': ftst = OP_FTEOWNED; break;
5657 case 'R': ftst = OP_FTRREAD; break;
5658 case 'W': ftst = OP_FTRWRITE; break;
5659 case 'X': ftst = OP_FTREXEC; break;
5660 case 'O': ftst = OP_FTROWNED; break;
5661 case 'e': ftst = OP_FTIS; break;
5662 case 'z': ftst = OP_FTZERO; break;
5663 case 's': ftst = OP_FTSIZE; break;
5664 case 'f': ftst = OP_FTFILE; break;
5665 case 'd': ftst = OP_FTDIR; break;
5666 case 'l': ftst = OP_FTLINK; break;
5667 case 'p': ftst = OP_FTPIPE; break;
5668 case 'S': ftst = OP_FTSOCK; break;
5669 case 'u': ftst = OP_FTSUID; break;
5670 case 'g': ftst = OP_FTSGID; break;
5671 case 'k': ftst = OP_FTSVTX; break;
5672 case 'b': ftst = OP_FTBLK; break;
5673 case 'c': ftst = OP_FTCHR; break;
5674 case 't': ftst = OP_FTTTY; break;
5675 case 'T': ftst = OP_FTTEXT; break;
5676 case 'B': ftst = OP_FTBINARY; break;
5677 case 'M': case 'A': case 'C':
5678 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5680 case 'M': ftst = OP_FTMTIME; break;
5681 case 'A': ftst = OP_FTATIME; break;
5682 case 'C': ftst = OP_FTCTIME; break;
5690 PL_last_uni = PL_oldbufptr;
5691 PL_last_lop_op = (OPCODE)ftst;
5692 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5693 "### Saw file test %c\n", (int)tmp);
5698 /* Assume it was a minus followed by a one-letter named
5699 * subroutine call (or a -bareword), then. */
5700 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5701 "### '-%c' looked like a file test but was not\n",
5708 const char tmp = *s++;
5711 if (PL_expect == XOPERATOR)
5716 else if (*s == '>') {
5719 if (((*s == '$' || *s == '&') && s[1] == '*')
5720 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5721 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5722 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5725 PL_expect = XPOSTDEREF;
5728 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5729 s = force_word(s,METHOD,FALSE,TRUE);
5737 if (PL_expect == XOPERATOR) {
5739 && !PL_lex_allbrackets
5740 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5748 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5750 OPERATOR('-'); /* unary minus */
5756 const char tmp = *s++;
5759 if (PL_expect == XOPERATOR)
5764 if (PL_expect == XOPERATOR) {
5766 && !PL_lex_allbrackets
5767 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5775 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5782 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5783 if (PL_expect != XOPERATOR) {
5784 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5785 PL_expect = XOPERATOR;
5786 force_ident(PL_tokenbuf, '*');
5794 if (*s == '=' && !PL_lex_allbrackets
5795 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5803 && !PL_lex_allbrackets
5804 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5809 PL_parser->saw_infix_sigil = 1;
5814 if (PL_expect == XOPERATOR) {
5816 && !PL_lex_allbrackets
5817 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5822 PL_parser->saw_infix_sigil = 1;
5825 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5826 PL_tokenbuf[0] = '%';
5827 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5829 if (!PL_tokenbuf[1]) {
5832 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5834 PL_tokenbuf[0] = '@';
5836 PL_expect = XOPERATOR;
5837 force_ident_maybe_lex('%');
5842 bof = FEATURE_BITWISE_IS_ENABLED;
5843 if (bof && s[1] == '.')
5845 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5846 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5852 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5854 if (PL_lex_brackets > 100)
5855 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5856 PL_lex_brackstack[PL_lex_brackets++] = 0;
5857 PL_lex_allbrackets++;
5859 const char tmp = *s++;
5864 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5866 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5869 Perl_ck_warner_d(aTHX_
5870 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5871 "Smartmatch is experimental");
5875 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5877 BCop(OP_SCOMPLEMENT);
5879 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5881 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5888 goto just_a_word_zero_gv;
5894 switch (PL_expect) {
5896 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5898 PL_bufptr = s; /* update in case we back off */
5901 "Use of := for an empty attribute list is not allowed");
5908 PL_expect = XTERMBLOCK;
5912 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5915 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5916 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5917 if (tmp < 0) tmp = -tmp;
5932 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5934 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5939 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5941 COPLINE_SET_FROM_MULTI_END;
5944 sv_catsv(sv, PL_lex_stuff);
5945 attrs = op_append_elem(OP_LIST, attrs,
5946 newSVOP(OP_CONST, 0, sv));
5947 SvREFCNT_dec_NN(PL_lex_stuff);
5948 PL_lex_stuff = NULL;
5951 /* NOTE: any CV attrs applied here need to be part of
5952 the CVf_BUILTIN_ATTRS define in cv.h! */
5953 if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5955 CvLVALUE_on(PL_compcv);
5957 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5959 CvMETHOD_on(PL_compcv);
5961 else if (!PL_in_my && len == 5
5962 && strnEQ(SvPVX(sv), "const", len))
5965 Perl_ck_warner_d(aTHX_
5966 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5967 ":const is experimental"
5969 CvANONCONST_on(PL_compcv);
5970 if (!CvANON(PL_compcv))
5971 yyerror(":const is not permitted on named "
5974 /* After we've set the flags, it could be argued that
5975 we don't need to do the attributes.pm-based setting
5976 process, and shouldn't bother appending recognized
5977 flags. To experiment with that, uncomment the
5978 following "else". (Note that's already been
5979 uncommented. That keeps the above-applied built-in
5980 attributes from being intercepted (and possibly
5981 rejected) by a package's attribute routines, but is
5982 justified by the performance win for the common case
5983 of applying only built-in attributes.) */
5985 attrs = op_append_elem(OP_LIST, attrs,
5986 newSVOP(OP_CONST, 0,
5990 if (*s == ':' && s[1] != ':')
5993 break; /* require real whitespace or :'s */
5994 /* XXX losing whitespace on sequential attributes here */
5999 && !(PL_expect == XOPERATOR
6000 ? (*s == '=' || *s == ')')
6001 : (*s == '{' || *s == '(')))
6003 const char q = ((*s == '\'') ? '"' : '\'');
6004 /* If here for an expression, and parsed no attrs, back
6006 if (PL_expect == XOPERATOR && !attrs) {
6010 /* MUST advance bufptr here to avoid bogus "at end of line"
6011 context messages from yyerror().
6014 yyerror( (const char *)
6016 ? Perl_form(aTHX_ "Invalid separator character "
6017 "%c%c%c in attribute list", q, *s, q)
6018 : "Unterminated attribute list" ) );
6026 NEXTVAL_NEXTTOKE.opval = attrs;
6032 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6036 PL_lex_allbrackets--;
6040 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6041 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6045 PL_lex_allbrackets++;
6048 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6055 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6058 PL_lex_allbrackets--;
6064 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6067 if (PL_lex_brackets <= 0)
6068 /* diag_listed_as: Unmatched right %s bracket */
6069 yyerror("Unmatched right square bracket");
6072 PL_lex_allbrackets--;
6073 if (PL_lex_state == LEX_INTERPNORMAL) {
6074 if (PL_lex_brackets == 0) {
6075 if (*s == '-' && s[1] == '>')
6076 PL_lex_state = LEX_INTERPENDMAYBE;
6077 else if (*s != '[' && *s != '{')
6078 PL_lex_state = LEX_INTERPEND;
6085 if (PL_lex_brackets > 100) {
6086 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6088 switch (PL_expect) {
6091 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6092 PL_lex_allbrackets++;
6093 OPERATOR(HASHBRACK);
6095 while (s < PL_bufend && SPACE_OR_TAB(*s))
6098 PL_tokenbuf[0] = '\0';
6099 if (d < PL_bufend && *d == '-') {
6100 PL_tokenbuf[0] = '-';
6102 while (d < PL_bufend && SPACE_OR_TAB(*d))
6105 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6106 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6108 while (d < PL_bufend && SPACE_OR_TAB(*d))
6111 const char minus = (PL_tokenbuf[0] == '-');
6112 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6120 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6121 PL_lex_allbrackets++;
6126 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6127 PL_lex_allbrackets++;
6131 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6132 PL_lex_allbrackets++;
6137 if (PL_oldoldbufptr == PL_last_lop)
6138 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6140 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6141 PL_lex_allbrackets++;
6144 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6146 /* This hack is to get the ${} in the message. */
6148 yyerror("syntax error");
6151 OPERATOR(HASHBRACK);
6153 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6154 /* ${...} or @{...} etc., but not print {...}
6155 * Skip the disambiguation and treat this as a block.
6157 goto block_expectation;
6159 /* This hack serves to disambiguate a pair of curlies
6160 * as being a block or an anon hash. Normally, expectation
6161 * determines that, but in cases where we're not in a
6162 * position to expect anything in particular (like inside
6163 * eval"") we have to resolve the ambiguity. This code
6164 * covers the case where the first term in the curlies is a
6165 * quoted string. Most other cases need to be explicitly
6166 * disambiguated by prepending a "+" before the opening
6167 * curly in order to force resolution as an anon hash.
6169 * XXX should probably propagate the outer expectation
6170 * into eval"" to rely less on this hack, but that could
6171 * potentially break current behavior of eval"".
6175 if (*s == '\'' || *s == '"' || *s == '`') {
6176 /* common case: get past first string, handling escapes */
6177 for (t++; t < PL_bufend && *t != *s;)
6182 else if (*s == 'q') {
6185 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6186 && !isWORDCHAR(*t))))
6188 /* skip q//-like construct */
6190 char open, close, term;
6193 while (t < PL_bufend && isSPACE(*t))
6195 /* check for q => */
6196 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6197 OPERATOR(HASHBRACK);
6201 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6205 for (t++; t < PL_bufend; t++) {
6206 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6208 else if (*t == open)
6212 for (t++; t < PL_bufend; t++) {
6213 if (*t == '\\' && t+1 < PL_bufend)
6215 else if (*t == close && --brackets <= 0)
6217 else if (*t == open)
6224 /* skip plain q word */
6225 while ( t < PL_bufend
6226 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6228 t += UTF ? UTF8SKIP(t) : 1;
6231 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6232 t += UTF ? UTF8SKIP(t) : 1;
6233 while ( t < PL_bufend
6234 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6236 t += UTF ? UTF8SKIP(t) : 1;
6239 while (t < PL_bufend && isSPACE(*t))
6241 /* if comma follows first term, call it an anon hash */
6242 /* XXX it could be a comma expression with loop modifiers */
6243 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6244 || (*t == '=' && t[1] == '>')))
6245 OPERATOR(HASHBRACK);
6246 if (PL_expect == XREF)
6249 /* If there is an opening brace or 'sub:', treat it
6250 as a term to make ${{...}}{k} and &{sub:attr...}
6251 dwim. Otherwise, treat it as a statement, so
6252 map {no strict; ...} works.
6259 if (strEQs(s, "sub")) {
6272 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6278 pl_yylval.ival = CopLINE(PL_curcop);
6279 PL_copline = NOLINE; /* invalidate current command line number */
6280 TOKEN(formbrack ? '=' : '{');
6282 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6285 assert(s != PL_bufend);
6287 if (PL_lex_brackets <= 0)
6288 /* diag_listed_as: Unmatched right %s bracket */
6289 yyerror("Unmatched right curly bracket");
6291 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6292 PL_lex_allbrackets--;
6293 if (PL_lex_state == LEX_INTERPNORMAL) {
6294 if (PL_lex_brackets == 0) {
6295 if (PL_expect & XFAKEBRACK) {
6296 PL_expect &= XENUMMASK;
6297 PL_lex_state = LEX_INTERPEND;
6299 return yylex(); /* ignore fake brackets */
6301 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6302 && SvEVALED(PL_lex_repl))
6303 PL_lex_state = LEX_INTERPEND;
6304 else if (*s == '-' && s[1] == '>')
6305 PL_lex_state = LEX_INTERPENDMAYBE;
6306 else if (*s != '[' && *s != '{')
6307 PL_lex_state = LEX_INTERPEND;
6310 if (PL_expect & XFAKEBRACK) {
6311 PL_expect &= XENUMMASK;
6313 return yylex(); /* ignore fake brackets */
6315 force_next(formbrack ? '.' : '}');
6316 if (formbrack) LEAVE_with_name("lex_format");
6317 if (formbrack == 2) { /* means . where arguments were expected */
6323 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6326 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6327 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6334 if (PL_expect == XOPERATOR) {
6335 if ( PL_bufptr == PL_linestart
6336 && ckWARN(WARN_SEMICOLON)
6337 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6339 CopLINE_dec(PL_curcop);
6340 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6341 CopLINE_inc(PL_curcop);
6344 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6346 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6347 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6353 PL_parser->saw_infix_sigil = 1;
6354 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6360 PL_tokenbuf[0] = '&';
6361 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6362 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6363 if (PL_tokenbuf[1]) {
6364 force_ident_maybe_lex('&');
6373 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6374 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6382 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6384 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6385 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6389 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6393 const char tmp = *s++;
6395 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "=====")) {
6396 s = vcs_conflict_marker(s + 5);
6399 if (!PL_lex_allbrackets
6400 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6408 if (!PL_lex_allbrackets
6409 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6418 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6419 && strchr("+-*/%.^&|<",tmp))
6420 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6421 "Reversed %c= operator",(int)tmp);
6423 if (PL_expect == XSTATE
6425 && (s == PL_linestart+1 || s[-2] == '\n') )
6427 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6428 || PL_lex_state != LEX_NORMAL)
6434 if (strEQs(s,"=cut")) {
6448 PL_parser->in_pod = 1;
6452 if (PL_expect == XBLOCK) {
6454 #ifdef PERL_STRICT_CR
6455 while (SPACE_OR_TAB(*t))
6457 while (SPACE_OR_TAB(*t) || *t == '\r')
6460 if (*t == '\n' || *t == '#') {
6462 ENTER_with_name("lex_format");
6463 SAVEI8(PL_parser->form_lex_state);
6464 SAVEI32(PL_lex_formbrack);
6465 PL_parser->form_lex_state = PL_lex_state;
6466 PL_lex_formbrack = PL_lex_brackets + 1;
6470 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6479 const char tmp = *s++;
6481 /* was this !=~ where !~ was meant?
6482 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6484 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6485 const char *t = s+1;
6487 while (t < PL_bufend && isSPACE(*t))
6490 if (*t == '/' || *t == '?'
6491 || ((*t == 'm' || *t == 's' || *t == 'y')
6492 && !isWORDCHAR(t[1]))
6493 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6494 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6495 "!=~ should be !~");
6497 if (!PL_lex_allbrackets
6498 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6511 if (PL_expect != XOPERATOR) {
6512 if (s[1] != '<' && !strchr(s,'>'))
6514 if (s[1] == '<' && s[2] != '>') {
6515 if ((s == PL_linestart || s[-1] == '\n') && strEQs(s+2, "<<<<<")) {
6516 s = vcs_conflict_marker(s + 7);
6519 s = scan_heredoc(s);
6522 s = scan_inputsymbol(s);
6523 PL_expect = XOPERATOR;
6524 TOKEN(sublex_start());
6530 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "<<<<<")) {
6531 s = vcs_conflict_marker(s + 5);
6534 if (*s == '=' && !PL_lex_allbrackets
6535 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6540 SHop(OP_LEFT_SHIFT);
6545 if (!PL_lex_allbrackets
6546 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6554 if (!PL_lex_allbrackets
6555 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6564 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6572 const char tmp = *s++;
6574 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, ">>>>>")) {
6575 s = vcs_conflict_marker(s + 5);
6578 if (*s == '=' && !PL_lex_allbrackets
6579 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6584 SHop(OP_RIGHT_SHIFT);
6586 else if (tmp == '=') {
6587 if (!PL_lex_allbrackets
6588 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6597 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6606 if (PL_expect == XPOSTDEREF) {
6609 POSTDEREF(DOLSHARP);
6615 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6616 || strchr("{$:+-@", s[2])))
6618 PL_tokenbuf[0] = '@';
6619 s = scan_ident(s + 1, PL_tokenbuf + 1,
6620 sizeof PL_tokenbuf - 1, FALSE);
6621 if (PL_expect == XOPERATOR) {
6623 if (PL_bufptr > s) {
6625 PL_bufptr = PL_oldbufptr;
6627 no_op("Array length", d);
6629 if (!PL_tokenbuf[1])
6631 PL_expect = XOPERATOR;
6632 force_ident_maybe_lex('#');
6636 PL_tokenbuf[0] = '$';
6637 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6638 if (PL_expect == XOPERATOR) {
6640 if (PL_bufptr > s) {
6642 PL_bufptr = PL_oldbufptr;
6646 if (!PL_tokenbuf[1]) {
6648 yyerror("Final $ should be \\$ or $name");
6654 const char tmp = *s;
6655 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6658 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6659 && intuit_more(s)) {
6661 PL_tokenbuf[0] = '@';
6662 if (ckWARN(WARN_SYNTAX)) {
6666 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6669 t += UTF ? UTF8SKIP(t) : 1;
6672 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6673 while (t < PL_bufend && *t != ']')
6675 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6676 "Multidimensional syntax %" UTF8f " not supported",
6677 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6681 else if (*s == '{') {
6683 PL_tokenbuf[0] = '%';
6684 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6685 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6687 char tmpbuf[sizeof PL_tokenbuf];
6690 } while (isSPACE(*t));
6691 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6693 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6698 && get_cvn_flags(tmpbuf, len, UTF
6702 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6703 "You need to quote \"%" UTF8f "\"",
6704 UTF8fARG(UTF, len, tmpbuf));
6711 PL_expect = XOPERATOR;
6712 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6713 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6714 if (!islop || PL_last_lop_op == OP_GREPSTART)
6715 PL_expect = XOPERATOR;
6716 else if (strchr("$@\"'`q", *s))
6717 PL_expect = XTERM; /* e.g. print $fh "foo" */
6718 else if ( strchr("&*<%", *s)
6719 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6721 PL_expect = XTERM; /* e.g. print $fh &sub */
6723 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6724 char tmpbuf[sizeof PL_tokenbuf];
6726 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6727 if ((t2 = keyword(tmpbuf, len, 0))) {
6728 /* binary operators exclude handle interpretations */
6740 PL_expect = XTERM; /* e.g. print $fh length() */
6745 PL_expect = XTERM; /* e.g. print $fh subr() */
6748 else if (isDIGIT(*s))
6749 PL_expect = XTERM; /* e.g. print $fh 3 */
6750 else if (*s == '.' && isDIGIT(s[1]))
6751 PL_expect = XTERM; /* e.g. print $fh .3 */
6752 else if ((*s == '?' || *s == '-' || *s == '+')
6753 && !isSPACE(s[1]) && s[1] != '=')
6754 PL_expect = XTERM; /* e.g. print $fh -1 */
6755 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6757 PL_expect = XTERM; /* e.g. print $fh /.../
6758 XXX except DORDOR operator
6760 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6762 PL_expect = XTERM; /* print $fh <<"EOF" */
6765 force_ident_maybe_lex('$');
6769 if (PL_expect == XPOSTDEREF)
6771 PL_tokenbuf[0] = '@';
6772 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6773 if (PL_expect == XOPERATOR) {
6775 if (PL_bufptr > s) {
6777 PL_bufptr = PL_oldbufptr;
6782 if (!PL_tokenbuf[1]) {
6785 if (PL_lex_state == LEX_NORMAL)
6787 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6789 PL_tokenbuf[0] = '%';
6791 /* Warn about @ where they meant $. */
6792 if (*s == '[' || *s == '{') {
6793 if (ckWARN(WARN_SYNTAX)) {
6794 S_check_scalar_slice(aTHX_ s);
6798 PL_expect = XOPERATOR;
6799 force_ident_maybe_lex('@');
6802 case '/': /* may be division, defined-or, or pattern */
6803 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6804 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6805 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6810 else if (PL_expect == XOPERATOR) {
6812 if (*s == '=' && !PL_lex_allbrackets
6813 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6821 /* Disable warning on "study /blah/" */
6822 if ( PL_oldoldbufptr == PL_last_uni
6823 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6824 || memNE(PL_last_uni, "study", 5)
6825 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6828 s = scan_pat(s,OP_MATCH);
6829 TERM(sublex_start());
6832 case '?': /* conditional */
6834 if (!PL_lex_allbrackets
6835 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6840 PL_lex_allbrackets++;
6844 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6845 #ifdef PERL_STRICT_CR
6848 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6850 && (s == PL_linestart || s[-1] == '\n') )
6853 formbrack = 2; /* dot seen where arguments expected */
6856 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6860 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6863 if (!PL_lex_allbrackets
6864 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6872 pl_yylval.ival = OPf_SPECIAL;
6878 if (*s == '=' && !PL_lex_allbrackets
6879 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6887 case '0': case '1': case '2': case '3': case '4':
6888 case '5': case '6': case '7': case '8': case '9':
6889 s = scan_num(s, &pl_yylval);
6890 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6891 if (PL_expect == XOPERATOR)
6896 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6899 COPLINE_SET_FROM_MULTI_END;
6900 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6901 if (PL_expect == XOPERATOR) {
6904 pl_yylval.ival = OP_CONST;
6905 TERM(sublex_start());
6908 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6911 printbuf("### Saw string before %s\n", s);
6913 PerlIO_printf(Perl_debug_log,
6914 "### Saw unterminated string\n");
6916 if (PL_expect == XOPERATOR) {
6921 pl_yylval.ival = OP_CONST;
6922 /* FIXME. I think that this can be const if char *d is replaced by
6923 more localised variables. */
6924 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6925 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6926 pl_yylval.ival = OP_STRINGIFY;
6930 if (pl_yylval.ival == OP_CONST)
6931 COPLINE_SET_FROM_MULTI_END;
6932 TERM(sublex_start());
6935 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6938 printbuf("### Saw backtick string before %s\n", s);
6940 PerlIO_printf(Perl_debug_log,
6941 "### Saw unterminated backtick string\n");
6943 if (PL_expect == XOPERATOR)
6944 no_op("Backticks",s);
6947 pl_yylval.ival = OP_BACKTICK;
6948 TERM(sublex_start());
6952 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6954 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6956 if (PL_expect == XOPERATOR)
6957 no_op("Backslash",s);
6961 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6962 char *start = s + 2;
6963 while (isDIGIT(*start) || *start == '_')
6965 if (*start == '.' && isDIGIT(start[1])) {
6966 s = scan_num(s, &pl_yylval);
6969 else if ((*start == ':' && start[1] == ':')
6970 || (PL_expect == XSTATE && *start == ':'))
6972 else if (PL_expect == XSTATE) {
6974 while (d < PL_bufend && isSPACE(*d)) d++;
6975 if (*d == ':') goto keylookup;
6977 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6978 if (!isALPHA(*start) && (PL_expect == XTERM
6979 || PL_expect == XREF || PL_expect == XSTATE
6980 || PL_expect == XTERMORDORDOR)) {
6981 GV *const gv = gv_fetchpvn_flags(s, start - s,
6982 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6984 s = scan_num(s, &pl_yylval);
6991 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7044 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7046 /* Some keywords can be followed by any delimiter, including ':' */
7047 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7049 /* x::* is just a word, unless x is "CORE" */
7050 if (!anydelim && *s == ':' && s[1] == ':') {
7051 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
7056 while (d < PL_bufend && isSPACE(*d))
7057 d++; /* no comments skipped here, or s### is misparsed */
7059 /* Is this a word before a => operator? */
7060 if (*d == '=' && d[1] == '>') {
7064 = newSVOP(OP_CONST, 0,
7065 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7066 pl_yylval.opval->op_private = OPpCONST_BARE;
7070 /* Check for plugged-in keyword */
7074 char *saved_bufptr = PL_bufptr;
7076 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7078 if (result == KEYWORD_PLUGIN_DECLINE) {
7079 /* not a plugged-in keyword */
7080 PL_bufptr = saved_bufptr;
7081 } else if (result == KEYWORD_PLUGIN_STMT) {
7082 pl_yylval.opval = o;
7084 if (!PL_nexttoke) PL_expect = XSTATE;
7085 return REPORT(PLUGSTMT);
7086 } else if (result == KEYWORD_PLUGIN_EXPR) {
7087 pl_yylval.opval = o;
7089 if (!PL_nexttoke) PL_expect = XOPERATOR;
7090 return REPORT(PLUGEXPR);
7092 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7097 /* Check for built-in keyword */
7098 tmp = keyword(PL_tokenbuf, len, 0);
7100 /* Is this a label? */
7101 if (!anydelim && PL_expect == XSTATE
7102 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7104 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7105 pl_yylval.pval[len] = '\0';
7106 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7111 /* Check for lexical sub */
7112 if (PL_expect != XOPERATOR) {
7113 char tmpbuf[sizeof PL_tokenbuf + 1];
7115 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7116 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7117 if (off != NOT_IN_PAD) {
7118 assert(off); /* we assume this is boolean-true below */
7119 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7120 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7121 HEK * const stashname = HvNAME_HEK(stash);
7122 sv = newSVhek(stashname);
7123 sv_catpvs(sv, "::");
7124 sv_catpvn_flags(sv, PL_tokenbuf, len,
7125 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7126 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7136 rv2cv_op = newOP(OP_PADANY, 0);
7137 rv2cv_op->op_targ = off;
7138 cv = find_lexical_cv(off);
7146 if (tmp < 0) { /* second-class keyword? */
7147 GV *ogv = NULL; /* override (winner) */
7148 GV *hgv = NULL; /* hidden (loser) */
7149 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7151 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7152 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7154 && (cv = GvCVu(gv)))
7156 if (GvIMPORTED_CV(gv))
7158 else if (! CvMETHOD(cv))
7162 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7165 && (isGV_with_GP(gv)
7166 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7167 : SvPCS_IMPORTED(gv)
7168 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7176 tmp = 0; /* overridden by import or by GLOBAL */
7179 && -tmp==KEY_lock /* XXX generalizable kludge */
7182 tmp = 0; /* any sub overrides "weak" keyword */
7184 else { /* no override */
7186 if (tmp == KEY_dump) {
7187 Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED),
7188 "dump() better written as CORE::dump(). "
7189 "dump() will no longer be available "
7194 if (hgv && tmp != KEY_x) /* never ambiguous */
7195 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7196 "Ambiguous call resolved as CORE::%s(), "
7197 "qualify as such or use &",
7202 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7203 && (!anydelim || *s != '#')) {
7204 /* no override, and not s### either; skipspace is safe here
7205 * check for => on following line */
7207 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7208 STRLEN soff = s - SvPVX(PL_linestr);
7210 arrow = *s == '=' && s[1] == '>';
7211 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7212 s = SvPVX(PL_linestr) + soff;
7220 /* Trade off - by using this evil construction we can pull the
7221 variable gv into the block labelled keylookup. If not, then
7222 we have to give it function scope so that the goto from the
7223 earlier ':' case doesn't bypass the initialisation. */
7224 just_a_word_zero_gv:
7234 default: /* not a keyword */
7237 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7241 /* Get the rest if it looks like a package qualifier */
7243 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7245 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7248 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7249 UTF8fARG(UTF, len, PL_tokenbuf),
7250 *s == '\'' ? "'" : "::");
7255 if (PL_expect == XOPERATOR) {
7256 if (PL_bufptr == PL_linestart) {
7257 CopLINE_dec(PL_curcop);
7258 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7259 CopLINE_inc(PL_curcop);
7262 no_op("Bareword",s);
7265 /* See if the name is "Foo::",
7266 in which case Foo is a bareword
7267 (and a package name). */
7270 && PL_tokenbuf[len - 2] == ':'
7271 && PL_tokenbuf[len - 1] == ':')
7273 if (ckWARN(WARN_BAREWORD)
7274 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7275 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7276 "Bareword \"%" UTF8f
7277 "\" refers to nonexistent package",
7278 UTF8fARG(UTF, len, PL_tokenbuf));
7280 PL_tokenbuf[len] = '\0';
7289 /* if we saw a global override before, get the right name */
7292 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7295 SV * const tmp_sv = sv;
7296 sv = newSVpvs("CORE::GLOBAL::");
7297 sv_catsv(sv, tmp_sv);
7298 SvREFCNT_dec(tmp_sv);
7302 /* Presume this is going to be a bareword of some sort. */
7304 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7305 pl_yylval.opval->op_private = OPpCONST_BARE;
7307 /* And if "Foo::", then that's what it certainly is. */
7313 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7314 const_op->op_private = OPpCONST_BARE;
7316 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7320 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7323 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7326 /* Use this var to track whether intuit_method has been
7327 called. intuit_method returns 0 or > 255. */
7330 /* See if it's the indirect object for a list operator. */
7333 && PL_oldoldbufptr < PL_bufptr
7334 && (PL_oldoldbufptr == PL_last_lop
7335 || PL_oldoldbufptr == PL_last_uni)
7336 && /* NO SKIPSPACE BEFORE HERE! */
7338 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7341 bool immediate_paren = *s == '(';
7344 /* (Now we can afford to cross potential line boundary.) */
7347 /* intuit_method() can indirectly call lex_next_chunk(),
7350 s_off = s - SvPVX(PL_linestr);
7351 /* Two barewords in a row may indicate method call. */
7352 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7354 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7356 /* the code at method: doesn't use s */
7359 s = SvPVX(PL_linestr) + s_off;
7361 /* If not a declared subroutine, it's an indirect object. */
7362 /* (But it's an indir obj regardless for sort.) */
7363 /* Also, if "_" follows a filetest operator, it's a bareword */
7366 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7368 && (PL_last_lop_op != OP_MAPSTART
7369 && PL_last_lop_op != OP_GREPSTART))))
7370 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7371 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7375 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7380 PL_expect = XOPERATOR;
7383 /* Is this a word before a => operator? */
7384 if (*s == '=' && s[1] == '>' && !pkgname) {
7387 if (gvp || (lex && !off)) {
7388 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7389 /* This is our own scalar, created a few lines
7390 above, so this is safe. */
7392 sv_setpv(sv, PL_tokenbuf);
7393 if (UTF && !IN_BYTES
7394 && is_utf8_string((U8*)PL_tokenbuf, len))
7401 /* If followed by a paren, it's certainly a subroutine. */
7406 while (SPACE_OR_TAB(*d))
7408 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7413 NEXTVAL_NEXTTOKE.opval =
7414 off ? rv2cv_op : pl_yylval.opval;
7416 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7417 else op_free(rv2cv_op), force_next(BAREWORD);
7422 /* If followed by var or block, call it a method (unless sub) */
7424 if ((*s == '$' || *s == '{') && !cv) {
7426 PL_last_lop = PL_oldbufptr;
7427 PL_last_lop_op = OP_METHOD;
7428 if (!PL_lex_allbrackets
7429 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7431 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7433 PL_expect = XBLOCKTERM;
7435 return REPORT(METHOD);
7438 /* If followed by a bareword, see if it looks like indir obj. */
7442 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7443 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7447 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7449 sv_setpvn(sv, PL_tokenbuf, len);
7450 if (UTF && !IN_BYTES
7451 && is_utf8_string((U8*)PL_tokenbuf, len))
7453 else SvUTF8_off(sv);
7456 if (tmp == METHOD && !PL_lex_allbrackets
7457 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7459 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7464 /* Not a method, so call it a subroutine (if defined) */
7467 /* Check for a constant sub */
7468 if ((sv = cv_const_sv_or_av(cv))) {
7471 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7472 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7473 if (SvTYPE(sv) == SVt_PVAV)
7474 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7477 pl_yylval.opval->op_private = 0;
7478 pl_yylval.opval->op_folded = 1;
7479 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7484 op_free(pl_yylval.opval);
7486 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7487 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7488 PL_last_lop = PL_oldbufptr;
7489 PL_last_lop_op = OP_ENTERSUB;
7490 /* Is there a prototype? */
7494 STRLEN protolen = CvPROTOLEN(cv);
7495 const char *proto = CvPROTO(cv);
7497 proto = S_strip_spaces(aTHX_ proto, &protolen);
7500 if ((optional = *proto == ';'))
7503 while (*proto == ';');
7507 *proto == '$' || *proto == '_'
7508 || *proto == '*' || *proto == '+'
7513 *proto == '\\' && proto[1] && proto[2] == '\0'
7516 UNIPROTO(UNIOPSUB,optional);
7517 if (*proto == '\\' && proto[1] == '[') {
7518 const char *p = proto + 2;
7519 while(*p && *p != ']')
7521 if(*p == ']' && !p[1])
7522 UNIPROTO(UNIOPSUB,optional);
7524 if (*proto == '&' && *s == '{') {
7526 sv_setpvs(PL_subname, "__ANON__");
7528 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7529 if (!PL_lex_allbrackets
7530 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7532 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7537 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7539 force_next(off ? PRIVATEREF : BAREWORD);
7540 if (!PL_lex_allbrackets
7541 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7543 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7548 /* Call it a bare word */
7550 if (PL_hints & HINT_STRICT_SUBS)
7551 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7554 /* after "print" and similar functions (corresponding to
7555 * "F? L" in opcode.pl), whatever wasn't already parsed as
7556 * a filehandle should be subject to "strict subs".
7557 * Likewise for the optional indirect-object argument to system
7558 * or exec, which can't be a bareword */
7559 if ((PL_last_lop_op == OP_PRINT
7560 || PL_last_lop_op == OP_PRTF
7561 || PL_last_lop_op == OP_SAY
7562 || PL_last_lop_op == OP_SYSTEM
7563 || PL_last_lop_op == OP_EXEC)
7564 && (PL_hints & HINT_STRICT_SUBS))
7565 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7566 if (lastchar != '-') {
7567 if (ckWARN(WARN_RESERVED)) {
7571 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7573 /* PL_warn_reserved is constant */
7574 GCC_DIAG_IGNORE(-Wformat-nonliteral);
7575 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7585 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7586 && saw_infix_sigil) {
7587 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7588 "Operator or semicolon missing before %c%" UTF8f,
7590 UTF8fARG(UTF, strlen(PL_tokenbuf),
7592 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7593 "Ambiguous use of %c resolved as operator %c",
7594 lastchar, lastchar);
7601 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7606 newSVOP(OP_CONST, 0,
7607 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7610 case KEY___PACKAGE__:
7612 newSVOP(OP_CONST, 0,
7614 ? newSVhek(HvNAME_HEK(PL_curstash))
7621 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7622 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7625 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7627 gv_init(gv,stash,"DATA",4,0);
7630 GvIOp(gv) = newIO();
7631 IoIFP(GvIOp(gv)) = PL_rsfp;
7632 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
7634 const int fd = PerlIO_fileno(PL_rsfp);
7636 fcntl(fd,F_SETFD, FD_CLOEXEC);
7640 /* Mark this internal pseudo-handle as clean */
7641 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7642 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7643 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7645 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7646 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7647 /* if the script was opened in binmode, we need to revert
7648 * it to text mode for compatibility; but only iff it has CRs
7649 * XXX this is a questionable hack at best. */
7650 if (PL_bufend-PL_bufptr > 2
7651 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7654 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7655 loc = PerlIO_tell(PL_rsfp);
7656 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7659 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7661 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7662 #endif /* NETWARE */
7664 PerlIO_seek(PL_rsfp, loc, 0);
7668 #ifdef PERLIO_LAYERS
7671 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7680 FUN0OP(CvCLONE(PL_compcv)
7681 ? newOP(OP_RUNCV, 0)
7682 : newPVOP(OP_RUNCV,0,NULL));
7691 if (PL_expect == XSTATE) {
7702 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7703 if ((*s == ':' && s[1] == ':')
7704 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7708 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7712 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7713 UTF8fARG(UTF, len, PL_tokenbuf));
7716 else if (tmp == KEY_require || tmp == KEY_do
7718 /* that's a way to remember we saw "CORE::" */
7730 LOP(OP_ACCEPT,XTERM);
7733 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7738 LOP(OP_ATAN2,XTERM);
7744 LOP(OP_BINMODE,XTERM);
7747 LOP(OP_BLESS,XTERM);
7756 /* We have to disambiguate the two senses of
7757 "continue". If the next token is a '{' then
7758 treat it as the start of a continue block;
7759 otherwise treat it as a control operator.
7769 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7779 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7788 if (!PL_cryptseen) {
7789 PL_cryptseen = TRUE;
7793 LOP(OP_CRYPT,XTERM);
7796 LOP(OP_CHMOD,XTERM);
7799 LOP(OP_CHOWN,XTERM);
7802 LOP(OP_CONNECT,XTERM);
7822 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7824 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7825 && !keyword(PL_tokenbuf + 1, len, 0)) {
7826 SSize_t off = s-SvPVX(PL_linestr);
7828 s = SvPVX(PL_linestr)+off;
7830 force_ident_maybe_lex('&');
7835 if (orig_keyword == KEY_do) {
7844 PL_hints |= HINT_BLOCK_SCOPE;
7854 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7855 STR_WITH_LEN("NDBM_File::"),
7856 STR_WITH_LEN("DB_File::"),
7857 STR_WITH_LEN("GDBM_File::"),
7858 STR_WITH_LEN("SDBM_File::"),
7859 STR_WITH_LEN("ODBM_File::"),
7861 LOP(OP_DBMOPEN,XTERM);
7873 pl_yylval.ival = CopLINE(PL_curcop);
7877 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7889 if (*s == '{') { /* block eval */
7890 PL_expect = XTERMBLOCK;
7891 UNIBRACK(OP_ENTERTRY);
7893 else { /* string eval */
7895 UNIBRACK(OP_ENTEREVAL);
7900 UNIBRACK(-OP_ENTEREVAL);
7914 case KEY_endhostent:
7920 case KEY_endservent:
7923 case KEY_endprotoent:
7934 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7936 pl_yylval.ival = CopLINE(PL_curcop);
7938 if ( PL_expect == XSTATE
7939 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
7942 SSize_t s_off = s - SvPVX(PL_linestr);
7944 if ((PL_bufend - p) >= 3
7945 && strEQs(p, "my") && isSPACE(*(p + 2)))
7949 else if ((PL_bufend - p) >= 4
7950 && strEQs(p, "our") && isSPACE(*(p + 3)))
7953 /* skip optional package name, as in "for my abc $x (..)" */
7954 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
7955 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7958 if (*p != '$' && *p != '\\')
7959 Perl_croak(aTHX_ "Missing $ on loop variable");
7961 /* The buffer may have been reallocated, update s */
7962 s = SvPVX(PL_linestr) + s_off;
7967 LOP(OP_FORMLINE,XTERM);
7976 LOP(OP_FCNTL,XTERM);
7982 LOP(OP_FLOCK,XTERM);
7985 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7990 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7995 LOP(OP_GREPSTART, XREF);
8012 case KEY_getpriority:
8013 LOP(OP_GETPRIORITY,XTERM);
8015 case KEY_getprotobyname:
8018 case KEY_getprotobynumber:
8019 LOP(OP_GPBYNUMBER,XTERM);
8021 case KEY_getprotoent:
8033 case KEY_getpeername:
8034 UNI(OP_GETPEERNAME);
8036 case KEY_gethostbyname:
8039 case KEY_gethostbyaddr:
8040 LOP(OP_GHBYADDR,XTERM);
8042 case KEY_gethostent:
8045 case KEY_getnetbyname:
8048 case KEY_getnetbyaddr:
8049 LOP(OP_GNBYADDR,XTERM);
8054 case KEY_getservbyname:
8055 LOP(OP_GSBYNAME,XTERM);
8057 case KEY_getservbyport:
8058 LOP(OP_GSBYPORT,XTERM);
8060 case KEY_getservent:
8063 case KEY_getsockname:
8064 UNI(OP_GETSOCKNAME);
8066 case KEY_getsockopt:
8067 LOP(OP_GSOCKOPT,XTERM);
8082 pl_yylval.ival = CopLINE(PL_curcop);
8083 Perl_ck_warner_d(aTHX_
8084 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8085 "given is experimental");
8090 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8098 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8100 pl_yylval.ival = CopLINE(PL_curcop);
8104 LOP(OP_INDEX,XTERM);
8110 LOP(OP_IOCTL,XTERM);
8137 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8142 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8156 LOP(OP_LISTEN,XTERM);
8165 s = scan_pat(s,OP_MATCH);
8166 TERM(sublex_start());
8169 LOP(OP_MAPSTART, XREF);
8172 LOP(OP_MKDIR,XTERM);
8175 LOP(OP_MSGCTL,XTERM);
8178 LOP(OP_MSGGET,XTERM);
8181 LOP(OP_MSGRCV,XTERM);
8184 LOP(OP_MSGSND,XTERM);
8191 yyerror(Perl_form(aTHX_
8192 "Can't redeclare \"%s\" in \"%s\"",
8193 tmp == KEY_my ? "my" :
8194 tmp == KEY_state ? "state" : "our",
8195 PL_in_my == KEY_my ? "my" :
8196 PL_in_my == KEY_state ? "state" : "our"));
8198 PL_in_my = (U16)tmp;
8200 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8201 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8202 if (len == 3 && strEQs(PL_tokenbuf, "sub"))
8204 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8205 if (!PL_in_my_stash) {
8209 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8210 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8211 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8214 else if (*s == '\\') {
8215 if (!FEATURE_MYREF_IS_ENABLED)
8216 Perl_croak(aTHX_ "The experimental declared_refs "
8217 "feature is not enabled");
8218 Perl_ck_warner_d(aTHX_
8219 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8220 "Declaring references is experimental");
8228 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8233 s = tokenize_use(0, s);
8237 if (*s == '(' || (s = skipspace(s), *s == '('))
8240 if (!PL_lex_allbrackets
8241 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8243 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8250 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8252 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8254 for (t=d; isSPACE(*t);)
8256 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8258 && !(t[0] == '=' && t[1] == '>')
8259 && !(t[0] == ':' && t[1] == ':')
8260 && !keyword(s, d-s, 0)
8262 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8263 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8264 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8270 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8272 pl_yylval.ival = OP_OR;
8282 LOP(OP_OPEN_DIR,XTERM);
8285 checkcomma(s,PL_tokenbuf,"filehandle");
8289 checkcomma(s,PL_tokenbuf,"filehandle");
8308 s = force_word(s,BAREWORD,FALSE,TRUE);
8310 s = force_strict_version(s);
8314 LOP(OP_PIPE_OP,XTERM);
8317 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8320 COPLINE_SET_FROM_MULTI_END;
8321 pl_yylval.ival = OP_CONST;
8322 TERM(sublex_start());
8329 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8332 COPLINE_SET_FROM_MULTI_END;
8333 PL_expect = XOPERATOR;
8334 if (SvCUR(PL_lex_stuff)) {
8335 int warned_comma = !ckWARN(WARN_QW);
8336 int warned_comment = warned_comma;
8337 d = SvPV_force(PL_lex_stuff, len);
8339 for (; isSPACE(*d) && len; --len, ++d)
8344 if (!warned_comma || !warned_comment) {
8345 for (; !isSPACE(*d) && len; --len, ++d) {
8346 if (!warned_comma && *d == ',') {
8347 Perl_warner(aTHX_ packWARN(WARN_QW),
8348 "Possible attempt to separate words with commas");
8351 else if (!warned_comment && *d == '#') {
8352 Perl_warner(aTHX_ packWARN(WARN_QW),
8353 "Possible attempt to put comments in qw() list");
8359 for (; !isSPACE(*d) && len; --len, ++d)
8362 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8363 words = op_append_elem(OP_LIST, words,
8364 newSVOP(OP_CONST, 0, tokeq(sv)));
8369 words = newNULLLIST();
8370 SvREFCNT_dec_NN(PL_lex_stuff);
8371 PL_lex_stuff = NULL;
8372 PL_expect = XOPERATOR;
8373 pl_yylval.opval = sawparens(words);
8378 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8381 pl_yylval.ival = OP_STRINGIFY;
8382 if (SvIVX(PL_lex_stuff) == '\'')
8383 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8384 TERM(sublex_start());
8387 s = scan_pat(s,OP_QR);
8388 TERM(sublex_start());
8391 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8394 pl_yylval.ival = OP_BACKTICK;
8395 TERM(sublex_start());
8403 s = force_version(s, FALSE);
8405 else if (*s != 'v' || !isDIGIT(s[1])
8406 || (s = force_version(s, TRUE), *s == 'v'))
8408 *PL_tokenbuf = '\0';
8409 s = force_word(s,BAREWORD,TRUE,TRUE);
8410 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8411 PL_tokenbuf + sizeof(PL_tokenbuf),
8414 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8415 GV_ADD | (UTF ? SVf_UTF8 : 0));
8418 yyerror("<> at require-statement should be quotes");
8420 if (orig_keyword == KEY_require) {
8426 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8428 PL_last_uni = PL_oldbufptr;
8429 PL_last_lop_op = OP_REQUIRE;
8431 return REPORT( (int)REQUIRE );
8440 LOP(OP_RENAME,XTERM);
8449 LOP(OP_RINDEX,XTERM);
8458 UNIDOR(OP_READLINE);
8461 UNIDOR(OP_BACKTICK);
8470 LOP(OP_REVERSE,XTERM);
8473 UNIDOR(OP_READLINK);
8480 if (pl_yylval.opval)
8481 TERM(sublex_start());
8483 TOKEN(1); /* force error */
8486 checkcomma(s,PL_tokenbuf,"filehandle");
8496 LOP(OP_SELECT,XTERM);
8502 LOP(OP_SEMCTL,XTERM);
8505 LOP(OP_SEMGET,XTERM);
8508 LOP(OP_SEMOP,XTERM);
8514 LOP(OP_SETPGRP,XTERM);
8516 case KEY_setpriority:
8517 LOP(OP_SETPRIORITY,XTERM);
8519 case KEY_sethostent:
8525 case KEY_setservent:
8528 case KEY_setprotoent:
8538 LOP(OP_SEEKDIR,XTERM);
8540 case KEY_setsockopt:
8541 LOP(OP_SSOCKOPT,XTERM);
8547 LOP(OP_SHMCTL,XTERM);
8550 LOP(OP_SHMGET,XTERM);
8553 LOP(OP_SHMREAD,XTERM);
8556 LOP(OP_SHMWRITE,XTERM);
8559 LOP(OP_SHUTDOWN,XTERM);
8568 LOP(OP_SOCKET,XTERM);
8570 case KEY_socketpair:
8571 LOP(OP_SOCKPAIR,XTERM);
8574 checkcomma(s,PL_tokenbuf,"subroutine name");
8577 s = force_word(s,BAREWORD,TRUE,TRUE);
8581 LOP(OP_SPLIT,XTERM);
8584 LOP(OP_SPRINTF,XTERM);
8587 LOP(OP_SPLICE,XTERM);
8602 LOP(OP_SUBSTR,XTERM);
8608 char * const tmpbuf = PL_tokenbuf + 1;
8609 expectation attrful;
8610 bool have_name, have_proto;
8611 const int key = tmp;
8612 SV *format_name = NULL;
8614 SSize_t off = s-SvPVX(PL_linestr);
8616 d = SvPVX(PL_linestr)+off;
8618 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8620 || (*s == ':' && s[1] == ':'))
8624 attrful = XATTRBLOCK;
8625 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8627 if (key == KEY_format)
8628 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8630 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8632 PL_tokenbuf, len + 1, 0
8634 sv_setpvn(PL_subname, tmpbuf, len);
8636 sv_setsv(PL_subname,PL_curstname);
8637 sv_catpvs(PL_subname,"::");
8638 sv_catpvn(PL_subname,tmpbuf,len);
8640 if (SvUTF8(PL_linestr))
8641 SvUTF8_on(PL_subname);
8648 if (key == KEY_my || key == KEY_our || key==KEY_state)
8651 /* diag_listed_as: Missing name in "%s sub" */
8653 "Missing name in \"%s\"", PL_bufptr);
8655 PL_expect = XTERMBLOCK;
8656 attrful = XATTRTERM;
8657 sv_setpvs(PL_subname,"?");
8661 if (key == KEY_format) {
8663 NEXTVAL_NEXTTOKE.opval
8664 = newSVOP(OP_CONST,0, format_name);
8665 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8666 force_next(BAREWORD);
8671 /* Look for a prototype */
8672 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8673 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8674 COPLINE_SET_FROM_MULTI_END;
8676 Perl_croak(aTHX_ "Prototype not terminated");
8677 (void)validate_proto(PL_subname, PL_lex_stuff,
8678 ckWARN(WARN_ILLEGALPROTO), 0);
8686 if (*s == ':' && s[1] != ':')
8687 PL_expect = attrful;
8688 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8689 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8690 key == KEY_DESTROY || key == KEY_BEGIN ||
8691 key == KEY_UNITCHECK || key == KEY_CHECK ||
8692 key == KEY_INIT || key == KEY_END ||
8693 key == KEY_my || key == KEY_state ||
8696 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8697 else if (*s != ';' && *s != '}')
8698 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8702 NEXTVAL_NEXTTOKE.opval =
8703 newSVOP(OP_CONST, 0, PL_lex_stuff);
8704 PL_lex_stuff = NULL;
8709 sv_setpvs(PL_subname, "__ANON__");
8711 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8714 force_ident_maybe_lex('&');
8719 LOP(OP_SYSTEM,XREF);
8722 LOP(OP_SYMLINK,XTERM);
8725 LOP(OP_SYSCALL,XTERM);
8728 LOP(OP_SYSOPEN,XTERM);
8731 LOP(OP_SYSSEEK,XTERM);
8734 LOP(OP_SYSREAD,XTERM);
8737 LOP(OP_SYSWRITE,XTERM);
8742 TERM(sublex_start());
8763 LOP(OP_TRUNCATE,XTERM);
8775 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8777 pl_yylval.ival = CopLINE(PL_curcop);
8781 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8783 pl_yylval.ival = CopLINE(PL_curcop);
8787 LOP(OP_UNLINK,XTERM);
8793 LOP(OP_UNPACK,XTERM);
8796 LOP(OP_UTIME,XTERM);
8802 LOP(OP_UNSHIFT,XTERM);
8805 s = tokenize_use(1, s);
8815 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8817 pl_yylval.ival = CopLINE(PL_curcop);
8818 Perl_ck_warner_d(aTHX_
8819 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8820 "when is experimental");
8824 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8826 pl_yylval.ival = CopLINE(PL_curcop);
8830 PL_hints |= HINT_BLOCK_SCOPE;
8837 LOP(OP_WAITPID,XTERM);
8843 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8844 * we use the same number on EBCDIC */
8845 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8849 if (PL_expect == XOPERATOR) {
8850 if (*s == '=' && !PL_lex_allbrackets
8851 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8861 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8863 pl_yylval.ival = OP_XOR;
8872 Looks up an identifier in the pad or in a package
8874 is_sig indicates that this is a subroutine signature variable
8875 rather than a plain pad var.
8878 PRIVATEREF if this is a lexical name.
8879 BAREWORD if this belongs to a package.
8882 if we're in a my declaration
8883 croak if they tried to say my($foo::bar)
8884 build the ops for a my() declaration
8885 if it's an access to a my() variable
8886 build ops for access to a my() variable
8887 if in a dq string, and they've said @foo and we can't find @foo
8889 build ops for a bareword
8893 S_pending_ident(pTHX)
8896 const char pit = (char)pl_yylval.ival;
8897 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8898 /* All routes through this function want to know if there is a colon. */
8899 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8901 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8902 "### Pending identifier '%s'\n", PL_tokenbuf); });
8904 /* if we're in a my(), we can't allow dynamics here.
8905 $foo'bar has already been turned into $foo::bar, so
8906 just check for colons.
8908 if it's a legal name, the OP is a PADANY.
8911 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8913 /* diag_listed_as: No package name allowed for variable %s
8915 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8916 "%se %s in \"our\"",
8917 *PL_tokenbuf=='&' ?"subroutin":"variabl",
8918 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8919 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8924 /* "my" variable %s can't be in a package */
8925 /* PL_no_myglob is constant */
8926 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8927 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8928 PL_in_my == KEY_my ? "my" : "state",
8929 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8931 UTF ? SVf_UTF8 : 0);
8935 if (PL_in_my == KEY_sigvar) {
8936 /* A signature 'padop' needs in addition, an op_first to
8937 * point to a child sigdefelem, and an extra field to hold
8938 * the signature index. We can achieve both by using an
8939 * UNOP_AUX and (ab)using the op_aux field to hold the
8940 * index. If we ever need more fields, use a real malloced
8941 * aux strut instead.
8943 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
8944 INT2PTR(UNOP_AUX_item *,
8945 (PL_parser->sig_elems)));
8946 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
8947 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
8951 o = newOP(OP_PADANY, 0);
8952 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8953 UTF ? SVf_UTF8 : 0);
8954 if (PL_in_my == KEY_sigvar)
8957 pl_yylval.opval = o;
8963 build the ops for accesses to a my() variable.
8968 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8970 if (tmp != NOT_IN_PAD) {
8971 /* might be an "our" variable" */
8972 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8973 /* build ops for a bareword */
8974 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8975 HEK * const stashname = HvNAME_HEK(stash);
8976 SV * const sym = newSVhek(stashname);
8977 sv_catpvs(sym, "::");
8978 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8979 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
8980 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8984 ((PL_tokenbuf[0] == '$') ? SVt_PV
8985 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8990 pl_yylval.opval = newOP(OP_PADANY, 0);
8991 pl_yylval.opval->op_targ = tmp;
8997 Whine if they've said @foo or @foo{key} in a doublequoted string,
8998 and @foo (or %foo) isn't a variable we can find in the symbol
9001 if (ckWARN(WARN_AMBIGUOUS)
9003 && PL_lex_state != LEX_NORMAL
9004 && !PL_lex_brackets)
9006 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9007 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9009 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9012 /* Downgraded from fatal to warning 20000522 mjd */
9013 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9014 "Possible unintended interpolation of %" UTF8f
9016 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9020 /* build ops for a bareword */
9021 pl_yylval.opval = newSVOP(OP_CONST, 0,
9022 newSVpvn_flags(PL_tokenbuf + 1,
9024 UTF ? SVf_UTF8 : 0 ));
9025 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9027 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9028 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9029 | ( UTF ? SVf_UTF8 : 0 ),
9030 ((PL_tokenbuf[0] == '$') ? SVt_PV
9031 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9037 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9039 PERL_ARGS_ASSERT_CHECKCOMMA;
9041 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9042 if (ckWARN(WARN_SYNTAX)) {
9045 for (w = s+2; *w && level; w++) {
9053 /* the list of chars below is for end of statements or
9054 * block / parens, boolean operators (&&, ||, //) and branch
9055 * constructs (or, and, if, until, unless, while, err, for).
9056 * Not a very solid hack... */
9057 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9058 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9059 "%s (...) interpreted as function",name);
9062 while (s < PL_bufend && isSPACE(*s))
9066 while (s < PL_bufend && isSPACE(*s))
9068 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9069 const char * const w = s;
9070 s += UTF ? UTF8SKIP(s) : 1;
9071 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9072 s += UTF ? UTF8SKIP(s) : 1;
9073 while (s < PL_bufend && isSPACE(*s))
9077 if (keyword(w, s - w, 0))
9080 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9081 if (gv && GvCVu(gv))
9086 Copy(w, tmpbuf+1, s - w, char);
9088 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9089 if (off != NOT_IN_PAD) return;
9091 Perl_croak(aTHX_ "No comma allowed after %s", what);
9096 /* S_new_constant(): do any overload::constant lookup.
9098 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9099 Best used as sv=new_constant(..., sv, ...).
9100 If s, pv are NULL, calls subroutine with one argument,
9101 and <type> is used with error messages only.
9102 <type> is assumed to be well formed UTF-8 */
9105 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9106 SV *sv, SV *pv, const char *type, STRLEN typelen)
9109 HV * table = GvHV(PL_hintgv); /* ^H */
9114 const char *why1 = "", *why2 = "", *why3 = "";
9116 PERL_ARGS_ASSERT_NEW_CONSTANT;
9117 /* We assume that this is true: */
9118 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9121 /* charnames doesn't work well if there have been errors found */
9122 if (PL_error_count > 0 && *key == 'c')
9124 SvREFCNT_dec_NN(sv);
9125 return &PL_sv_undef;
9128 sv_2mortal(sv); /* Parent created it permanently */
9130 || ! (PL_hints & HINT_LOCALIZE_HH)
9131 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9136 /* Here haven't found what we're looking for. If it is charnames,
9137 * perhaps it needs to be loaded. Try doing that before giving up */
9139 Perl_load_module(aTHX_
9141 newSVpvs("_charnames"),
9142 /* version parameter; no need to specify it, as if
9143 * we get too early a version, will fail anyway,
9144 * not being able to find '_charnames' */
9149 assert(sp == PL_stack_sp);
9150 table = GvHV(PL_hintgv);
9152 && (PL_hints & HINT_LOCALIZE_HH)
9153 && (cvp = hv_fetch(table, key, keylen, FALSE))
9159 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9160 msg = Perl_form(aTHX_
9161 "Constant(%.*s) unknown",
9162 (int)(type ? typelen : len),
9168 why3 = "} is not defined";
9171 msg = Perl_form(aTHX_
9172 /* The +3 is for '\N{'; -4 for that, plus '}' */
9173 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9177 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9178 (int)(type ? typelen : len),
9179 (type ? type: s), why1, why2, why3);
9182 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9183 return SvREFCNT_inc_simple_NN(sv);
9188 pv = newSVpvn_flags(s, len, SVs_TEMP);
9190 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9192 typesv = &PL_sv_undef;
9194 PUSHSTACKi(PERLSI_OVERLOAD);
9206 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9210 /* Check the eval first */
9211 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9213 const char * errstr;
9214 sv_catpvs(errsv, "Propagated");
9215 errstr = SvPV_const(errsv, errlen);
9216 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9218 res = SvREFCNT_inc_simple_NN(sv);
9222 SvREFCNT_inc_simple_void_NN(res);
9231 why1 = "Call to &{$^H{";
9233 why3 = "}} did not return a defined value";
9235 (void)sv_2mortal(sv);
9242 PERL_STATIC_INLINE void
9243 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9244 bool is_utf8, bool check_dollar)
9246 PERL_ARGS_ASSERT_PARSE_IDENT;
9248 while (*s < PL_bufend) {
9250 Perl_croak(aTHX_ "%s", ident_too_long);
9251 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9252 /* The UTF-8 case must come first, otherwise things
9253 * like c\N{COMBINING TILDE} would start failing, as the
9254 * isWORDCHAR_A case below would gobble the 'c' up.
9257 char *t = *s + UTF8SKIP(*s);
9258 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9261 if (*d + (t - *s) > e)
9262 Perl_croak(aTHX_ "%s", ident_too_long);
9263 Copy(*s, *d, t - *s, char);
9267 else if ( isWORDCHAR_A(**s) ) {
9270 } while (isWORDCHAR_A(**s) && *d < e);
9272 else if ( allow_package
9274 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9280 else if (allow_package && **s == ':' && (*s)[1] == ':'
9281 /* Disallow things like Foo::$bar. For the curious, this is
9282 * the code path that triggers the "Bad name after" warning
9283 * when looking for barewords.
9285 && !(check_dollar && (*s)[2] == '$')) {
9295 /* Returns a NUL terminated string, with the length of the string written to
9299 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9302 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9303 bool is_utf8 = cBOOL(UTF);
9305 PERL_ARGS_ASSERT_SCAN_WORD;
9307 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE);
9313 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9314 * iff Unicode semantics are to be used. The legal ones are any of:
9315 * a) all ASCII characters except:
9316 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9318 * The final case currently doesn't get this far in the program, so we
9319 * don't test for it. If that were to change, it would be ok to allow it.
9320 * b) When not under Unicode rules, any upper Latin1 character
9321 * c) Otherwise, when unicode rules are used, all XIDS characters.
9323 * Because all ASCII characters have the same representation whether
9324 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9325 * '{' without knowing if is UTF-8 or not. */
9326 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9327 (isGRAPH_A(*(s)) || ((is_utf8) \
9328 ? isIDFIRST_utf8_safe(s, e) \
9330 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9333 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9335 I32 herelines = PL_parser->herelines;
9336 SSize_t bracket = -1;
9339 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9340 bool is_utf8 = cBOOL(UTF);
9341 I32 orig_copline = 0, tmp_copline = 0;
9343 PERL_ARGS_ASSERT_SCAN_IDENT;
9345 if (isSPACE(*s) || !*s)
9348 while (isDIGIT(*s)) {
9350 Perl_croak(aTHX_ "%s", ident_too_long);
9354 else { /* See if it is a "normal" identifier */
9355 parse_ident(&s, &d, e, 1, is_utf8, FALSE);
9360 /* Either a digit variable, or parse_ident() found an identifier
9361 (anything valid as a bareword), so job done and return. */
9362 if (PL_lex_state != LEX_NORMAL)
9363 PL_lex_state = LEX_INTERPENDMAYBE;
9367 /* Here, it is not a run-of-the-mill identifier name */
9369 if (*s == '$' && s[1]
9370 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9371 || isDIGIT_A((U8)s[1])
9374 || strEQs(s+1,"::")) )
9376 /* Dereferencing a value in a scalar variable.
9377 The alternatives are different syntaxes for a scalar variable.
9378 Using ' as a leading package separator isn't allowed. :: is. */
9381 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9383 bracket = s - SvPVX(PL_linestr);
9385 orig_copline = CopLINE(PL_curcop);
9386 if (s < PL_bufend && isSPACE(*s)) {
9390 if ((s <= PL_bufend - (is_utf8)
9393 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9396 const STRLEN skip = UTF8SKIP(s);
9399 for ( i = 0; i < skip; i++ )
9407 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9408 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9412 /* Warn about ambiguous code after unary operators if {...} notation isn't
9413 used. There's no difference in ambiguity; it's merely a heuristic
9414 about when not to warn. */
9415 else if (ck_uni && bracket == -1)
9417 if (bracket != -1) {
9420 /* If we were processing {...} notation then... */
9421 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9422 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9425 /* note we have to check for a normal identifier first,
9426 * as it handles utf8 symbols, and only after that has
9427 * been ruled out can we look at the caret words */
9428 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9429 /* if it starts as a valid identifier, assume that it is one.
9430 (the later check for } being at the expected point will trap
9431 cases where this doesn't pan out.) */
9432 d += is_utf8 ? UTF8SKIP(d) : 1;
9433 parse_ident(&s, &d, e, 1, is_utf8, TRUE);
9436 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9438 while (isWORDCHAR(*s) && d < e) {
9442 Perl_croak(aTHX_ "%s", ident_too_long);
9445 tmp_copline = CopLINE(PL_curcop);
9446 if (s < PL_bufend && isSPACE(*s)) {
9449 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9450 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9451 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9452 const char * const brack =
9454 ((*s == '[') ? "[...]" : "{...}");
9455 orig_copline = CopLINE(PL_curcop);
9456 CopLINE_set(PL_curcop, tmp_copline);
9457 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9458 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9459 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9460 funny, dest, brack, funny, dest, brack);
9461 CopLINE_set(PL_curcop, orig_copline);
9464 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9465 PL_lex_allbrackets++;
9471 tmp_copline = CopLINE(PL_curcop);
9472 if ((skip = s < PL_bufend && isSPACE(*s))) {
9473 /* Avoid incrementing line numbers or resetting PL_linestart,
9474 in case we have to back up. */
9475 STRLEN s_off = s - SvPVX(PL_linestr);
9477 s = SvPVX(PL_linestr) + s_off;
9482 /* Expect to find a closing } after consuming any trailing whitespace.
9485 /* Now increment line numbers if applicable. */
9489 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9490 PL_lex_state = LEX_INTERPEND;
9493 if (PL_lex_state == LEX_NORMAL) {
9494 if (ckWARN(WARN_AMBIGUOUS)
9495 && (keyword(dest, d - dest, 0)
9496 || get_cvn_flags(dest, d - dest, is_utf8
9500 SV *tmp = newSVpvn_flags( dest, d - dest,
9501 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9504 orig_copline = CopLINE(PL_curcop);
9505 CopLINE_set(PL_curcop, tmp_copline);
9506 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9507 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9508 funny, SVfARG(tmp), funny, SVfARG(tmp));
9509 CopLINE_set(PL_curcop, orig_copline);
9514 /* Didn't find the closing } at the point we expected, so restore
9515 state such that the next thing to process is the opening { and */
9516 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9517 CopLINE_set(PL_curcop, orig_copline);
9518 PL_parser->herelines = herelines;
9522 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9523 PL_lex_state = LEX_INTERPEND;
9528 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9530 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9531 * found in the parse starting at 's', based on the subset that are valid
9532 * in this context input to this routine in 'valid_flags'. Advances s.
9533 * Returns TRUE if the input should be treated as a valid flag, so the next
9534 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9535 * upon first call on the current regex. This routine will set it to any
9536 * charset modifier found. The caller shouldn't change it. This way,
9537 * another charset modifier encountered in the parse can be detected as an
9538 * error, as we have decided to allow only one */
9541 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9543 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9544 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9545 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9546 UTF ? SVf_UTF8 : 0);
9548 /* Pretend that it worked, so will continue processing before
9557 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9558 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9559 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9560 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9561 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9562 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9563 case LOCALE_PAT_MOD:
9565 goto multiple_charsets;
9567 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9570 case UNICODE_PAT_MOD:
9572 goto multiple_charsets;
9574 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9577 case ASCII_RESTRICT_PAT_MOD:
9579 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9583 /* Error if previous modifier wasn't an 'a', but if it was, see
9584 * if, and accept, a second occurrence (only) */
9586 || get_regex_charset(*pmfl)
9587 != REGEX_ASCII_RESTRICTED_CHARSET)
9589 goto multiple_charsets;
9591 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9595 case DEPENDS_PAT_MOD:
9597 goto multiple_charsets;
9599 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9608 if (*charset != c) {
9609 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9611 else if (c == 'a') {
9612 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9613 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9616 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9619 /* Pretend that it worked, so will continue processing before dieing */
9625 S_scan_pat(pTHX_ char *start, I32 type)
9629 const char * const valid_flags =
9630 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9631 char charset = '\0'; /* character set modifier */
9632 unsigned int x_mod_count = 0;
9634 PERL_ARGS_ASSERT_SCAN_PAT;
9636 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9638 Perl_croak(aTHX_ "Search pattern not terminated");
9640 pm = (PMOP*)newPMOP(type, 0);
9641 if (PL_multi_open == '?') {
9642 /* This is the only point in the code that sets PMf_ONCE: */
9643 pm->op_pmflags |= PMf_ONCE;
9645 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9646 allows us to restrict the list needed by reset to just the ??
9648 assert(type != OP_TRANS);
9650 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9653 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9656 elements = mg->mg_len / sizeof(PMOP**);
9657 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9658 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9659 mg->mg_len = elements * sizeof(PMOP**);
9660 PmopSTASH_set(pm,PL_curstash);
9664 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9665 * anon CV. False positives like qr/[(?{]/ are harmless */
9667 if (type == OP_QR) {
9669 char *e, *p = SvPV(PL_lex_stuff, len);
9671 for (; p < e; p++) {
9672 if (p[0] == '(' && p[1] == '?'
9673 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9675 pm->op_pmflags |= PMf_HAS_CV;
9679 pm->op_pmflags |= PMf_IS_QR;
9682 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9683 &s, &charset, &x_mod_count))
9685 /* issue a warning if /c is specified,but /g is not */
9686 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9688 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9689 "Use of /c modifier is meaningless without /g" );
9692 PL_lex_op = (OP*)pm;
9693 pl_yylval.ival = OP_MATCH;
9698 S_scan_subst(pTHX_ char *start)
9704 line_t linediff = 0;
9706 char charset = '\0'; /* character set modifier */
9707 unsigned int x_mod_count = 0;
9710 PERL_ARGS_ASSERT_SCAN_SUBST;
9712 pl_yylval.ival = OP_NULL;
9714 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9717 Perl_croak(aTHX_ "Substitution pattern not terminated");
9721 first_start = PL_multi_start;
9722 first_line = CopLINE(PL_curcop);
9723 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9725 SvREFCNT_dec_NN(PL_lex_stuff);
9726 PL_lex_stuff = NULL;
9727 Perl_croak(aTHX_ "Substitution replacement not terminated");
9729 PL_multi_start = first_start; /* so whole substitution is taken together */
9731 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9735 if (*s == EXEC_PAT_MOD) {
9739 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9740 &s, &charset, &x_mod_count))
9746 if ((pm->op_pmflags & PMf_CONTINUE)) {
9747 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9751 SV * const repl = newSVpvs("");
9754 pm->op_pmflags |= PMf_EVAL;
9755 for (; es > 1; es--) {
9756 sv_catpvs(repl, "eval ");
9758 sv_catpvs(repl, "do {");
9759 sv_catsv(repl, PL_parser->lex_sub_repl);
9760 sv_catpvs(repl, "}");
9761 SvREFCNT_dec(PL_parser->lex_sub_repl);
9762 PL_parser->lex_sub_repl = repl;
9766 linediff = CopLINE(PL_curcop) - first_line;
9768 CopLINE_set(PL_curcop, first_line);
9770 if (linediff || es) {
9771 /* the IVX field indicates that the replacement string is a s///e;
9772 * the NVX field indicates how many src code lines the replacement
9774 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9775 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
9776 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9780 PL_lex_op = (OP*)pm;
9781 pl_yylval.ival = OP_SUBST;
9786 S_scan_trans(pTHX_ char *start)
9793 bool nondestruct = 0;
9796 PERL_ARGS_ASSERT_SCAN_TRANS;
9798 pl_yylval.ival = OP_NULL;
9800 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9802 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9806 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9808 SvREFCNT_dec_NN(PL_lex_stuff);
9809 PL_lex_stuff = NULL;
9810 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9813 complement = del = squash = 0;
9817 complement = OPpTRANS_COMPLEMENT;
9820 del = OPpTRANS_DELETE;
9823 squash = OPpTRANS_SQUASH;
9835 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9836 o->op_private &= ~OPpTRANS_ALL;
9837 o->op_private |= del|squash|complement|
9838 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9839 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9842 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9849 Takes a pointer to the first < in <<FOO.
9850 Returns a pointer to the byte following <<FOO.
9852 This function scans a heredoc, which involves different methods
9853 depending on whether we are in a string eval, quoted construct, etc.
9854 This is because PL_linestr could containing a single line of input, or
9855 a whole string being evalled, or the contents of the current quote-
9858 The two basic methods are:
9859 - Steal lines from the input stream
9860 - Scan the heredoc in PL_linestr and remove it therefrom
9862 In a file scope or filtered eval, the first method is used; in a
9863 string eval, the second.
9865 In a quote-like operator, we have to choose between the two,
9866 depending on where we can find a newline. We peek into outer lex-
9867 ing scopes until we find one with a newline in it. If we reach the
9868 outermost lexing scope and it is a file, we use the stream method.
9869 Otherwise it is treated as an eval.
9873 S_scan_heredoc(pTHX_ char *s)
9875 I32 op_type = OP_SCALAR;
9884 bool indented = FALSE;
9885 const bool infile = PL_rsfp || PL_parser->filtered;
9886 const line_t origline = CopLINE(PL_curcop);
9887 LEXSHARED *shared = PL_parser->lex_shared;
9889 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9892 d = PL_tokenbuf + 1;
9893 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9894 *PL_tokenbuf = '\n';
9900 while (SPACE_OR_TAB(*peek))
9902 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9905 s = delimcpy(d, e, s, PL_bufend, term, &len);
9907 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9913 /* <<\FOO is equivalent to <<'FOO' */
9917 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9918 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
9920 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
9921 peek += UTF ? UTF8SKIP(peek) : 1;
9923 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9924 Copy(s, d, len, char);
9928 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9929 Perl_croak(aTHX_ "Delimiter for here document is too long");
9932 len = d - PL_tokenbuf;
9934 #ifndef PERL_STRICT_CR
9935 d = strchr(s, '\r');
9937 char * const olds = s;
9939 while (s < PL_bufend) {
9945 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9954 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9959 tmpstr = newSV_type(SVt_PVIV);
9963 SvIV_set(tmpstr, -1);
9965 else if (term == '`') {
9966 op_type = OP_BACKTICK;
9967 SvIV_set(tmpstr, '\\');
9970 PL_multi_start = origline + 1 + PL_parser->herelines;
9971 PL_multi_open = PL_multi_close = '<';
9972 /* inside a string eval or quote-like operator */
9973 if (!infile || PL_lex_inwhat) {
9976 char * const olds = s;
9977 PERL_CONTEXT * const cx = CX_CUR();
9978 /* These two fields are not set until an inner lexing scope is
9979 entered. But we need them set here. */
9980 shared->ls_bufptr = s;
9981 shared->ls_linestr = PL_linestr;
9983 /* Look for a newline. If the current buffer does not have one,
9984 peek into the line buffer of the parent lexing scope, going
9985 up as many levels as necessary to find one with a newline
9988 while (!(s = (char *)memchr(
9989 (void *)shared->ls_bufptr, '\n',
9990 SvEND(shared->ls_linestr)-shared->ls_bufptr
9992 shared = shared->ls_prev;
9993 /* shared is only null if we have gone beyond the outermost
9994 lexing scope. In a file, we will have broken out of the
9995 loop in the previous iteration. In an eval, the string buf-
9996 fer ends with "\n;", so the while condition above will have
9997 evaluated to false. So shared can never be null. Or so you
9998 might think. Odd syntax errors like s;@{<<; can gobble up
9999 the implicit semicolon at the end of a flie, causing the
10000 file handle to be closed even when we are not in a string
10001 eval. So shared may be null in that case.
10002 (Closing '}' here to balance the earlier open brace for
10003 editors that look for matched pairs.) */
10004 if (UNLIKELY(!shared))
10006 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10007 most lexing scope. In a file, shared->ls_linestr at that
10008 level is just one line, so there is no body to steal. */
10009 if (infile && !shared->ls_prev) {
10014 else { /* eval or we've already hit EOF */
10015 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10019 linestr = shared->ls_linestr;
10020 bufend = SvEND(linestr);
10025 while (s < bufend - len + 1) {
10027 ++PL_parser->herelines;
10029 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10033 /* Only valid if it's preceded by whitespace only */
10034 while (backup != myolds && --backup >= myolds) {
10035 if (! SPACE_OR_TAB(*backup)) {
10042 /* No whitespace or all! */
10043 if (backup == s || *backup == '\n') {
10044 Newxz(indent, indent_len + 1, char);
10045 memcpy(indent, backup + 1, indent_len);
10046 s--; /* before our delimiter */
10047 PL_parser->herelines--; /* this line doesn't count */
10053 while (s < bufend - len + 1
10054 && memNE(s,PL_tokenbuf,len) )
10057 ++PL_parser->herelines;
10061 if (s >= bufend - len + 1) {
10064 sv_setpvn(tmpstr,d+1,s-d);
10066 /* the preceding stmt passes a newline */
10067 PL_parser->herelines++;
10069 /* s now points to the newline after the heredoc terminator.
10070 d points to the newline before the body of the heredoc.
10073 /* We are going to modify linestr in place here, so set
10074 aside copies of the string if necessary for re-evals or
10076 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10077 check shared->re_eval_str. */
10078 if (shared->re_eval_start || shared->re_eval_str) {
10079 /* Set aside the rest of the regexp */
10080 if (!shared->re_eval_str)
10081 shared->re_eval_str =
10082 newSVpvn(shared->re_eval_start,
10083 bufend - shared->re_eval_start);
10084 shared->re_eval_start -= s-d;
10086 if (cxstack_ix >= 0
10087 && CxTYPE(cx) == CXt_EVAL
10088 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10089 && cx->blk_eval.cur_text == linestr)
10091 cx->blk_eval.cur_text = newSVsv(linestr);
10092 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10094 /* Copy everything from s onwards back to d. */
10095 Move(s,d,bufend-s + 1,char);
10096 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10097 /* Setting PL_bufend only applies when we have not dug deeper
10098 into other scopes, because sublex_done sets PL_bufend to
10099 SvEND(PL_linestr). */
10100 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10106 char *oldbufptr_save;
10107 char *oldoldbufptr_save;
10109 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10110 term = PL_tokenbuf[1];
10112 linestr_save = PL_linestr; /* must restore this afterwards */
10113 d = s; /* and this */
10114 oldbufptr_save = PL_oldbufptr;
10115 oldoldbufptr_save = PL_oldoldbufptr;
10116 PL_linestr = newSVpvs("");
10117 PL_bufend = SvPVX(PL_linestr);
10119 PL_bufptr = PL_bufend;
10120 CopLINE_set(PL_curcop,
10121 origline + 1 + PL_parser->herelines);
10122 if (!lex_next_chunk(LEX_NO_TERM)
10123 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10124 /* Simply freeing linestr_save might seem simpler here, as it
10125 does not matter what PL_linestr points to, since we are
10126 about to croak; but in a quote-like op, linestr_save
10127 will have been prospectively freed already, via
10128 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10129 restore PL_linestr. */
10130 SvREFCNT_dec_NN(PL_linestr);
10131 PL_linestr = linestr_save;
10132 PL_oldbufptr = oldbufptr_save;
10133 PL_oldoldbufptr = oldoldbufptr_save;
10136 CopLINE_set(PL_curcop, origline);
10137 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10138 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10139 /* ^That should be enough to avoid this needing to grow: */
10140 sv_catpvs(PL_linestr, "\n\0");
10141 assert(s == SvPVX(PL_linestr));
10142 PL_bufend = SvEND(PL_linestr);
10145 PL_parser->herelines++;
10146 PL_last_lop = PL_last_uni = NULL;
10147 #ifndef PERL_STRICT_CR
10148 if (PL_bufend - PL_linestart >= 2) {
10149 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10150 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10152 PL_bufend[-2] = '\n';
10154 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10156 else if (PL_bufend[-1] == '\r')
10157 PL_bufend[-1] = '\n';
10159 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10160 PL_bufend[-1] = '\n';
10162 if (indented && (PL_bufend-s) >= len) {
10163 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10166 char *backup = found;
10169 /* Only valid if it's preceded by whitespace only */
10170 while (backup != s && --backup >= s) {
10171 if (! SPACE_OR_TAB(*backup)) {
10177 /* All whitespace or none! */
10178 if (backup == found || SPACE_OR_TAB(*backup)) {
10179 Newxz(indent, indent_len + 1, char);
10180 memcpy(indent, backup, indent_len);
10181 SvREFCNT_dec(PL_linestr);
10182 PL_linestr = linestr_save;
10183 PL_linestart = SvPVX(linestr_save);
10184 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10185 PL_oldbufptr = oldbufptr_save;
10186 PL_oldoldbufptr = oldoldbufptr_save;
10192 /* Didn't find it */
10193 sv_catsv(tmpstr,PL_linestr);
10195 if (*s == term && PL_bufend-s >= len
10196 && memEQ(s,PL_tokenbuf + 1,len))
10198 SvREFCNT_dec(PL_linestr);
10199 PL_linestr = linestr_save;
10200 PL_linestart = SvPVX(linestr_save);
10201 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10202 PL_oldbufptr = oldbufptr_save;
10203 PL_oldoldbufptr = oldoldbufptr_save;
10207 sv_catsv(tmpstr,PL_linestr);
10212 PL_multi_end = origline + PL_parser->herelines;
10213 if (indented && indent) {
10214 STRLEN linecount = 1;
10215 STRLEN herelen = SvCUR(tmpstr);
10216 char *ss = SvPVX(tmpstr);
10217 char *se = ss + herelen;
10218 SV *newstr = newSV(herelen+1);
10221 /* Trim leading whitespace */
10223 /* newline only? Copy and move on */
10225 sv_catpv(newstr,"\n");
10229 /* Found our indentation? Strip it */
10230 } else if (se - ss >= indent_len
10231 && memEQ(ss, indent, indent_len))
10237 while ((ss + le) < se && *(ss + le) != '\n')
10240 sv_catpvn(newstr, ss, le);
10244 /* Line doesn't begin with our indentation? Croak */
10247 "Indentation on line %d of here-doc doesn't match delimiter",
10252 /* avoid sv_setsv() as we dont wan't to COW here */
10253 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10255 SvREFCNT_dec_NN(newstr);
10257 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10258 SvPV_shrink_to_cur(tmpstr);
10261 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10264 PL_lex_stuff = tmpstr;
10265 pl_yylval.ival = op_type;
10269 SvREFCNT_dec(tmpstr);
10270 CopLINE_set(PL_curcop, origline);
10271 missingterm(PL_tokenbuf + 1);
10274 /* scan_inputsymbol
10275 takes: position of first '<' in input buffer
10276 returns: position of first char following the matching '>' in
10278 side-effects: pl_yylval and lex_op are set.
10283 <<>> read from ARGV without magic open
10284 <FH> read from filehandle
10285 <pkg::FH> read from package qualified filehandle
10286 <pkg'FH> read from package qualified filehandle
10287 <$fh> read from filehandle in $fh
10288 <*.h> filename glob
10293 S_scan_inputsymbol(pTHX_ char *start)
10295 char *s = start; /* current position in buffer */
10298 bool nomagicopen = FALSE;
10299 char *d = PL_tokenbuf; /* start of temp holding space */
10300 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10302 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10304 end = strchr(s, '\n');
10307 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10308 nomagicopen = TRUE;
10314 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10316 /* die if we didn't have space for the contents of the <>,
10317 or if it didn't end, or if we see a newline
10320 if (len >= (I32)sizeof PL_tokenbuf)
10321 Perl_croak(aTHX_ "Excessively long <> operator");
10323 Perl_croak(aTHX_ "Unterminated <> operator");
10328 Remember, only scalar variables are interpreted as filehandles by
10329 this code. Anything more complex (e.g., <$fh{$num}>) will be
10330 treated as a glob() call.
10331 This code makes use of the fact that except for the $ at the front,
10332 a scalar variable and a filehandle look the same.
10334 if (*d == '$' && d[1]) d++;
10336 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10337 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10338 d += UTF ? UTF8SKIP(d) : 1;
10341 /* If we've tried to read what we allow filehandles to look like, and
10342 there's still text left, then it must be a glob() and not a getline.
10343 Use scan_str to pull out the stuff between the <> and treat it
10344 as nothing more than a string.
10347 if (d - PL_tokenbuf != len) {
10348 pl_yylval.ival = OP_GLOB;
10349 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10351 Perl_croak(aTHX_ "Glob not terminated");
10355 bool readline_overriden = FALSE;
10357 /* we're in a filehandle read situation */
10360 /* turn <> into <ARGV> */
10362 Copy("ARGV",d,5,char);
10364 /* Check whether readline() is overriden */
10365 if ((gv_readline = gv_override("readline",8)))
10366 readline_overriden = TRUE;
10368 /* if <$fh>, create the ops to turn the variable into a
10372 /* try to find it in the pad for this block, otherwise find
10373 add symbol table ops
10375 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10376 if (tmp != NOT_IN_PAD) {
10377 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10378 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10379 HEK * const stashname = HvNAME_HEK(stash);
10380 SV * const sym = sv_2mortal(newSVhek(stashname));
10381 sv_catpvs(sym, "::");
10382 sv_catpv(sym, d+1);
10387 OP * const o = newOP(OP_PADSV, 0);
10389 PL_lex_op = readline_overriden
10390 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10391 op_append_elem(OP_LIST, o,
10392 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10393 : newUNOP(OP_READLINE, 0, o);
10401 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10403 PL_lex_op = readline_overriden
10404 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10405 op_append_elem(OP_LIST,
10406 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10407 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10408 : newUNOP(OP_READLINE, 0,
10409 newUNOP(OP_RV2SV, 0,
10410 newGVOP(OP_GV, 0, gv)));
10412 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10413 pl_yylval.ival = OP_NULL;
10416 /* If it's none of the above, it must be a literal filehandle
10417 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10419 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10420 PL_lex_op = readline_overriden
10421 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10422 op_append_elem(OP_LIST,
10423 newGVOP(OP_GV, 0, gv),
10424 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10425 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10426 pl_yylval.ival = OP_NULL;
10436 start position in buffer
10437 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10438 only if they are of the open/close form
10439 keep_delims preserve the delimiters around the string
10440 re_reparse compiling a run-time /(?{})/:
10441 collapse // to /, and skip encoding src
10442 delimp if non-null, this is set to the position of
10443 the closing delimiter, or just after it if
10444 the closing and opening delimiters differ
10445 (i.e., the opening delimiter of a substitu-
10447 returns: position to continue reading from buffer
10448 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10449 updates the read buffer.
10451 This subroutine pulls a string out of the input. It is called for:
10452 q single quotes q(literal text)
10453 ' single quotes 'literal text'
10454 qq double quotes qq(interpolate $here please)
10455 " double quotes "interpolate $here please"
10456 qx backticks qx(/bin/ls -l)
10457 ` backticks `/bin/ls -l`
10458 qw quote words @EXPORT_OK = qw( func() $spam )
10459 m// regexp match m/this/
10460 s/// regexp substitute s/this/that/
10461 tr/// string transliterate tr/this/that/
10462 y/// string transliterate y/this/that/
10463 ($*@) sub prototypes sub foo ($)
10464 (stuff) sub attr parameters sub foo : attr(stuff)
10465 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10467 In most of these cases (all but <>, patterns and transliterate)
10468 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10469 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10470 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10473 It skips whitespace before the string starts, and treats the first
10474 character as the delimiter. If the delimiter is one of ([{< then
10475 the corresponding "close" character )]}> is used as the closing
10476 delimiter. It allows quoting of delimiters, and if the string has
10477 balanced delimiters ([{<>}]) it allows nesting.
10479 On success, the SV with the resulting string is put into lex_stuff or,
10480 if that is already non-NULL, into lex_repl. The second case occurs only
10481 when parsing the RHS of the special constructs s/// and tr/// (y///).
10482 For convenience, the terminating delimiter character is stuffed into
10487 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10491 SV *sv; /* scalar value: string */
10492 const char *tmps; /* temp string, used for delimiter matching */
10493 char *s = start; /* current position in the buffer */
10494 char term; /* terminating character */
10495 char *to; /* current position in the sv's data */
10496 I32 brackets = 1; /* bracket nesting level */
10497 bool has_utf8 = FALSE; /* is there any utf8 content? */
10498 IV termcode; /* terminating char. code */
10499 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10500 STRLEN termlen; /* length of terminating string */
10503 /* The delimiters that have a mirror-image closing one */
10504 const char * opening_delims = "([{<";
10505 const char * closing_delims = ")]}>";
10507 const char * non_grapheme_msg = "Use of unassigned code point or"
10508 " non-standalone grapheme for a delimiter"
10509 " will be a fatal error starting in Perl"
10511 /* The only non-UTF character that isn't a stand alone grapheme is
10512 * white-space, hence can't be a delimiter. So can skip for non-UTF-8 */
10513 bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED);
10515 PERL_ARGS_ASSERT_SCAN_STR;
10517 /* skip space before the delimiter */
10522 /* mark where we are, in case we need to report errors */
10525 /* after skipping whitespace, the next character is the terminator */
10527 if (!UTF || UTF8_IS_INVARIANT(term)) {
10528 termcode = termstr[0] = term;
10532 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10533 if (check_grapheme) {
10534 if ( UNLIKELY(UNICODE_IS_SUPER(termcode))
10535 || UNLIKELY(UNICODE_IS_NONCHAR(termcode)))
10537 /* These are considered graphemes, and since the ending
10538 * delimiter will be the same, we don't have to check the other
10540 check_grapheme = FALSE;
10542 else if (UNLIKELY(! _is_grapheme((U8 *) start,
10547 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "%s", non_grapheme_msg);
10549 /* Don't have to check the other end, as have already warned at
10551 check_grapheme = FALSE;
10555 Copy(s, termstr, termlen, U8);
10558 /* mark where we are */
10559 PL_multi_start = CopLINE(PL_curcop);
10560 PL_multi_open = termcode;
10561 herelines = PL_parser->herelines;
10563 /* If the delimiter has a mirror-image closing one, get it */
10564 if (term && (tmps = strchr(opening_delims, term))) {
10565 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10568 PL_multi_close = termcode;
10570 if (PL_multi_open == PL_multi_close) {
10571 keep_bracketed_quoted = FALSE;
10574 /* create a new SV to hold the contents. 79 is the SV's initial length.
10575 What a random number. */
10576 sv = newSV_type(SVt_PVIV);
10578 SvIV_set(sv, termcode);
10579 (void)SvPOK_only(sv); /* validate pointer */
10581 /* move past delimiter and try to read a complete string */
10583 sv_catpvn(sv, s, termlen);
10586 /* extend sv if need be */
10587 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10588 /* set 'to' to the next character in the sv's string */
10589 to = SvPVX(sv)+SvCUR(sv);
10591 /* if open delimiter is the close delimiter read unbridle */
10592 if (PL_multi_open == PL_multi_close) {
10593 for (; s < PL_bufend; s++,to++) {
10594 /* embedded newlines increment the current line number */
10595 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10596 COPLINE_INC_WITH_HERELINES;
10597 /* handle quoted delimiters */
10598 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10599 if (!keep_bracketed_quoted
10601 || (re_reparse && s[1] == '\\'))
10604 else /* any other quotes are simply copied straight through */
10607 /* terminate when run out of buffer (the for() condition), or
10608 have found the terminator */
10609 else if (*s == term) { /* First byte of terminator matches */
10610 if (termlen == 1) /* If is the only byte, are done */
10613 /* If the remainder of the terminator matches, also are
10614 * done, after checking that is a separate grapheme */
10615 if ( s + termlen <= PL_bufend
10616 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10618 if ( check_grapheme
10619 && UNLIKELY(! _is_grapheme((U8 *) start,
10624 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10625 "%s", non_grapheme_msg);
10630 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10638 /* if the terminator isn't the same as the start character (e.g.,
10639 matched brackets), we have to allow more in the quoting, and
10640 be prepared for nested brackets.
10643 /* read until we run out of string, or we find the terminator */
10644 for (; s < PL_bufend; s++,to++) {
10645 /* embedded newlines increment the line count */
10646 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10647 COPLINE_INC_WITH_HERELINES;
10648 /* backslashes can escape the open or closing characters */
10649 if (*s == '\\' && s+1 < PL_bufend) {
10650 if (!keep_bracketed_quoted
10651 && ( ((UV)s[1] == PL_multi_open)
10652 || ((UV)s[1] == PL_multi_close) ))
10659 /* allow nested opens and closes */
10660 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10662 else if ((UV)*s == PL_multi_open)
10664 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10669 /* terminate the copied string and update the sv's end-of-string */
10671 SvCUR_set(sv, to - SvPVX_const(sv));
10674 * this next chunk reads more into the buffer if we're not done yet
10678 break; /* handle case where we are done yet :-) */
10680 #ifndef PERL_STRICT_CR
10681 if (to - SvPVX_const(sv) >= 2) {
10682 if ( (to[-2] == '\r' && to[-1] == '\n')
10683 || (to[-2] == '\n' && to[-1] == '\r'))
10687 SvCUR_set(sv, to - SvPVX_const(sv));
10689 else if (to[-1] == '\r')
10692 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10696 /* if we're out of file, or a read fails, bail and reset the current
10697 line marker so we can report where the unterminated string began
10699 COPLINE_INC_WITH_HERELINES;
10700 PL_bufptr = PL_bufend;
10701 if (!lex_next_chunk(0)) {
10703 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10706 s = start = PL_bufptr;
10709 /* at this point, we have successfully read the delimited string */
10712 sv_catpvn(sv, s, termlen);
10718 PL_multi_end = CopLINE(PL_curcop);
10719 CopLINE_set(PL_curcop, PL_multi_start);
10720 PL_parser->herelines = herelines;
10722 /* if we allocated too much space, give some back */
10723 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10724 SvLEN_set(sv, SvCUR(sv) + 1);
10725 SvPV_renew(sv, SvLEN(sv));
10728 /* decide whether this is the first or second quoted string we've read
10733 PL_parser->lex_sub_repl = sv;
10736 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10742 takes: pointer to position in buffer
10743 returns: pointer to new position in buffer
10744 side-effects: builds ops for the constant in pl_yylval.op
10746 Read a number in any of the formats that Perl accepts:
10748 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10749 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10750 0b[01](_?[01])* binary integers
10751 0[0-7](_?[0-7])* octal integers
10752 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10753 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10755 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10758 If it reads a number without a decimal point or an exponent, it will
10759 try converting the number to an integer and see if it can do so
10760 without loss of precision.
10764 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10766 const char *s = start; /* current position in buffer */
10767 char *d; /* destination in temp buffer */
10768 char *e; /* end of temp buffer */
10769 NV nv; /* number read, as a double */
10770 SV *sv = NULL; /* place to put the converted number */
10771 bool floatit; /* boolean: int or float? */
10772 const char *lastub = NULL; /* position of last underbar */
10773 static const char* const number_too_long = "Number too long";
10774 bool warned_about_underscore = 0;
10775 #define WARN_ABOUT_UNDERSCORE() \
10777 if (!warned_about_underscore) { \
10778 warned_about_underscore = 1; \
10779 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10780 "Misplaced _ in number"); \
10783 /* Hexadecimal floating point.
10785 * In many places (where we have quads and NV is IEEE 754 double)
10786 * we can fit the mantissa bits of a NV into an unsigned quad.
10787 * (Note that UVs might not be quads even when we have quads.)
10788 * This will not work everywhere, though (either no quads, or
10789 * using long doubles), in which case we have to resort to NV,
10790 * which will probably mean horrible loss of precision due to
10791 * multiple fp operations. */
10792 bool hexfp = FALSE;
10793 int total_bits = 0;
10794 int significant_bits = 0;
10795 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10796 # define HEXFP_UQUAD
10797 Uquad_t hexfp_uquad = 0;
10798 int hexfp_frac_bits = 0;
10803 NV hexfp_mult = 1.0;
10804 UV high_non_zero = 0; /* highest digit */
10805 int non_zero_integer_digits = 0;
10807 PERL_ARGS_ASSERT_SCAN_NUM;
10809 /* We use the first character to decide what type of number this is */
10813 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10815 /* if it starts with a 0, it could be an octal number, a decimal in
10816 0.13 disguise, or a hexadecimal number, or a binary number. */
10820 u holds the "number so far"
10821 shift the power of 2 of the base
10822 (hex == 4, octal == 3, binary == 1)
10823 overflowed was the number more than we can hold?
10825 Shift is used when we add a digit. It also serves as an "are
10826 we in octal/hex/binary?" indicator to disallow hex characters
10827 when in octal mode.
10832 bool overflowed = FALSE;
10833 bool just_zero = TRUE; /* just plain 0 or binary number? */
10834 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10835 static const char* const bases[5] =
10836 { "", "binary", "", "octal", "hexadecimal" };
10837 static const char* const Bases[5] =
10838 { "", "Binary", "", "Octal", "Hexadecimal" };
10839 static const char* const maxima[5] =
10841 "0b11111111111111111111111111111111",
10845 const char *base, *Base, *max;
10847 /* check for hex */
10848 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10852 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10857 /* check for a decimal in disguise */
10858 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10860 /* so it must be octal */
10867 WARN_ABOUT_UNDERSCORE();
10871 base = bases[shift];
10872 Base = Bases[shift];
10873 max = maxima[shift];
10875 /* read the rest of the number */
10877 /* x is used in the overflow test,
10878 b is the digit we're adding on. */
10883 /* if we don't mention it, we're done */
10887 /* _ are ignored -- but warned about if consecutive */
10889 if (lastub && s == lastub + 1)
10890 WARN_ABOUT_UNDERSCORE();
10894 /* 8 and 9 are not octal */
10895 case '8': case '9':
10897 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10901 case '2': case '3': case '4':
10902 case '5': case '6': case '7':
10904 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10907 case '0': case '1':
10908 b = *s++ & 15; /* ASCII digit -> value of digit */
10912 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10913 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10914 /* make sure they said 0x */
10917 b = (*s++ & 7) + 9;
10919 /* Prepare to put the digit we have onto the end
10920 of the number so far. We check for overflows.
10926 x = u << shift; /* make room for the digit */
10928 total_bits += shift;
10930 if ((x >> shift) != u
10931 && !(PL_hints & HINT_NEW_BINARY)) {
10934 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10935 "Integer overflow in %s number",
10938 u = x | b; /* add the digit to the end */
10941 n *= nvshift[shift];
10942 /* If an NV has not enough bits in its
10943 * mantissa to represent an UV this summing of
10944 * small low-order numbers is a waste of time
10945 * (because the NV cannot preserve the
10946 * low-order bits anyway): we could just
10947 * remember when did we overflow and in the
10948 * end just multiply n by the right
10953 if (high_non_zero == 0 && b > 0)
10957 non_zero_integer_digits++;
10959 /* this could be hexfp, but peek ahead
10960 * to avoid matching ".." */
10961 if (UNLIKELY(HEXFP_PEEK(s))) {
10969 /* if we get here, we had success: make a scalar value from
10974 /* final misplaced underbar check */
10976 WARN_ABOUT_UNDERSCORE();
10978 if (UNLIKELY(HEXFP_PEEK(s))) {
10979 /* Do sloppy (on the underbars) but quick detection
10980 * (and value construction) for hexfp, the decimal
10981 * detection will shortly be more thorough with the
10982 * underbar checks. */
10984 significant_bits = non_zero_integer_digits * shift;
10987 #else /* HEXFP_NV */
10990 /* Ignore the leading zero bits of
10991 * the high (first) non-zero digit. */
10992 if (high_non_zero) {
10993 if (high_non_zero < 0x8)
10994 significant_bits--;
10995 if (high_non_zero < 0x4)
10996 significant_bits--;
10997 if (high_non_zero < 0x2)
10998 significant_bits--;
11005 bool accumulate = TRUE;
11006 for (h++; (isXDIGIT(*h) || *h == '_'); h++) {
11007 if (isXDIGIT(*h)) {
11008 U8 b = XDIGIT_VALUE(*h);
11009 significant_bits += shift;
11012 if (significant_bits < NV_MANT_DIG) {
11013 /* We are in the long "run" of xdigits,
11014 * accumulate the full four bits. */
11015 hexfp_uquad <<= shift;
11017 hexfp_frac_bits += shift;
11019 /* We are at a hexdigit either at,
11020 * or straddling, the edge of mantissa.
11021 * We will try grabbing as many as
11022 * possible bits. */
11024 significant_bits - NV_MANT_DIG;
11027 hexfp_uquad <<= tail;
11028 hexfp_uquad |= b >> (shift - tail);
11029 hexfp_frac_bits += tail;
11031 /* Ignore the trailing zero bits
11032 * of the last non-zero xdigit.
11034 * The assumption here is that if
11035 * one has input of e.g. the xdigit
11036 * eight (0x8), there is only one
11037 * bit being input, not the full
11038 * four bits. Conversely, if one
11039 * specifies a zero xdigit, the
11040 * assumption is that one really
11041 * wants all those bits to be zero. */
11043 if ((b & 0x1) == 0x0) {
11044 significant_bits--;
11045 if ((b & 0x2) == 0x0) {
11046 significant_bits--;
11047 if ((b & 0x4) == 0x0) {
11048 significant_bits--;
11054 accumulate = FALSE;
11057 /* Keep skipping the xdigits, and
11058 * accumulating the significant bits,
11059 * but do not shift the uquad
11060 * (which would catastrophically drop
11061 * high-order bits) or accumulate the
11062 * xdigits anymore. */
11064 #else /* HEXFP_NV */
11068 hexfp_nv += b * nv_mult;
11070 accumulate = FALSE;
11074 if (significant_bits >= NV_MANT_DIG)
11075 accumulate = FALSE;
11079 if ((total_bits > 0 || significant_bits > 0) &&
11080 isALPHA_FOLD_EQ(*h, 'p')) {
11081 bool negexp = FALSE;
11085 else if (*h == '-') {
11091 while (isDIGIT(*h) || *h == '_') {
11094 hexfp_exp += *h - '0';
11097 && -hexfp_exp < NV_MIN_EXP - 1) {
11098 /* NOTE: this means that the exponent
11099 * underflow warning happens for
11100 * the IEEE 754 subnormals (denormals),
11101 * because DBL_MIN_EXP etc are the lowest
11102 * possible binary (or, rather, DBL_RADIX-base)
11103 * exponent for normals, not subnormals.
11105 * This may or may not be a good thing. */
11106 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11107 "Hexadecimal float: exponent underflow");
11113 && hexfp_exp > NV_MAX_EXP - 1) {
11114 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11115 "Hexadecimal float: exponent overflow");
11123 hexfp_exp = -hexfp_exp;
11125 hexfp_exp -= hexfp_frac_bits;
11127 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11135 if (n > 4294967295.0)
11136 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11137 "%s number > %s non-portable",
11143 if (u > 0xffffffff)
11144 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11145 "%s number > %s non-portable",
11150 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11151 sv = new_constant(start, s - start, "integer",
11152 sv, NULL, NULL, 0);
11153 else if (PL_hints & HINT_NEW_BINARY)
11154 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11159 handle decimal numbers.
11160 we're also sent here when we read a 0 as the first digit
11162 case '1': case '2': case '3': case '4': case '5':
11163 case '6': case '7': case '8': case '9': case '.':
11166 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11175 /* read next group of digits and _ and copy into d */
11178 || UNLIKELY(hexfp && isXDIGIT(*s)))
11180 /* skip underscores, checking for misplaced ones
11184 if (lastub && s == lastub + 1)
11185 WARN_ABOUT_UNDERSCORE();
11189 /* check for end of fixed-length buffer */
11191 Perl_croak(aTHX_ "%s", number_too_long);
11192 /* if we're ok, copy the character */
11197 /* final misplaced underbar check */
11198 if (lastub && s == lastub + 1)
11199 WARN_ABOUT_UNDERSCORE();
11201 /* read a decimal portion if there is one. avoid
11202 3..5 being interpreted as the number 3. followed
11205 if (*s == '.' && s[1] != '.') {
11210 WARN_ABOUT_UNDERSCORE();
11214 /* copy, ignoring underbars, until we run out of digits.
11218 || UNLIKELY(hexfp && isXDIGIT(*s));
11221 /* fixed length buffer check */
11223 Perl_croak(aTHX_ "%s", number_too_long);
11225 if (lastub && s == lastub + 1)
11226 WARN_ABOUT_UNDERSCORE();
11232 /* fractional part ending in underbar? */
11234 WARN_ABOUT_UNDERSCORE();
11235 if (*s == '.' && isDIGIT(s[1])) {
11236 /* oops, it's really a v-string, but without the "v" */
11242 /* read exponent part, if present */
11243 if ((isALPHA_FOLD_EQ(*s, 'e')
11244 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11245 && strchr("+-0123456789_", s[1]))
11247 int exp_digits = 0;
11248 const char *save_s = s;
11251 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11252 ditto for p (hexfloats) */
11253 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11254 /* At least some Mach atof()s don't grok 'E' */
11257 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11264 /* stray preinitial _ */
11266 WARN_ABOUT_UNDERSCORE();
11270 /* allow positive or negative exponent */
11271 if (*s == '+' || *s == '-')
11274 /* stray initial _ */
11276 WARN_ABOUT_UNDERSCORE();
11280 /* read digits of exponent */
11281 while (isDIGIT(*s) || *s == '_') {
11285 Perl_croak(aTHX_ "%s", number_too_long);
11289 if (((lastub && s == lastub + 1)
11290 || (!isDIGIT(s[1]) && s[1] != '_')))
11291 WARN_ABOUT_UNDERSCORE();
11297 /* no exponent digits, the [eEpP] could be for something else,
11298 * though in practice we don't get here for p since that's preparsed
11299 * earlier, and results in only the 0xX being consumed, so behave similarly
11300 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11313 We try to do an integer conversion first if no characters
11314 indicating "float" have been found.
11319 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11321 if (flags == IS_NUMBER_IN_UV) {
11323 sv = newSViv(uv); /* Prefer IVs over UVs. */
11326 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11327 if (uv <= (UV) IV_MIN)
11328 sv = newSViv(-(IV)uv);
11335 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
11336 /* terminate the string */
11338 if (UNLIKELY(hexfp)) {
11339 # ifdef NV_MANT_DIG
11340 if (significant_bits > NV_MANT_DIG)
11341 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11342 "Hexadecimal float: mantissa overflow");
11345 nv = hexfp_uquad * hexfp_mult;
11346 #else /* HEXFP_NV */
11347 nv = hexfp_nv * hexfp_mult;
11350 nv = Atof(PL_tokenbuf);
11352 RESTORE_LC_NUMERIC_UNDERLYING();
11357 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11358 const char *const key = floatit ? "float" : "integer";
11359 const STRLEN keylen = floatit ? 5 : 7;
11360 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11361 key, keylen, sv, NULL, NULL, 0);
11365 /* if it starts with a v, it could be a v-string */
11368 sv = newSV(5); /* preallocate storage space */
11369 ENTER_with_name("scan_vstring");
11371 s = scan_vstring(s, PL_bufend, sv);
11372 SvREFCNT_inc_simple_void_NN(sv);
11373 LEAVE_with_name("scan_vstring");
11377 /* make the op for the constant and return */
11380 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11382 lvalp->opval = NULL;
11388 S_scan_formline(pTHX_ char *s)
11390 SV * const stuff = newSVpvs("");
11391 bool needargs = FALSE;
11392 bool eofmt = FALSE;
11394 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11396 while (!needargs) {
11400 #ifdef PERL_STRICT_CR
11401 while (SPACE_OR_TAB(*t))
11404 while (SPACE_OR_TAB(*t) || *t == '\r')
11407 if (*t == '\n' || t == PL_bufend) {
11412 eol = (char *) memchr(s,'\n',PL_bufend-s);
11417 for (t = s; t < eol; t++) {
11418 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11420 goto enough; /* ~~ must be first line in formline */
11422 if (*t == '@' || *t == '^')
11426 sv_catpvn(stuff, s, eol-s);
11427 #ifndef PERL_STRICT_CR
11428 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11429 char *end = SvPVX(stuff) + SvCUR(stuff);
11432 SvCUR_set(stuff, SvCUR(stuff) - 1);
11440 if ((PL_rsfp || PL_parser->filtered)
11441 && PL_parser->form_lex_state == LEX_NORMAL) {
11443 PL_bufptr = PL_bufend;
11444 COPLINE_INC_WITH_HERELINES;
11445 got_some = lex_next_chunk(0);
11446 CopLINE_dec(PL_curcop);
11454 if (!SvCUR(stuff) || needargs)
11455 PL_lex_state = PL_parser->form_lex_state;
11456 if (SvCUR(stuff)) {
11457 PL_expect = XSTATE;
11459 const char *s2 = s;
11460 while (isSPACE(*s2) && *s2 != '\n')
11463 PL_expect = XTERMBLOCK;
11464 NEXTVAL_NEXTTOKE.ival = 0;
11467 NEXTVAL_NEXTTOKE.ival = 0;
11468 force_next(FORMLBRACK);
11471 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11474 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11478 SvREFCNT_dec(stuff);
11480 PL_lex_formbrack = 0;
11486 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11488 const I32 oldsavestack_ix = PL_savestack_ix;
11489 CV* const outsidecv = PL_compcv;
11491 SAVEI32(PL_subline);
11492 save_item(PL_subname);
11493 SAVESPTR(PL_compcv);
11495 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11496 CvFLAGS(PL_compcv) |= flags;
11498 PL_subline = CopLINE(PL_curcop);
11499 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11500 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11501 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11502 if (outsidecv && CvPADLIST(outsidecv))
11503 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11505 return oldsavestack_ix;
11509 S_yywarn(pTHX_ const char *const s, U32 flags)
11511 PERL_ARGS_ASSERT_YYWARN;
11513 PL_in_eval |= EVAL_WARNONLY;
11514 yyerror_pv(s, flags);
11519 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11521 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11524 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11527 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11529 NOT_REACHED; /* NOTREACHED */
11535 /* Called, after at least one error has been found, to abort the parse now,
11536 * instead of trying to forge ahead */
11538 yyerror_pvn(NULL, 0, 0);
11542 Perl_yyerror(pTHX_ const char *const s)
11544 PERL_ARGS_ASSERT_YYERROR;
11545 return yyerror_pvn(s, strlen(s), 0);
11549 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11551 PERL_ARGS_ASSERT_YYERROR_PV;
11552 return yyerror_pvn(s, strlen(s), flags);
11556 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11558 const char *context = NULL;
11561 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11562 int yychar = PL_parser->yychar;
11564 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11565 * apply. If the number of errors found is large enough, it abandons
11566 * parsing. If 's' is NULL, there is no message, and it abandons
11567 * processing unconditionally */
11570 if (!yychar || (yychar == ';' && !PL_rsfp))
11571 sv_catpvs(where_sv, "at EOF");
11572 else if ( PL_oldoldbufptr
11573 && PL_bufptr > PL_oldoldbufptr
11574 && PL_bufptr - PL_oldoldbufptr < 200
11575 && PL_oldoldbufptr != PL_oldbufptr
11576 && PL_oldbufptr != PL_bufptr)
11580 The code below is removed for NetWare because it
11581 abends/crashes on NetWare when the script has error such as
11582 not having the closing quotes like:
11583 if ($var eq "value)
11584 Checking of white spaces is anyway done in NetWare code.
11587 while (isSPACE(*PL_oldoldbufptr))
11590 context = PL_oldoldbufptr;
11591 contlen = PL_bufptr - PL_oldoldbufptr;
11593 else if ( PL_oldbufptr
11594 && PL_bufptr > PL_oldbufptr
11595 && PL_bufptr - PL_oldbufptr < 200
11596 && PL_oldbufptr != PL_bufptr) {
11599 The code below is removed for NetWare because it
11600 abends/crashes on NetWare when the script has error such as
11601 not having the closing quotes like:
11602 if ($var eq "value)
11603 Checking of white spaces is anyway done in NetWare code.
11606 while (isSPACE(*PL_oldbufptr))
11609 context = PL_oldbufptr;
11610 contlen = PL_bufptr - PL_oldbufptr;
11612 else if (yychar > 255)
11613 sv_catpvs(where_sv, "next token ???");
11614 else if (yychar == YYEMPTY) {
11615 if (PL_lex_state == LEX_NORMAL)
11616 sv_catpvs(where_sv, "at end of line");
11617 else if (PL_lex_inpat)
11618 sv_catpvs(where_sv, "within pattern");
11620 sv_catpvs(where_sv, "within string");
11623 sv_catpvs(where_sv, "next char ");
11625 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11626 else if (isPRINT_LC(yychar)) {
11627 const char string = yychar;
11628 sv_catpvn(where_sv, &string, 1);
11631 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11633 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11634 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11635 OutCopFILE(PL_curcop),
11636 (IV)(PL_parser->preambling == NOLINE
11637 ? CopLINE(PL_curcop)
11638 : PL_parser->preambling));
11640 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11641 UTF8fARG(UTF, contlen, context));
11643 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11644 if ( PL_multi_start < PL_multi_end
11645 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11647 Perl_sv_catpvf(aTHX_ msg,
11648 " (Might be a runaway multi-line %c%c string starting on"
11649 " line %" IVdf ")\n",
11650 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11653 if (PL_in_eval & EVAL_WARNONLY) {
11654 PL_in_eval &= ~EVAL_WARNONLY;
11655 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11661 if (s == NULL || PL_error_count >= 10) {
11662 const char * msg = "";
11663 const char * const name = OutCopFILE(PL_curcop);
11666 SV * errsv = ERRSV;
11667 if (SvCUR(errsv)) {
11668 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11673 abort_execution(msg, name);
11676 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11680 PL_in_my_stash = NULL;
11685 S_swallow_bom(pTHX_ U8 *s)
11687 const STRLEN slen = SvCUR(PL_linestr);
11689 PERL_ARGS_ASSERT_SWALLOW_BOM;
11693 if (s[1] == 0xFE) {
11694 /* UTF-16 little-endian? (or UTF-32LE?) */
11695 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11696 /* diag_listed_as: Unsupported script encoding %s */
11697 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11698 #ifndef PERL_NO_UTF16_FILTER
11700 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11703 if (PL_bufend > (char*)s) {
11704 s = add_utf16_textfilter(s, TRUE);
11707 /* diag_listed_as: Unsupported script encoding %s */
11708 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11713 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11714 #ifndef PERL_NO_UTF16_FILTER
11716 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11719 if (PL_bufend > (char *)s) {
11720 s = add_utf16_textfilter(s, FALSE);
11723 /* diag_listed_as: Unsupported script encoding %s */
11724 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11728 case BOM_UTF8_FIRST_BYTE: {
11729 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
11730 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
11732 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11734 s += len + 1; /* UTF-8 */
11741 if (s[2] == 0xFE && s[3] == 0xFF) {
11742 /* UTF-32 big-endian */
11743 /* diag_listed_as: Unsupported script encoding %s */
11744 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11747 else if (s[2] == 0 && s[3] != 0) {
11750 * are a good indicator of UTF-16BE. */
11751 #ifndef PERL_NO_UTF16_FILTER
11753 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11755 s = add_utf16_textfilter(s, FALSE);
11757 /* diag_listed_as: Unsupported script encoding %s */
11758 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11765 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11768 * are a good indicator of UTF-16LE. */
11769 #ifndef PERL_NO_UTF16_FILTER
11771 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11773 s = add_utf16_textfilter(s, TRUE);
11775 /* diag_listed_as: Unsupported script encoding %s */
11776 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11784 #ifndef PERL_NO_UTF16_FILTER
11786 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11788 SV *const filter = FILTER_DATA(idx);
11789 /* We re-use this each time round, throwing the contents away before we
11791 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11792 SV *const utf8_buffer = filter;
11793 IV status = IoPAGE(filter);
11794 const bool reverse = cBOOL(IoLINES(filter));
11797 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11799 /* As we're automatically added, at the lowest level, and hence only called
11800 from this file, we can be sure that we're not called in block mode. Hence
11801 don't bother writing code to deal with block mode. */
11803 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11806 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11808 DEBUG_P(PerlIO_printf(Perl_debug_log,
11809 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11810 FPTR2DPTR(void *, S_utf16_textfilter),
11811 reverse ? 'l' : 'b', idx, maxlen, status,
11812 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11819 /* First, look in our buffer of existing UTF-8 data: */
11820 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11824 } else if (status == 0) {
11826 IoPAGE(filter) = 0;
11827 nl = SvEND(utf8_buffer);
11830 STRLEN got = nl - SvPVX(utf8_buffer);
11831 /* Did we have anything to append? */
11833 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11834 /* Everything else in this code works just fine if SVp_POK isn't
11835 set. This, however, needs it, and we need it to work, else
11836 we loop infinitely because the buffer is never consumed. */
11837 sv_chop(utf8_buffer, nl);
11841 /* OK, not a complete line there, so need to read some more UTF-16.
11842 Read an extra octect if the buffer currently has an odd number. */
11846 if (SvCUR(utf16_buffer) >= 2) {
11847 /* Location of the high octet of the last complete code point.
11848 Gosh, UTF-16 is a pain. All the benefits of variable length,
11849 *coupled* with all the benefits of partial reads and
11851 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11852 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11854 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11858 /* We have the first half of a surrogate. Read more. */
11859 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11862 status = FILTER_READ(idx + 1, utf16_buffer,
11863 160 + (SvCUR(utf16_buffer) & 1));
11864 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11865 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11868 IoPAGE(filter) = status;
11873 chars = SvCUR(utf16_buffer) >> 1;
11874 have = SvCUR(utf8_buffer);
11875 SvGROW(utf8_buffer, have + chars * 3 + 1);
11878 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11879 (U8*)SvPVX_const(utf8_buffer) + have,
11880 chars * 2, &newlen);
11882 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11883 (U8*)SvPVX_const(utf8_buffer) + have,
11884 chars * 2, &newlen);
11886 SvCUR_set(utf8_buffer, have + newlen);
11889 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11890 it's private to us, and utf16_to_utf8{,reversed} take a
11891 (pointer,length) pair, rather than a NUL-terminated string. */
11892 if(SvCUR(utf16_buffer) & 1) {
11893 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11894 SvCUR_set(utf16_buffer, 1);
11896 SvCUR_set(utf16_buffer, 0);
11899 DEBUG_P(PerlIO_printf(Perl_debug_log,
11900 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11902 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11903 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11908 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11910 SV *filter = filter_add(S_utf16_textfilter, NULL);
11912 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11914 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11916 IoLINES(filter) = reversed;
11917 IoPAGE(filter) = 1; /* Not EOF */
11919 /* Sadly, we have to return a valid pointer, come what may, so we have to
11920 ignore any error return from this. */
11921 SvCUR_set(PL_linestr, 0);
11922 if (FILTER_READ(0, PL_linestr, 0)) {
11923 SvUTF8_on(PL_linestr);
11925 SvUTF8_on(PL_linestr);
11927 PL_bufend = SvEND(PL_linestr);
11928 return (U8*)SvPVX(PL_linestr);
11933 Returns a pointer to the next character after the parsed
11934 vstring, as well as updating the passed in sv.
11936 Function must be called like
11938 sv = sv_2mortal(newSV(5));
11939 s = scan_vstring(s,e,sv);
11941 where s and e are the start and end of the string.
11942 The sv should already be large enough to store the vstring
11943 passed in, for performance reasons.
11945 This function may croak if fatal warnings are enabled in the
11946 calling scope, hence the sv_2mortal in the example (to prevent
11947 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11953 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11955 const char *pos = s;
11956 const char *start = s;
11958 PERL_ARGS_ASSERT_SCAN_VSTRING;
11960 if (*pos == 'v') pos++; /* get past 'v' */
11961 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11963 if ( *pos != '.') {
11964 /* this may not be a v-string if followed by => */
11965 const char *next = pos;
11966 while (next < e && isSPACE(*next))
11968 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11969 /* return string not v-string */
11970 sv_setpvn(sv,(char *)s,pos-s);
11971 return (char *)pos;
11975 if (!isALPHA(*pos)) {
11976 U8 tmpbuf[UTF8_MAXBYTES+1];
11979 s++; /* get past 'v' */
11984 /* this is atoi() that tolerates underscores */
11987 const char *end = pos;
11989 while (--end >= s) {
11991 const UV orev = rev;
11992 rev += (*end - '0') * mult;
11995 /* diag_listed_as: Integer overflow in %s number */
11996 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11997 "Integer overflow in decimal number");
12001 /* Append native character for the rev point */
12002 tmpend = uvchr_to_utf8(tmpbuf, rev);
12003 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12004 if (!UVCHR_IS_INVARIANT(rev))
12006 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12012 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12016 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12023 Perl_keyword_plugin_standard(pTHX_
12024 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12026 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12027 PERL_UNUSED_CONTEXT;
12028 PERL_UNUSED_ARG(keyword_ptr);
12029 PERL_UNUSED_ARG(keyword_len);
12030 PERL_UNUSED_ARG(op_ptr);
12031 return KEYWORD_PLUGIN_DECLINE;
12034 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12036 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12038 SAVEI32(PL_lex_brackets);
12039 if (PL_lex_brackets > 100)
12040 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12041 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12042 SAVEI32(PL_lex_allbrackets);
12043 PL_lex_allbrackets = 0;
12044 SAVEI8(PL_lex_fakeeof);
12045 PL_lex_fakeeof = (U8)fakeeof;
12046 if(yyparse(gramtype) && !PL_parser->error_count)
12047 qerror(Perl_mess(aTHX_ "Parse error"));
12050 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12052 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12056 SAVEVPTR(PL_eval_root);
12057 PL_eval_root = NULL;
12058 parse_recdescent(gramtype, fakeeof);
12064 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12066 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12069 if (flags & ~PARSE_OPTIONAL)
12070 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12071 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12072 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12073 if (!PL_parser->error_count)
12074 qerror(Perl_mess(aTHX_ "Parse error"));
12075 exprop = newOP(OP_NULL, 0);
12081 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12083 Parse a Perl arithmetic expression. This may contain operators of precedence
12084 down to the bit shift operators. The expression must be followed (and thus
12085 terminated) either by a comparison or lower-precedence operator or by
12086 something that would normally terminate an expression such as semicolon.
12087 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12088 otherwise it is mandatory. It is up to the caller to ensure that the
12089 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12090 the source of the code to be parsed and the lexical context for the
12093 The op tree representing the expression is returned. If an optional
12094 expression is absent, a null pointer is returned, otherwise the pointer
12097 If an error occurs in parsing or compilation, in most cases a valid op
12098 tree is returned anyway. The error is reflected in the parser state,
12099 normally resulting in a single exception at the top level of parsing
12100 which covers all the compilation errors that occurred. Some compilation
12101 errors, however, will throw an exception immediately.
12107 Perl_parse_arithexpr(pTHX_ U32 flags)
12109 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12113 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12115 Parse a Perl term expression. This may contain operators of precedence
12116 down to the assignment operators. The expression must be followed (and thus
12117 terminated) either by a comma or lower-precedence operator or by
12118 something that would normally terminate an expression such as semicolon.
12119 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12120 otherwise it is mandatory. It is up to the caller to ensure that the
12121 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12122 the source of the code to be parsed and the lexical context for the
12125 The op tree representing the expression is returned. If an optional
12126 expression is absent, a null pointer is returned, otherwise the pointer
12129 If an error occurs in parsing or compilation, in most cases a valid op
12130 tree is returned anyway. The error is reflected in the parser state,
12131 normally resulting in a single exception at the top level of parsing
12132 which covers all the compilation errors that occurred. Some compilation
12133 errors, however, will throw an exception immediately.
12139 Perl_parse_termexpr(pTHX_ U32 flags)
12141 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12145 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12147 Parse a Perl list expression. This may contain operators of precedence
12148 down to the comma operator. The expression must be followed (and thus
12149 terminated) either by a low-precedence logic operator such as C<or> or by
12150 something that would normally terminate an expression such as semicolon.
12151 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12152 otherwise it is mandatory. It is up to the caller to ensure that the
12153 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12154 the source of the code to be parsed and the lexical context for the
12157 The op tree representing the expression is returned. If an optional
12158 expression is absent, a null pointer is returned, otherwise the pointer
12161 If an error occurs in parsing or compilation, in most cases a valid op
12162 tree is returned anyway. The error is reflected in the parser state,
12163 normally resulting in a single exception at the top level of parsing
12164 which covers all the compilation errors that occurred. Some compilation
12165 errors, however, will throw an exception immediately.
12171 Perl_parse_listexpr(pTHX_ U32 flags)
12173 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12177 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12179 Parse a single complete Perl expression. This allows the full
12180 expression grammar, including the lowest-precedence operators such
12181 as C<or>. The expression must be followed (and thus terminated) by a
12182 token that an expression would normally be terminated by: end-of-file,
12183 closing bracketing punctuation, semicolon, or one of the keywords that
12184 signals a postfix expression-statement modifier. If C<flags> has the
12185 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12186 mandatory. It is up to the caller to ensure that the dynamic parser
12187 state (L</PL_parser> et al) is correctly set to reflect the source of
12188 the code to be parsed and the lexical context for the expression.
12190 The op tree representing the expression is returned. If an optional
12191 expression is absent, a null pointer is returned, otherwise the pointer
12194 If an error occurs in parsing or compilation, in most cases a valid op
12195 tree is returned anyway. The error is reflected in the parser state,
12196 normally resulting in a single exception at the top level of parsing
12197 which covers all the compilation errors that occurred. Some compilation
12198 errors, however, will throw an exception immediately.
12204 Perl_parse_fullexpr(pTHX_ U32 flags)
12206 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12210 =for apidoc Amx|OP *|parse_block|U32 flags
12212 Parse a single complete Perl code block. This consists of an opening
12213 brace, a sequence of statements, and a closing brace. The block
12214 constitutes a lexical scope, so C<my> variables and various compile-time
12215 effects can be contained within it. It is up to the caller to ensure
12216 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12217 reflect the source of the code to be parsed and the lexical context for
12220 The op tree representing the code block is returned. This is always a
12221 real op, never a null pointer. It will normally be a C<lineseq> list,
12222 including C<nextstate> or equivalent ops. No ops to construct any kind
12223 of runtime scope are included by virtue of it being a block.
12225 If an error occurs in parsing or compilation, in most cases a valid op
12226 tree (most likely null) is returned anyway. The error is reflected in
12227 the parser state, normally resulting in a single exception at the top
12228 level of parsing which covers all the compilation errors that occurred.
12229 Some compilation errors, however, will throw an exception immediately.
12231 The C<flags> parameter is reserved for future use, and must always
12238 Perl_parse_block(pTHX_ U32 flags)
12241 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12242 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12246 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12248 Parse a single unadorned Perl statement. This may be a normal imperative
12249 statement or a declaration that has compile-time effect. It does not
12250 include any label or other affixture. It is up to the caller to ensure
12251 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12252 reflect the source of the code to be parsed and the lexical context for
12255 The op tree representing the statement is returned. This may be a
12256 null pointer if the statement is null, for example if it was actually
12257 a subroutine definition (which has compile-time side effects). If not
12258 null, it will be ops directly implementing the statement, suitable to
12259 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12260 equivalent op (except for those embedded in a scope contained entirely
12261 within the statement).
12263 If an error occurs in parsing or compilation, in most cases a valid op
12264 tree (most likely null) is returned anyway. The error is reflected in
12265 the parser state, normally resulting in a single exception at the top
12266 level of parsing which covers all the compilation errors that occurred.
12267 Some compilation errors, however, will throw an exception immediately.
12269 The C<flags> parameter is reserved for future use, and must always
12276 Perl_parse_barestmt(pTHX_ U32 flags)
12279 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12280 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12284 =for apidoc Amx|SV *|parse_label|U32 flags
12286 Parse a single label, possibly optional, of the type that may prefix a
12287 Perl statement. It is up to the caller to ensure that the dynamic parser
12288 state (L</PL_parser> et al) is correctly set to reflect the source of
12289 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12290 label is optional, otherwise it is mandatory.
12292 The name of the label is returned in the form of a fresh scalar. If an
12293 optional label is absent, a null pointer is returned.
12295 If an error occurs in parsing, which can only occur if the label is
12296 mandatory, a valid label is returned anyway. The error is reflected in
12297 the parser state, normally resulting in a single exception at the top
12298 level of parsing which covers all the compilation errors that occurred.
12304 Perl_parse_label(pTHX_ U32 flags)
12306 if (flags & ~PARSE_OPTIONAL)
12307 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12309 PL_parser->yychar = yylex();
12310 if (PL_parser->yychar == LABEL) {
12311 char * const lpv = pl_yylval.pval;
12312 STRLEN llen = strlen(lpv);
12313 PL_parser->yychar = YYEMPTY;
12314 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12321 STRLEN wlen, bufptr_pos;
12324 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12326 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12327 if (word_takes_any_delimiter(s, wlen))
12329 bufptr_pos = s - SvPVX(PL_linestr);
12331 lex_read_space(LEX_KEEP_PREVIOUS);
12333 s = SvPVX(PL_linestr) + bufptr_pos;
12334 if (t[0] == ':' && t[1] != ':') {
12335 PL_oldoldbufptr = PL_oldbufptr;
12338 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12342 if (flags & PARSE_OPTIONAL) {
12345 qerror(Perl_mess(aTHX_ "Parse error"));
12346 return newSVpvs("x");
12353 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12355 Parse a single complete Perl statement. This may be a normal imperative
12356 statement or a declaration that has compile-time effect, and may include
12357 optional labels. It is up to the caller to ensure that the dynamic
12358 parser state (L</PL_parser> et al) is correctly set to reflect the source
12359 of the code to be parsed and the lexical context for the statement.
12361 The op tree representing the statement is returned. This may be a
12362 null pointer if the statement is null, for example if it was actually
12363 a subroutine definition (which has compile-time side effects). If not
12364 null, it will be the result of a L</newSTATEOP> call, normally including
12365 a C<nextstate> or equivalent op.
12367 If an error occurs in parsing or compilation, in most cases a valid op
12368 tree (most likely null) is returned anyway. The error is reflected in
12369 the parser state, normally resulting in a single exception at the top
12370 level of parsing which covers all the compilation errors that occurred.
12371 Some compilation errors, however, will throw an exception immediately.
12373 The C<flags> parameter is reserved for future use, and must always
12380 Perl_parse_fullstmt(pTHX_ U32 flags)
12383 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12384 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12388 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12390 Parse a sequence of zero or more Perl statements. These may be normal
12391 imperative statements, including optional labels, or declarations
12392 that have compile-time effect, or any mixture thereof. The statement
12393 sequence ends when a closing brace or end-of-file is encountered in a
12394 place where a new statement could have validly started. It is up to
12395 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12396 is correctly set to reflect the source of the code to be parsed and the
12397 lexical context for the statements.
12399 The op tree representing the statement sequence is returned. This may
12400 be a null pointer if the statements were all null, for example if there
12401 were no statements or if there were only subroutine definitions (which
12402 have compile-time side effects). If not null, it will be a C<lineseq>
12403 list, normally including C<nextstate> or equivalent ops.
12405 If an error occurs in parsing or compilation, in most cases a valid op
12406 tree is returned anyway. The error is reflected in the parser state,
12407 normally resulting in a single exception at the top level of parsing
12408 which covers all the compilation errors that occurred. Some compilation
12409 errors, however, will throw an exception immediately.
12411 The C<flags> parameter is reserved for future use, and must always
12418 Perl_parse_stmtseq(pTHX_ U32 flags)
12423 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12424 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12425 c = lex_peek_unichar(0);
12426 if (c != -1 && c != /*{*/'}')
12427 qerror(Perl_mess(aTHX_ "Parse error"));
12432 * ex: set ts=8 sts=4 sw=4 et: