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_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_sublex_info (PL_parser->sublex_info)
69 #define PL_linestr (PL_parser->linestr)
70 #define PL_expect (PL_parser->expect)
71 #define PL_copline (PL_parser->copline)
72 #define PL_bufptr (PL_parser->bufptr)
73 #define PL_oldbufptr (PL_parser->oldbufptr)
74 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
75 #define PL_linestart (PL_parser->linestart)
76 #define PL_bufend (PL_parser->bufend)
77 #define PL_last_uni (PL_parser->last_uni)
78 #define PL_last_lop (PL_parser->last_lop)
79 #define PL_last_lop_op (PL_parser->last_lop_op)
80 #define PL_lex_state (PL_parser->lex_state)
81 #define PL_rsfp (PL_parser->rsfp)
82 #define PL_rsfp_filters (PL_parser->rsfp_filters)
83 #define PL_in_my (PL_parser->in_my)
84 #define PL_in_my_stash (PL_parser->in_my_stash)
85 #define PL_tokenbuf (PL_parser->tokenbuf)
86 #define PL_multi_end (PL_parser->multi_end)
87 #define PL_error_count (PL_parser->error_count)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_nexttype (PL_parser->nexttype)
91 # define PL_nextval (PL_parser->nextval)
93 static const char* const ident_too_long = "Identifier too long";
95 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
97 #define XENUMMASK 0x3f
99 #define XFAKEBRACK 0x80
101 #ifdef USE_UTF8_SCRIPTS
102 # define UTF cBOOL(!IN_BYTES)
104 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
107 /* The maximum number of characters preceding the unrecognized one to display */
108 #define UNRECOGNIZED_PRECEDE_COUNT 10
110 /* In variables named $^X, these are the legal values for X.
111 * 1999-02-27 mjd-perl-patch@plover.com */
112 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
114 #define SPACE_OR_TAB(c) isBLANK_A(c)
116 #define HEXFP_PEEK(s) \
118 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
119 isALPHA_FOLD_EQ(s[0], 'p'))
121 /* LEX_* are values for PL_lex_state, the state of the lexer.
122 * They are arranged oddly so that the guard on the switch statement
123 * can get by with a single comparison (if the compiler is smart enough).
125 * These values refer to the various states within a sublex parse,
126 * i.e. within a double quotish string
129 /* #define LEX_NOTPARSING 11 is done in perl.h. */
131 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
132 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
133 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
134 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
135 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
137 /* at end of code, eg "$x" followed by: */
138 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
139 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
141 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
142 string or after \E, $foo, etc */
143 #define LEX_INTERPCONST 2 /* NOT USED */
144 #define LEX_FORMLINE 1 /* expecting a format line */
145 #define LEX_KNOWNEXT 0 /* next token known; just return it */
149 static const char* const lex_state_names[] = {
164 #include "keywords.h"
166 /* CLINE is a macro that ensures PL_copline has a sane value */
168 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 * Convenience functions to return different tokens and prime the
172 * lexer for the next token. They all take an argument.
174 * TOKEN : generic token (used for '(', DOLSHARP, etc)
175 * OPERATOR : generic operator
176 * AOPERATOR : assignment operator
177 * PREBLOCK : beginning the block after an if, while, foreach, ...
178 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
179 * PREREF : *EXPR where EXPR is not a simple identifier
180 * TERM : expression term
181 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
182 * LOOPX : loop exiting command (goto, last, dump, etc)
183 * FTST : file test operator
184 * FUN0 : zero-argument function
185 * FUN0OP : zero-argument function, with its op created in this file
186 * FUN1 : not used, except for not, which isn't a UNIOP
187 * BOop : bitwise or or xor
189 * BCop : bitwise complement
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
194 * AopNOASSIGN : addition-level operator that is never part of .=
195 * Mop : multiplication-level operator
196 * Eop : equality-testing operator
197 * Rop : relational operator <= != gt
199 * Also see LOP and lop() below.
202 #ifdef DEBUGGING /* Serve -DT. */
203 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
205 # define REPORT(retval) (retval)
208 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
209 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
210 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
211 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
213 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
214 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
215 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
216 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
218 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
220 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
221 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
222 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
223 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
224 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
225 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
226 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
228 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
229 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
230 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
231 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
232 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
233 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
234 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
235 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
237 /* This bit of chicanery makes a unary function followed by
238 * a parenthesis into a function with one argument, highest precedence.
239 * The UNIDOR macro is for unary functions that can be followed by the //
240 * operator (such as C<shift // 0>).
242 #define UNI3(f,x,have_x) { \
243 pl_yylval.ival = f; \
244 if (have_x) PL_expect = x; \
246 PL_last_uni = PL_oldbufptr; \
247 PL_last_lop_op = f; \
249 return REPORT( (int)FUNC1 ); \
251 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
253 #define UNI(f) UNI3(f,XTERM,1)
254 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
255 #define UNIPROTO(f,optional) { \
256 if (optional) PL_last_uni = PL_oldbufptr; \
260 #define UNIBRACK(f) UNI3(f,0,0)
262 /* grandfather return to old style */
265 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
266 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
267 pl_yylval.ival = (f); \
273 #define COPLINE_INC_WITH_HERELINES \
275 CopLINE_inc(PL_curcop); \
276 if (PL_parser->herelines) \
277 CopLINE(PL_curcop) += PL_parser->herelines, \
278 PL_parser->herelines = 0; \
280 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
281 * is no sublex_push to follow. */
282 #define COPLINE_SET_FROM_MULTI_END \
284 CopLINE_set(PL_curcop, PL_multi_end); \
285 if (PL_multi_end != PL_multi_start) \
286 PL_parser->herelines = 0; \
292 /* how to interpret the pl_yylval associated with the token */
296 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
301 static struct debug_tokens {
303 enum token_type type;
305 } const debug_tokens[] =
307 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
308 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
309 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
310 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
311 { ARROW, TOKENTYPE_NONE, "ARROW" },
312 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
313 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
314 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
315 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
316 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
317 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
318 { DO, TOKENTYPE_NONE, "DO" },
319 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
320 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
321 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
322 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
323 { ELSE, TOKENTYPE_NONE, "ELSE" },
324 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
325 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
326 { FOR, TOKENTYPE_IVAL, "FOR" },
327 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
328 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
329 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
330 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
331 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
332 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
333 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
334 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
335 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
336 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
337 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
338 { IF, TOKENTYPE_IVAL, "IF" },
339 { LABEL, TOKENTYPE_PVAL, "LABEL" },
340 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
341 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
342 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
343 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
344 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
345 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
346 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
347 { MY, TOKENTYPE_IVAL, "MY" },
348 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
349 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
350 { OROP, TOKENTYPE_IVAL, "OROP" },
351 { OROR, TOKENTYPE_NONE, "OROR" },
352 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
353 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
354 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
355 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
356 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
357 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
358 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
359 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
360 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
361 { PREINC, TOKENTYPE_NONE, "PREINC" },
362 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
363 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
364 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
365 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
366 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
367 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
368 { SUB, TOKENTYPE_NONE, "SUB" },
369 { THING, TOKENTYPE_OPVAL, "THING" },
370 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
371 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
372 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
373 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
374 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
375 { USE, TOKENTYPE_IVAL, "USE" },
376 { WHEN, TOKENTYPE_IVAL, "WHEN" },
377 { WHILE, TOKENTYPE_IVAL, "WHILE" },
378 { WORD, TOKENTYPE_OPVAL, "WORD" },
379 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
380 { 0, TOKENTYPE_NONE, NULL }
383 /* dump the returned token in rv, plus any optional arg in pl_yylval */
386 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
388 PERL_ARGS_ASSERT_TOKEREPORT;
391 const char *name = NULL;
392 enum token_type type = TOKENTYPE_NONE;
393 const struct debug_tokens *p;
394 SV* const report = newSVpvs("<== ");
396 for (p = debug_tokens; p->token; p++) {
397 if (p->token == (int)rv) {
404 Perl_sv_catpv(aTHX_ report, name);
405 else if (isGRAPH(rv))
407 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
409 sv_catpvs(report, " (pending identifier)");
412 sv_catpvs(report, "EOF");
414 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
419 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
421 case TOKENTYPE_OPNUM:
422 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
423 PL_op_name[lvalp->ival]);
426 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
428 case TOKENTYPE_OPVAL:
430 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
431 PL_op_name[lvalp->opval->op_type]);
432 if (lvalp->opval->op_type == OP_CONST) {
433 Perl_sv_catpvf(aTHX_ report, " %s",
434 SvPEEK(cSVOPx_sv(lvalp->opval)));
439 sv_catpvs(report, "(opval=null)");
442 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
448 /* print the buffer with suitable escapes */
451 S_printbuf(pTHX_ const char *const fmt, const char *const s)
453 SV* const tmp = newSVpvs("");
455 PERL_ARGS_ASSERT_PRINTBUF;
457 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
458 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
466 S_deprecate_commaless_var_list(pTHX) {
468 deprecate("comma-less variable list");
469 return REPORT(','); /* grandfather non-comma-format format */
475 * This subroutine looks for an '=' next to the operator that has just been
476 * parsed and turns it into an ASSIGNOP if it finds one.
480 S_ao(pTHX_ int toketype)
482 if (*PL_bufptr == '=') {
484 if (toketype == ANDAND)
485 pl_yylval.ival = OP_ANDASSIGN;
486 else if (toketype == OROR)
487 pl_yylval.ival = OP_ORASSIGN;
488 else if (toketype == DORDOR)
489 pl_yylval.ival = OP_DORASSIGN;
492 return REPORT(toketype);
497 * When Perl expects an operator and finds something else, no_op
498 * prints the warning. It always prints "<something> found where
499 * operator expected. It prints "Missing semicolon on previous line?"
500 * if the surprise occurs at the start of the line. "do you need to
501 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
502 * where the compiler doesn't know if foo is a method call or a function.
503 * It prints "Missing operator before end of line" if there's nothing
504 * after the missing operator, or "... before <...>" if there is something
505 * after the missing operator.
507 * PL_bufptr is expected to point to the start of the thing that was found,
508 * and s after the next token or partial token.
512 S_no_op(pTHX_ const char *const what, char *s)
514 char * const oldbp = PL_bufptr;
515 const bool is_first = (PL_oldbufptr == PL_linestart);
517 PERL_ARGS_ASSERT_NO_OP;
523 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
524 if (ckWARN_d(WARN_SYNTAX)) {
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
527 "\t(Missing semicolon on previous line?)\n");
528 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
530 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
531 t += UTF ? UTF8SKIP(t) : 1)
533 if (t < PL_bufptr && isSPACE(*t))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Do you need to predeclare %"UTF8f"?)\n",
536 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing operator before %"UTF8f"?)\n",
542 UTF8fARG(UTF, s - oldbp, oldbp));
550 * Complain about missing quote/regexp/heredoc terminator.
551 * If it's called with NULL then it cauterizes the line buffer.
552 * If we're in a delimited string and the delimiter is a control
553 * character, it's reformatted into a two-char sequence like ^C.
558 S_missingterm(pTHX_ char *s)
563 char * const nl = strrchr(s,'\n');
567 else if ((U8) PL_multi_close < 32) {
569 tmpbuf[1] = (char)toCTRL(PL_multi_close);
574 *tmpbuf = (char)PL_multi_close;
578 q = strchr(s,'"') ? '\'' : '"';
579 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
585 * Check whether the named feature is enabled.
588 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
590 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
592 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
594 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
596 if (namelen > MAX_FEATURE_LEN)
598 memcpy(&he_name[8], name, namelen);
600 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
601 REFCOUNTED_HE_EXISTS));
605 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
606 * utf16-to-utf8-reversed.
609 #ifdef PERL_CR_FILTER
613 const char *s = SvPVX_const(sv);
614 const char * const e = s + SvCUR(sv);
616 PERL_ARGS_ASSERT_STRIP_RETURN;
618 /* outer loop optimized to do nothing if there are no CR-LFs */
620 if (*s++ == '\r' && *s == '\n') {
621 /* hit a CR-LF, need to copy the rest */
625 if (*s == '\r' && s[1] == '\n')
636 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
639 if (count > 0 && !maxlen)
646 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
648 Creates and initialises a new lexer/parser state object, supplying
649 a context in which to lex and parse from a new source of Perl code.
650 A pointer to the new state object is placed in L</PL_parser>. An entry
651 is made on the save stack so that upon unwinding the new state object
652 will be destroyed and the former value of L</PL_parser> will be restored.
653 Nothing else need be done to clean up the parsing context.
655 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
656 non-null, provides a string (in SV form) containing code to be parsed.
657 A copy of the string is made, so subsequent modification of C<line>
658 does not affect parsing. C<rsfp>, if non-null, provides an input stream
659 from which code will be read to be parsed. If both are non-null, the
660 code in C<line> comes first and must consist of complete lines of input,
661 and C<rsfp> supplies the remainder of the source.
663 The C<flags> parameter is reserved for future use. Currently it is only
664 used by perl internally, so extensions should always pass zero.
669 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
670 can share filters with the current parser.
671 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
672 caller, hence isn't owned by the parser, so shouldn't be closed on parser
673 destruction. This is used to handle the case of defaulting to reading the
674 script from the standard input because no filename was given on the command
675 line (without getting confused by situation where STDIN has been closed, so
676 the script handle is opened on fd 0) */
679 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
681 const char *s = NULL;
682 yy_parser *parser, *oparser;
683 if (flags && flags & ~LEX_START_FLAGS)
684 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
686 /* create and initialise a parser */
688 Newxz(parser, 1, yy_parser);
689 parser->old_parser = oparser = PL_parser;
692 parser->stack = NULL;
694 parser->stack_size = 0;
696 /* on scope exit, free this parser and restore any outer one */
698 parser->saved_curcop = PL_curcop;
700 /* initialise lexer state */
702 parser->nexttoke = 0;
703 parser->error_count = oparser ? oparser->error_count : 0;
704 parser->copline = parser->preambling = NOLINE;
705 parser->lex_state = LEX_NORMAL;
706 parser->expect = XSTATE;
708 parser->rsfp_filters =
709 !(flags & LEX_START_SAME_FILTER) || !oparser
711 : MUTABLE_AV(SvREFCNT_inc(
712 oparser->rsfp_filters
713 ? oparser->rsfp_filters
714 : (oparser->rsfp_filters = newAV())
717 Newx(parser->lex_brackstack, 120, char);
718 Newx(parser->lex_casestack, 12, char);
719 *parser->lex_casestack = '\0';
720 Newxz(parser->lex_shared, 1, LEXSHARED);
724 s = SvPV_const(line, len);
725 parser->linestr = flags & LEX_START_COPIED
726 ? SvREFCNT_inc_simple_NN(line)
727 : newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
730 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
732 parser->oldoldbufptr =
735 parser->linestart = SvPVX(parser->linestr);
736 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
737 parser->last_lop = parser->last_uni = NULL;
739 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
740 |LEX_DONT_CLOSE_RSFP));
741 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
742 |LEX_DONT_CLOSE_RSFP));
744 parser->in_pod = parser->filtered = 0;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser
761 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
764 SvREFCNT_dec(parser->lex_stuff);
765 SvREFCNT_dec(parser->sublex_info.repl);
767 Safefree(parser->lex_brackstack);
768 Safefree(parser->lex_casestack);
769 Safefree(parser->lex_shared);
770 PL_parser = parser->old_parser;
775 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
777 I32 nexttoke = parser->nexttoke;
778 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
780 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
781 && parser->nextval[nexttoke].opval
782 && parser->nextval[nexttoke].opval->op_slabbed
783 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
784 op_free(parser->nextval[nexttoke].opval);
785 parser->nextval[nexttoke].opval = NULL;
792 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
794 Buffer scalar containing the chunk currently under consideration of the
795 text currently being lexed. This is always a plain string scalar (for
796 which C<SvPOK> is true). It is not intended to be used as a scalar by
797 normal scalar means; instead refer to the buffer directly by the pointer
798 variables described below.
800 The lexer maintains various C<char*> pointers to things in the
801 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
802 reallocated, all of these pointers must be updated. Don't attempt to
803 do this manually, but rather use L</lex_grow_linestr> if you need to
804 reallocate the buffer.
806 The content of the text chunk in the buffer is commonly exactly one
807 complete line of input, up to and including a newline terminator,
808 but there are situations where it is otherwise. The octets of the
809 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
810 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
811 flag on this scalar, which may disagree with it.
813 For direct examination of the buffer, the variable
814 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
815 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
816 of these pointers is usually preferable to examination of the scalar
817 through normal scalar means.
819 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
821 Direct pointer to the end of the chunk of text currently being lexed, the
822 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
823 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
824 always located at the end of the buffer, and does not count as part of
825 the buffer's contents.
827 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
829 Points to the current position of lexing inside the lexer buffer.
830 Characters around this point may be freely examined, within
831 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
832 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
833 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
835 Lexing code (whether in the Perl core or not) moves this pointer past
836 the characters that it consumes. It is also expected to perform some
837 bookkeeping whenever a newline character is consumed. This movement
838 can be more conveniently performed by the function L</lex_read_to>,
839 which handles newlines appropriately.
841 Interpretation of the buffer's octets can be abstracted out by
842 using the slightly higher-level functions L</lex_peek_unichar> and
843 L</lex_read_unichar>.
845 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
847 Points to the start of the current line inside the lexer buffer.
848 This is useful for indicating at which column an error occurred, and
849 not much else. This must be updated by any lexing code that consumes
850 a newline; the function L</lex_read_to> handles this detail.
856 =for apidoc Amx|bool|lex_bufutf8
858 Indicates whether the octets in the lexer buffer
859 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
860 of Unicode characters. If not, they should be interpreted as Latin-1
861 characters. This is analogous to the C<SvUTF8> flag for scalars.
863 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
864 contains valid UTF-8. Lexing code must be robust in the face of invalid
867 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
868 is significant, but not the whole story regarding the input character
869 encoding. Normally, when a file is being read, the scalar contains octets
870 and its C<SvUTF8> flag is off, but the octets should be interpreted as
871 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
872 however, the scalar may have the C<SvUTF8> flag on, and in this case its
873 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
874 is in effect. This logic may change in the future; use this function
875 instead of implementing the logic yourself.
881 Perl_lex_bufutf8(pTHX)
887 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
889 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
890 at least C<len> octets (including terminating C<NUL>). Returns a
891 pointer to the reallocated buffer. This is necessary before making
892 any direct modification of the buffer that would increase its length.
893 L</lex_stuff_pvn> provides a more convenient way to insert text into
896 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
897 this function updates all of the lexer's variables that point directly
904 Perl_lex_grow_linestr(pTHX_ STRLEN len)
908 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
909 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
910 linestr = PL_parser->linestr;
911 buf = SvPVX(linestr);
912 if (len <= SvLEN(linestr))
914 bufend_pos = PL_parser->bufend - buf;
915 bufptr_pos = PL_parser->bufptr - buf;
916 oldbufptr_pos = PL_parser->oldbufptr - buf;
917 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
918 linestart_pos = PL_parser->linestart - buf;
919 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
920 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
921 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
922 PL_parser->lex_shared->re_eval_start - buf : 0;
924 buf = sv_grow(linestr, len);
926 PL_parser->bufend = buf + bufend_pos;
927 PL_parser->bufptr = buf + bufptr_pos;
928 PL_parser->oldbufptr = buf + oldbufptr_pos;
929 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
930 PL_parser->linestart = buf + linestart_pos;
931 if (PL_parser->last_uni)
932 PL_parser->last_uni = buf + last_uni_pos;
933 if (PL_parser->last_lop)
934 PL_parser->last_lop = buf + last_lop_pos;
935 if (PL_parser->lex_shared->re_eval_start)
936 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
941 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
943 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
944 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
945 reallocating the buffer if necessary. This means that lexing code that
946 runs later will see the characters as if they had appeared in the input.
947 It is not recommended to do this as part of normal parsing, and most
948 uses of this facility run the risk of the inserted characters being
949 interpreted in an unintended manner.
951 The string to be inserted is represented by C<len> octets starting
952 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
953 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
954 The characters are recoded for the lexer buffer, according to how the
955 buffer is currently being interpreted (L</lex_bufutf8>). If a string
956 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
957 function is more convenient.
963 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
967 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
968 if (flags & ~(LEX_STUFF_UTF8))
969 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
971 if (flags & LEX_STUFF_UTF8) {
974 STRLEN highhalf = 0; /* Count of variants */
975 const char *p, *e = pv+len;
976 for (p = pv; p != e; p++) {
977 if (! UTF8_IS_INVARIANT(*p)) {
983 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
984 bufptr = PL_parser->bufptr;
985 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
986 SvCUR_set(PL_parser->linestr,
987 SvCUR(PL_parser->linestr) + len+highhalf);
988 PL_parser->bufend += len+highhalf;
989 for (p = pv; p != e; p++) {
991 if (! UTF8_IS_INVARIANT(c)) {
992 *bufptr++ = UTF8_TWO_BYTE_HI(c);
993 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1000 if (flags & LEX_STUFF_UTF8) {
1001 STRLEN highhalf = 0;
1002 const char *p, *e = pv+len;
1003 for (p = pv; p != e; p++) {
1005 if (UTF8_IS_ABOVE_LATIN1(c)) {
1006 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1007 "non-Latin-1 character into Latin-1 input");
1008 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1011 } else if (! UTF8_IS_INVARIANT(c)) {
1012 /* malformed UTF-8 */
1014 SAVESPTR(PL_warnhook);
1015 PL_warnhook = PERL_WARNHOOK_FATAL;
1016 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1022 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1023 bufptr = PL_parser->bufptr;
1024 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1025 SvCUR_set(PL_parser->linestr,
1026 SvCUR(PL_parser->linestr) + len-highhalf);
1027 PL_parser->bufend += len-highhalf;
1030 if (UTF8_IS_INVARIANT(*p)) {
1036 *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1042 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1043 bufptr = PL_parser->bufptr;
1044 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1045 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1046 PL_parser->bufend += len;
1047 Copy(pv, bufptr, len, char);
1053 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1055 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1056 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1057 reallocating the buffer if necessary. This means that lexing code that
1058 runs later will see the characters as if they had appeared in the input.
1059 It is not recommended to do this as part of normal parsing, and most
1060 uses of this facility run the risk of the inserted characters being
1061 interpreted in an unintended manner.
1063 The string to be inserted is represented by octets starting at C<pv>
1064 and continuing to the first nul. These octets are interpreted as either
1065 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1066 in C<flags>. The characters are recoded for the lexer buffer, according
1067 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1068 If it is not convenient to nul-terminate a string to be inserted, the
1069 L</lex_stuff_pvn> function is more appropriate.
1075 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1077 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1078 lex_stuff_pvn(pv, strlen(pv), flags);
1082 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1084 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1085 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1086 reallocating the buffer if necessary. This means that lexing code that
1087 runs later will see the characters as if they had appeared in the input.
1088 It is not recommended to do this as part of normal parsing, and most
1089 uses of this facility run the risk of the inserted characters being
1090 interpreted in an unintended manner.
1092 The string to be inserted is the string value of C<sv>. The characters
1093 are recoded for the lexer buffer, according to how the buffer is currently
1094 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1095 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1096 need to construct a scalar.
1102 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1106 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1110 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1114 =for apidoc Amx|void|lex_unstuff|char *ptr
1116 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1117 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1118 This hides the discarded text from any lexing code that runs later,
1119 as if the text had never appeared.
1121 This is not the normal way to consume lexed text. For that, use
1128 Perl_lex_unstuff(pTHX_ char *ptr)
1132 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1133 buf = PL_parser->bufptr;
1135 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 bufend = PL_parser->bufend;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1141 unstuff_len = ptr - buf;
1142 Move(ptr, buf, bufend+1-ptr, char);
1143 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1144 PL_parser->bufend = bufend - unstuff_len;
1148 =for apidoc Amx|void|lex_read_to|char *ptr
1150 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1151 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1152 performing the correct bookkeeping whenever a newline character is passed.
1153 This is the normal way to consume lexed text.
1155 Interpretation of the buffer's octets can be abstracted out by
1156 using the slightly higher-level functions L</lex_peek_unichar> and
1157 L</lex_read_unichar>.
1163 Perl_lex_read_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_READ_TO;
1167 s = PL_parser->bufptr;
1168 if (ptr < s || ptr > PL_parser->bufend)
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1170 for (; s != ptr; s++)
1172 COPLINE_INC_WITH_HERELINES;
1173 PL_parser->linestart = s+1;
1175 PL_parser->bufptr = ptr;
1179 =for apidoc Amx|void|lex_discard_to|char *ptr
1181 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1182 up to C<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. C<ptr> must not
1184 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1185 it is not permitted to discard text that has yet to be lexed.
1187 Normally it is not necessarily to do this directly, because it suffices to
1188 use the implicit discarding behaviour of L</lex_next_chunk> and things
1189 based on it. However, if a token stretches across multiple lines,
1190 and the lexing code has kept multiple lines of text in the buffer for
1191 that purpose, then after completion of the token it would be wise to
1192 explicitly discard the now-unneeded earlier lines, to avoid future
1193 multi-line tokens growing the buffer without bound.
1199 Perl_lex_discard_to(pTHX_ char *ptr)
1203 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1204 buf = SvPVX(PL_parser->linestr);
1206 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1209 if (ptr > PL_parser->bufptr)
1210 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1211 discard_len = ptr - buf;
1212 if (PL_parser->oldbufptr < ptr)
1213 PL_parser->oldbufptr = ptr;
1214 if (PL_parser->oldoldbufptr < ptr)
1215 PL_parser->oldoldbufptr = ptr;
1216 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1217 PL_parser->last_uni = NULL;
1218 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1219 PL_parser->last_lop = NULL;
1220 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1221 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1222 PL_parser->bufend -= discard_len;
1223 PL_parser->bufptr -= discard_len;
1224 PL_parser->oldbufptr -= discard_len;
1225 PL_parser->oldoldbufptr -= discard_len;
1226 if (PL_parser->last_uni)
1227 PL_parser->last_uni -= discard_len;
1228 if (PL_parser->last_lop)
1229 PL_parser->last_lop -= discard_len;
1233 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1235 Reads in the next chunk of text to be lexed, appending it to
1236 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1237 looked to the end of the current chunk and wants to know more. It is
1238 usual, but not necessary, for lexing to have consumed the entirety of
1239 the current chunk at this time.
1241 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1242 chunk (i.e., the current chunk has been entirely consumed), normally the
1243 current chunk will be discarded at the same time that the new chunk is
1244 read in. If C<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1245 will not be discarded. If the current chunk has not been entirely
1246 consumed, then it will not be discarded regardless of the flag.
1248 Returns true if some new text was added to the buffer, or false if the
1249 buffer has reached the end of the input text.
1254 #define LEX_FAKE_EOF 0x80000000
1255 #define LEX_NO_TERM 0x40000000 /* here-doc */
1258 Perl_lex_next_chunk(pTHX_ U32 flags)
1262 STRLEN old_bufend_pos, new_bufend_pos;
1263 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1264 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1265 bool got_some_for_debugger = 0;
1267 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1268 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1269 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1271 linestr = PL_parser->linestr;
1272 buf = SvPVX(linestr);
1273 if (!(flags & LEX_KEEP_PREVIOUS)
1274 && PL_parser->bufptr == PL_parser->bufend)
1276 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1278 if (PL_parser->last_uni != PL_parser->bufend)
1279 PL_parser->last_uni = NULL;
1280 if (PL_parser->last_lop != PL_parser->bufend)
1281 PL_parser->last_lop = NULL;
1282 last_uni_pos = last_lop_pos = 0;
1286 old_bufend_pos = PL_parser->bufend - buf;
1287 bufptr_pos = PL_parser->bufptr - buf;
1288 oldbufptr_pos = PL_parser->oldbufptr - buf;
1289 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1290 linestart_pos = PL_parser->linestart - buf;
1291 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1292 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1294 if (flags & LEX_FAKE_EOF) {
1296 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1298 } else if (filter_gets(linestr, old_bufend_pos)) {
1300 got_some_for_debugger = 1;
1301 } else if (flags & LEX_NO_TERM) {
1304 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1305 sv_setpvs(linestr, "");
1307 /* End of real input. Close filehandle (unless it was STDIN),
1308 * then add implicit termination.
1310 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1311 PerlIO_clearerr(PL_parser->rsfp);
1312 else if (PL_parser->rsfp)
1313 (void)PerlIO_close(PL_parser->rsfp);
1314 PL_parser->rsfp = NULL;
1315 PL_parser->in_pod = PL_parser->filtered = 0;
1316 if (!PL_in_eval && PL_minus_p) {
1318 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1319 PL_minus_n = PL_minus_p = 0;
1320 } else if (!PL_in_eval && PL_minus_n) {
1321 sv_catpvs(linestr, /*{*/";}");
1324 sv_catpvs(linestr, ";");
1327 buf = SvPVX(linestr);
1328 new_bufend_pos = SvCUR(linestr);
1329 PL_parser->bufend = buf + new_bufend_pos;
1330 PL_parser->bufptr = buf + bufptr_pos;
1331 PL_parser->oldbufptr = buf + oldbufptr_pos;
1332 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1333 PL_parser->linestart = buf + linestart_pos;
1334 if (PL_parser->last_uni)
1335 PL_parser->last_uni = buf + last_uni_pos;
1336 if (PL_parser->last_lop)
1337 PL_parser->last_lop = buf + last_lop_pos;
1338 if (PL_parser->preambling != NOLINE) {
1339 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1340 PL_parser->preambling = NOLINE;
1342 if ( got_some_for_debugger
1343 && PERLDB_LINE_OR_SAVESRC
1344 && PL_curstash != PL_debstash)
1346 /* debugger active and we're not compiling the debugger code,
1347 * so store the line into the debugger's array of lines
1349 update_debugger_info(NULL, buf+old_bufend_pos,
1350 new_bufend_pos-old_bufend_pos);
1356 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1358 Looks ahead one (Unicode) character in the text currently being lexed.
1359 Returns the codepoint (unsigned integer value) of the next character,
1360 or -1 if lexing has reached the end of the input text. To consume the
1361 peeked character, use L</lex_read_unichar>.
1363 If the next character is in (or extends into) the next chunk of input
1364 text, the next chunk will be read in. Normally the current chunk will be
1365 discarded at the same time, but if C<flags> includes C<LEX_KEEP_PREVIOUS>
1366 then the current chunk will not be discarded.
1368 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1369 is encountered, an exception is generated.
1375 Perl_lex_peek_unichar(pTHX_ U32 flags)
1379 if (flags & ~(LEX_KEEP_PREVIOUS))
1380 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1381 s = PL_parser->bufptr;
1382 bufend = PL_parser->bufend;
1388 if (!lex_next_chunk(flags))
1390 s = PL_parser->bufptr;
1391 bufend = PL_parser->bufend;
1394 if (UTF8_IS_INVARIANT(head))
1396 if (UTF8_IS_START(head)) {
1397 len = UTF8SKIP(&head);
1398 while ((STRLEN)(bufend-s) < len) {
1399 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1401 s = PL_parser->bufptr;
1402 bufend = PL_parser->bufend;
1405 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1406 if (retlen == (STRLEN)-1) {
1407 /* malformed UTF-8 */
1409 SAVESPTR(PL_warnhook);
1410 PL_warnhook = PERL_WARNHOOK_FATAL;
1411 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1417 if (!lex_next_chunk(flags))
1419 s = PL_parser->bufptr;
1426 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1428 Reads the next (Unicode) character in the text currently being lexed.
1429 Returns the codepoint (unsigned integer value) of the character read,
1430 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1431 if lexing has reached the end of the input text. To non-destructively
1432 examine the next character, use L</lex_peek_unichar> instead.
1434 If the next character is in (or extends into) the next chunk of input
1435 text, the next chunk will be read in. Normally the current chunk will be
1436 discarded at the same time, but if C<flags> includes C<LEX_KEEP_PREVIOUS>
1437 then the current chunk will not be discarded.
1439 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1440 is encountered, an exception is generated.
1446 Perl_lex_read_unichar(pTHX_ U32 flags)
1449 if (flags & ~(LEX_KEEP_PREVIOUS))
1450 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1451 c = lex_peek_unichar(flags);
1454 COPLINE_INC_WITH_HERELINES;
1456 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1458 ++(PL_parser->bufptr);
1464 =for apidoc Amx|void|lex_read_space|U32 flags
1466 Reads optional spaces, in Perl style, in the text currently being
1467 lexed. The spaces may include ordinary whitespace characters and
1468 Perl-style comments. C<#line> directives are processed if encountered.
1469 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1470 at a non-space character (or the end of the input text).
1472 If spaces extend into the next chunk of input text, the next chunk will
1473 be read in. Normally the current chunk will be discarded at the same
1474 time, but if C<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1475 chunk will not be discarded.
1480 #define LEX_NO_INCLINE 0x40000000
1481 #define LEX_NO_NEXT_CHUNK 0x80000000
1484 Perl_lex_read_space(pTHX_ U32 flags)
1487 const bool can_incline = !(flags & LEX_NO_INCLINE);
1488 bool need_incline = 0;
1489 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1490 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1491 s = PL_parser->bufptr;
1492 bufend = PL_parser->bufend;
1498 } while (!(c == '\n' || (c == 0 && s == bufend)));
1499 } else if (c == '\n') {
1502 PL_parser->linestart = s;
1508 } else if (isSPACE(c)) {
1510 } else if (c == 0 && s == bufend) {
1513 if (flags & LEX_NO_NEXT_CHUNK)
1515 PL_parser->bufptr = s;
1516 l = CopLINE(PL_curcop);
1517 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1518 got_more = lex_next_chunk(flags);
1519 CopLINE_set(PL_curcop, l);
1520 s = PL_parser->bufptr;
1521 bufend = PL_parser->bufend;
1524 if (can_incline && need_incline && PL_parser->rsfp) {
1534 PL_parser->bufptr = s;
1539 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1541 This function performs syntax checking on a prototype, C<proto>.
1542 If C<warn> is true, any illegal characters or mismatched brackets
1543 will trigger illegalproto warnings, declaring that they were
1544 detected in the prototype for C<name>.
1546 The return value is C<true> if this is a valid prototype, and
1547 C<false> if it is not, regardless of whether C<warn> was C<true> or
1550 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1557 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1559 STRLEN len, origlen;
1560 char *p = proto ? SvPV(proto, len) : NULL;
1561 bool bad_proto = FALSE;
1562 bool in_brackets = FALSE;
1563 bool after_slash = FALSE;
1564 char greedy_proto = ' ';
1565 bool proto_after_greedy_proto = FALSE;
1566 bool must_be_last = FALSE;
1567 bool underscore = FALSE;
1568 bool bad_proto_after_underscore = FALSE;
1570 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1576 for (; len--; p++) {
1579 proto_after_greedy_proto = TRUE;
1581 if (!strchr(";@%", *p))
1582 bad_proto_after_underscore = TRUE;
1585 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1592 in_brackets = FALSE;
1593 else if ((*p == '@' || *p == '%')
1597 must_be_last = TRUE;
1606 after_slash = FALSE;
1611 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1614 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1615 origlen, UNI_DISPLAY_ISPRINT)
1616 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1618 if (proto_after_greedy_proto)
1619 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1620 "Prototype after '%c' for %"SVf" : %s",
1621 greedy_proto, SVfARG(name), p);
1623 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1624 "Missing ']' in prototype for %"SVf" : %s",
1627 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1628 "Illegal character in prototype for %"SVf" : %s",
1630 if (bad_proto_after_underscore)
1631 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1632 "Illegal character after '_' in prototype for %"SVf" : %s",
1636 return (! (proto_after_greedy_proto || bad_proto) );
1641 * This subroutine has nothing to do with tilting, whether at windmills
1642 * or pinball tables. Its name is short for "increment line". It
1643 * increments the current line number in CopLINE(PL_curcop) and checks
1644 * to see whether the line starts with a comment of the form
1645 * # line 500 "foo.pm"
1646 * If so, it sets the current line number and file to the values in the comment.
1650 S_incline(pTHX_ const char *s)
1658 PERL_ARGS_ASSERT_INCLINE;
1660 COPLINE_INC_WITH_HERELINES;
1661 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1662 && s+1 == PL_bufend && *s == ';') {
1663 /* fake newline in string eval */
1664 CopLINE_dec(PL_curcop);
1669 while (SPACE_OR_TAB(*s))
1671 if (strnEQ(s, "line", 4))
1675 if (SPACE_OR_TAB(*s))
1679 while (SPACE_OR_TAB(*s))
1687 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1689 while (SPACE_OR_TAB(*s))
1691 if (*s == '"' && (t = strchr(s+1, '"'))) {
1697 while (!isSPACE(*t))
1701 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1703 if (*e != '\n' && *e != '\0')
1704 return; /* false alarm */
1706 if (!grok_atoUV(n, &uv, &e))
1708 line_num = ((line_t)uv) - 1;
1711 const STRLEN len = t - s;
1713 if (!PL_rsfp && !PL_parser->filtered) {
1714 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1715 * to *{"::_<newfilename"} */
1716 /* However, the long form of evals is only turned on by the
1717 debugger - usually they're "(eval %lu)" */
1718 GV * const cfgv = CopFILEGV(PL_curcop);
1721 STRLEN tmplen2 = len;
1725 if (tmplen2 + 2 <= sizeof smallbuf)
1728 Newx(tmpbuf2, tmplen2 + 2, char);
1733 memcpy(tmpbuf2 + 2, s, tmplen2);
1736 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1738 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1739 /* adjust ${"::_<newfilename"} to store the new file name */
1740 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1741 /* The line number may differ. If that is the case,
1742 alias the saved lines that are in the array.
1743 Otherwise alias the whole array. */
1744 if (CopLINE(PL_curcop) == line_num) {
1745 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1746 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1748 else if (GvAV(cfgv)) {
1749 AV * const av = GvAV(cfgv);
1750 const I32 start = CopLINE(PL_curcop)+1;
1751 I32 items = AvFILLp(av) - start;
1753 AV * const av2 = GvAVn(gv2);
1754 SV **svp = AvARRAY(av) + start;
1755 I32 l = (I32)line_num+1;
1757 av_store(av2, l++, SvREFCNT_inc(*svp++));
1762 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1765 CopFILE_free(PL_curcop);
1766 CopFILE_setn(PL_curcop, s, len);
1768 CopLINE_set(PL_curcop, line_num);
1771 #define skipspace(s) skipspace_flags(s, 0)
1775 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1777 AV *av = CopFILEAVx(PL_curcop);
1780 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1782 sv = *av_fetch(av, 0, 1);
1783 SvUPGRADE(sv, SVt_PVMG);
1785 if (!SvPOK(sv)) sv_setpvs(sv,"");
1787 sv_catsv(sv, orig_sv);
1789 sv_catpvn(sv, buf, len);
1794 if (PL_parser->preambling == NOLINE)
1795 av_store(av, CopLINE(PL_curcop), sv);
1801 * Called to gobble the appropriate amount and type of whitespace.
1802 * Skips comments as well.
1806 S_skipspace_flags(pTHX_ char *s, U32 flags)
1808 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1809 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1810 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1813 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1815 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1816 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1817 LEX_NO_NEXT_CHUNK : 0));
1819 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1820 if (PL_linestart > PL_bufptr)
1821 PL_bufptr = PL_linestart;
1829 * Check the unary operators to ensure there's no ambiguity in how they're
1830 * used. An ambiguous piece of code would be:
1832 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1833 * the +5 is its argument.
1842 if (PL_oldoldbufptr != PL_last_uni)
1844 while (isSPACE(*PL_last_uni))
1847 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1848 s += UTF ? UTF8SKIP(s) : 1;
1849 if ((t = strchr(s, '(')) && t < PL_bufptr)
1852 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1853 "Warning: Use of \"%"UTF8f"\" without parentheses is ambiguous",
1854 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1858 * LOP : macro to build a list operator. Its behaviour has been replaced
1859 * with a subroutine, S_lop() for which LOP is just another name.
1862 #define LOP(f,x) return lop(f,x,s)
1866 * Build a list operator (or something that might be one). The rules:
1867 * - if we have a next token, then it's a list operator (no parens) for
1868 * which the next token has already been parsed; e.g.,
1871 * - if the next thing is an opening paren, then it's a function
1872 * - else it's a list operator
1876 S_lop(pTHX_ I32 f, int x, char *s)
1878 PERL_ARGS_ASSERT_LOP;
1883 PL_last_lop = PL_oldbufptr;
1884 PL_last_lop_op = (OPCODE)f;
1889 return REPORT(FUNC);
1892 return REPORT(FUNC);
1895 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1896 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1897 return REPORT(LSTOP);
1903 * When the lexer realizes it knows the next token (for instance,
1904 * it is reordering tokens for the parser) then it can call S_force_next
1905 * to know what token to return the next time the lexer is called. Caller
1906 * will need to set PL_nextval[] and possibly PL_expect to ensure
1907 * the lexer handles the token correctly.
1911 S_force_next(pTHX_ I32 type)
1915 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1916 tokereport(type, &NEXTVAL_NEXTTOKE);
1919 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1920 PL_nexttype[PL_nexttoke] = type;
1922 if (PL_lex_state != LEX_KNOWNEXT) {
1923 PL_lex_defer = PL_lex_state;
1924 PL_lex_state = LEX_KNOWNEXT;
1931 * This subroutine handles postfix deref syntax after the arrow has already
1932 * been emitted. @* $* etc. are emitted as two separate token right here.
1933 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1934 * only the first, leaving yylex to find the next.
1938 S_postderef(pTHX_ int const funny, char const next)
1940 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1941 assert(strchr("*[{", next));
1943 PL_expect = XOPERATOR;
1944 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1945 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1946 PL_lex_state = LEX_INTERPEND;
1947 force_next(POSTJOIN);
1953 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1954 && !PL_lex_brackets)
1956 PL_expect = XOPERATOR;
1965 int yyc = PL_parser->yychar;
1966 if (yyc != YYEMPTY) {
1968 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1969 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1970 PL_lex_allbrackets--;
1972 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1973 } else if (yyc == '('/*)*/) {
1974 PL_lex_allbrackets--;
1979 PL_parser->yychar = YYEMPTY;
1984 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1986 SV * const sv = newSVpvn_utf8(start, len,
1989 && !is_invariant_string((const U8*)start, len)
1990 && is_utf8_string((const U8*)start, len));
1996 * When the lexer knows the next thing is a word (for instance, it has
1997 * just seen -> and it knows that the next char is a word char, then
1998 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2002 * char *start : buffer position (must be within PL_linestr)
2003 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2004 * int check_keyword : if true, Perl checks to make sure the word isn't
2005 * a keyword (do this if the word is a label, e.g. goto FOO)
2006 * int allow_pack : if true, : characters will also be allowed (require,
2007 * use, etc. do this)
2011 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2016 PERL_ARGS_ASSERT_FORCE_WORD;
2018 start = skipspace(start);
2020 if (isIDFIRST_lazy_if(s,UTF)
2021 || (allow_pack && *s == ':') )
2023 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2024 if (check_keyword) {
2025 char *s2 = PL_tokenbuf;
2027 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2029 if (keyword(s2, len2, 0))
2032 if (token == METHOD) {
2037 PL_expect = XOPERATOR;
2040 NEXTVAL_NEXTTOKE.opval
2041 = (OP*)newSVOP(OP_CONST,0,
2042 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2043 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2051 * Called when the lexer wants $foo *foo &foo etc, but the program
2052 * text only contains the "foo" portion. The first argument is a pointer
2053 * to the "foo", and the second argument is the type symbol to prefix.
2054 * Forces the next token to be a "WORD".
2055 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2059 S_force_ident(pTHX_ const char *s, int kind)
2061 PERL_ARGS_ASSERT_FORCE_IDENT;
2064 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2065 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2066 UTF ? SVf_UTF8 : 0));
2067 NEXTVAL_NEXTTOKE.opval = o;
2070 o->op_private = OPpCONST_ENTERED;
2071 /* XXX see note in pp_entereval() for why we forgo typo
2072 warnings if the symbol must be introduced in an eval.
2074 gv_fetchpvn_flags(s, len,
2075 (PL_in_eval ? GV_ADDMULTI
2076 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2077 kind == '$' ? SVt_PV :
2078 kind == '@' ? SVt_PVAV :
2079 kind == '%' ? SVt_PVHV :
2087 S_force_ident_maybe_lex(pTHX_ char pit)
2089 NEXTVAL_NEXTTOKE.ival = pit;
2094 Perl_str_to_version(pTHX_ SV *sv)
2099 const char *start = SvPV_const(sv,len);
2100 const char * const end = start + len;
2101 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2103 PERL_ARGS_ASSERT_STR_TO_VERSION;
2105 while (start < end) {
2109 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2114 retval += ((NV)n)/nshift;
2123 * Forces the next token to be a version number.
2124 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2125 * and if "guessing" is TRUE, then no new token is created (and the caller
2126 * must use an alternative parsing method).
2130 S_force_version(pTHX_ char *s, int guessing)
2135 PERL_ARGS_ASSERT_FORCE_VERSION;
2143 while (isDIGIT(*d) || *d == '_' || *d == '.')
2145 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2147 s = scan_num(s, &pl_yylval);
2148 version = pl_yylval.opval;
2149 ver = cSVOPx(version)->op_sv;
2150 if (SvPOK(ver) && !SvNIOK(ver)) {
2151 SvUPGRADE(ver, SVt_PVNV);
2152 SvNV_set(ver, str_to_version(ver));
2153 SvNOK_on(ver); /* hint that it is a version */
2156 else if (guessing) {
2161 /* NOTE: The parser sees the package name and the VERSION swapped */
2162 NEXTVAL_NEXTTOKE.opval = version;
2169 * S_force_strict_version
2170 * Forces the next token to be a version number using strict syntax rules.
2174 S_force_strict_version(pTHX_ char *s)
2177 const char *errstr = NULL;
2179 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2181 while (isSPACE(*s)) /* leading whitespace */
2184 if (is_STRICT_VERSION(s,&errstr)) {
2186 s = (char *)scan_version(s, ver, 0);
2187 version = newSVOP(OP_CONST, 0, ver);
2189 else if ((*s != ';' && *s != '{' && *s != '}' )
2190 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2194 yyerror(errstr); /* version required */
2198 /* NOTE: The parser sees the package name and the VERSION swapped */
2199 NEXTVAL_NEXTTOKE.opval = version;
2207 * Tokenize a quoted string passed in as an SV. It finds the next
2208 * chunk, up to end of string or a backslash. It may make a new
2209 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2214 S_tokeq(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_TOKEQ;
2225 assert (!SvIsCOW(sv));
2226 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2230 /* This is relying on the SV being "well formed" with a trailing '\0' */
2231 while (s < send && !(*s == '\\' && s[1] == '\\'))
2236 if ( PL_hints & HINT_NEW_STRING ) {
2237 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2238 SVs_TEMP | SvUTF8(sv));
2242 if (s + 1 < send && (s[1] == '\\'))
2243 s++; /* all that, just for this */
2248 SvCUR_set(sv, d - SvPVX_const(sv));
2250 if ( PL_hints & HINT_NEW_STRING )
2251 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2256 * Now come three functions related to double-quote context,
2257 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2258 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2259 * interact with PL_lex_state, and create fake ( ... ) argument lists
2260 * to handle functions and concatenation.
2264 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2269 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2271 * Pattern matching will set PL_lex_op to the pattern-matching op to
2272 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2274 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2276 * Everything else becomes a FUNC.
2278 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2279 * had an OP_CONST or OP_READLINE). This just sets us up for a
2280 * call to S_sublex_push().
2284 S_sublex_start(pTHX)
2286 const I32 op_type = pl_yylval.ival;
2288 if (op_type == OP_NULL) {
2289 pl_yylval.opval = PL_lex_op;
2293 if (op_type == OP_CONST) {
2294 SV *sv = PL_lex_stuff;
2295 PL_lex_stuff = NULL;
2298 if (SvTYPE(sv) == SVt_PVIV) {
2299 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2301 const char * const p = SvPV_const(sv, len);
2302 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2306 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2310 PL_sublex_info.super_state = PL_lex_state;
2311 PL_sublex_info.sub_inwhat = (U16)op_type;
2312 PL_sublex_info.sub_op = PL_lex_op;
2313 PL_lex_state = LEX_INTERPPUSH;
2317 pl_yylval.opval = PL_lex_op;
2327 * Create a new scope to save the lexing state. The scope will be
2328 * ended in S_sublex_done. Returns a '(', starting the function arguments
2329 * to the uc, lc, etc. found before.
2330 * Sets PL_lex_state to LEX_INTERPCONCAT.
2337 const bool is_heredoc = PL_multi_close == '<';
2340 PL_lex_state = PL_sublex_info.super_state;
2341 SAVEI8(PL_lex_dojoin);
2342 SAVEI32(PL_lex_brackets);
2343 SAVEI32(PL_lex_allbrackets);
2344 SAVEI32(PL_lex_formbrack);
2345 SAVEI8(PL_lex_fakeeof);
2346 SAVEI32(PL_lex_casemods);
2347 SAVEI32(PL_lex_starts);
2348 SAVEI8(PL_lex_state);
2349 SAVEI8(PL_lex_defer);
2350 SAVESPTR(PL_lex_repl);
2351 SAVEVPTR(PL_lex_inpat);
2352 SAVEI16(PL_lex_inwhat);
2355 SAVECOPLINE(PL_curcop);
2356 SAVEI32(PL_multi_end);
2357 SAVEI32(PL_parser->herelines);
2358 PL_parser->herelines = 0;
2360 SAVEI8(PL_multi_close);
2361 SAVEPPTR(PL_bufptr);
2362 SAVEPPTR(PL_bufend);
2363 SAVEPPTR(PL_oldbufptr);
2364 SAVEPPTR(PL_oldoldbufptr);
2365 SAVEPPTR(PL_last_lop);
2366 SAVEPPTR(PL_last_uni);
2367 SAVEPPTR(PL_linestart);
2368 SAVESPTR(PL_linestr);
2369 SAVEGENERICPV(PL_lex_brackstack);
2370 SAVEGENERICPV(PL_lex_casestack);
2371 SAVEGENERICPV(PL_parser->lex_shared);
2372 SAVEBOOL(PL_parser->lex_re_reparsing);
2373 SAVEI32(PL_copline);
2375 /* The here-doc parser needs to be able to peek into outer lexing
2376 scopes to find the body of the here-doc. So we put PL_linestr and
2377 PL_bufptr into lex_shared, to ‘share’ those values.
2379 PL_parser->lex_shared->ls_linestr = PL_linestr;
2380 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2382 PL_linestr = PL_lex_stuff;
2383 PL_lex_repl = PL_sublex_info.repl;
2384 PL_lex_stuff = NULL;
2385 PL_sublex_info.repl = NULL;
2387 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2388 set for an inner quote-like operator and then an error causes scope-
2389 popping. We must not have a PL_lex_stuff value left dangling, as
2390 that breaks assumptions elsewhere. See bug #123617. */
2391 SAVEGENERICSV(PL_lex_stuff);
2392 SAVEGENERICSV(PL_sublex_info.repl);
2394 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2395 = SvPVX(PL_linestr);
2396 PL_bufend += SvCUR(PL_linestr);
2397 PL_last_lop = PL_last_uni = NULL;
2398 SAVEFREESV(PL_linestr);
2399 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2401 PL_lex_dojoin = FALSE;
2402 PL_lex_brackets = PL_lex_formbrack = 0;
2403 PL_lex_allbrackets = 0;
2404 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2405 Newx(PL_lex_brackstack, 120, char);
2406 Newx(PL_lex_casestack, 12, char);
2407 PL_lex_casemods = 0;
2408 *PL_lex_casestack = '\0';
2410 PL_lex_state = LEX_INTERPCONCAT;
2412 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2413 PL_copline = NOLINE;
2415 Newxz(shared, 1, LEXSHARED);
2416 shared->ls_prev = PL_parser->lex_shared;
2417 PL_parser->lex_shared = shared;
2419 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2420 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2421 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2422 PL_lex_inpat = PL_sublex_info.sub_op;
2424 PL_lex_inpat = NULL;
2426 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2427 PL_in_eval &= ~EVAL_RE_REPARSING;
2434 * Restores lexer state after a S_sublex_push.
2440 if (!PL_lex_starts++) {
2441 SV * const sv = newSVpvs("");
2442 if (SvUTF8(PL_linestr))
2444 PL_expect = XOPERATOR;
2445 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2449 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2450 PL_lex_state = LEX_INTERPCASEMOD;
2454 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2455 assert(PL_lex_inwhat != OP_TRANSR);
2457 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2458 PL_linestr = PL_lex_repl;
2460 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2461 PL_bufend += SvCUR(PL_linestr);
2462 PL_last_lop = PL_last_uni = NULL;
2463 PL_lex_dojoin = FALSE;
2464 PL_lex_brackets = 0;
2465 PL_lex_allbrackets = 0;
2466 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2467 PL_lex_casemods = 0;
2468 *PL_lex_casestack = '\0';
2470 if (SvEVALED(PL_lex_repl)) {
2471 PL_lex_state = LEX_INTERPNORMAL;
2473 /* we don't clear PL_lex_repl here, so that we can check later
2474 whether this is an evalled subst; that means we rely on the
2475 logic to ensure sublex_done() is called again only via the
2476 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2479 PL_lex_state = LEX_INTERPCONCAT;
2482 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2483 CopLINE(PL_curcop) +=
2484 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2485 + PL_parser->herelines;
2486 PL_parser->herelines = 0;
2491 const line_t l = CopLINE(PL_curcop);
2493 if (PL_multi_close == '<')
2494 PL_parser->herelines += l - PL_multi_end;
2495 PL_bufend = SvPVX(PL_linestr);
2496 PL_bufend += SvCUR(PL_linestr);
2497 PL_expect = XOPERATOR;
2502 PERL_STATIC_INLINE SV*
2503 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2505 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2506 * interior, hence to the "}". Finds what the name resolves to, returning
2507 * an SV* containing it; NULL if no valid one found */
2509 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2516 const U8* first_bad_char_loc;
2517 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2519 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2524 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2526 &first_bad_char_loc))
2528 /* If warnings are on, this will print a more detailed analysis of what
2529 * is wrong than the error message below */
2530 utf8n_to_uvchr(first_bad_char_loc,
2531 e - ((char *) first_bad_char_loc),
2534 /* We deliberately don't try to print the malformed character, which
2535 * might not print very well; it also may be just the first of many
2536 * malformations, so don't print what comes after it */
2537 yyerror_pv(Perl_form(aTHX_
2538 "Malformed UTF-8 character immediately after '%.*s'",
2539 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2544 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2545 /* include the <}> */
2546 e - backslash_ptr + 1);
2548 SvREFCNT_dec_NN(res);
2552 /* See if the charnames handler is the Perl core's, and if so, we can skip
2553 * the validation needed for a user-supplied one, as Perl's does its own
2555 table = GvHV(PL_hintgv); /* ^H */
2556 cvp = hv_fetchs(table, "charnames", FALSE);
2557 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2558 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2560 const char * const name = HvNAME(stash);
2561 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2562 && strEQ(name, "_charnames")) {
2567 /* Here, it isn't Perl's charname handler. We can't rely on a
2568 * user-supplied handler to validate the input name. For non-ut8 input,
2569 * look to see that the first character is legal. Then loop through the
2570 * rest checking that each is a continuation */
2572 /* This code makes the reasonable assumption that the only Latin1-range
2573 * characters that begin a character name alias are alphabetic, otherwise
2574 * would have to create a isCHARNAME_BEGIN macro */
2577 if (! isALPHAU(*s)) {
2582 if (! isCHARNAME_CONT(*s)) {
2585 if (*s == ' ' && *(s-1) == ' ') {
2588 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2589 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2590 "NO-BREAK SPACE in a charnames "
2591 "alias definition is deprecated");
2597 /* Similarly for utf8. For invariants can check directly; for other
2598 * Latin1, can calculate their code point and check; otherwise use a
2600 if (UTF8_IS_INVARIANT(*s)) {
2601 if (! isALPHAU(*s)) {
2605 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2606 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2612 if (! PL_utf8_charname_begin) {
2613 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2614 PL_utf8_charname_begin = _core_swash_init("utf8",
2615 "_Perl_Charname_Begin",
2617 1, 0, NULL, &flags);
2619 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2626 if (UTF8_IS_INVARIANT(*s)) {
2627 if (! isCHARNAME_CONT(*s)) {
2630 if (*s == ' ' && *(s-1) == ' ') {
2635 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2636 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2640 if (*s == *NBSP_UTF8
2641 && *(s+1) == *(NBSP_UTF8+1)
2642 && ckWARN_d(WARN_DEPRECATED))
2644 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2645 "NO-BREAK SPACE in a charnames "
2646 "alias definition is deprecated");
2651 if (! PL_utf8_charname_continue) {
2652 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2653 PL_utf8_charname_continue = _core_swash_init("utf8",
2654 "_Perl_Charname_Continue",
2656 1, 0, NULL, &flags);
2658 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2665 if (*(s-1) == ' ') {
2668 "charnames alias definitions may not contain trailing "
2669 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2670 (int)(s - backslash_ptr + 1), backslash_ptr,
2671 (int)(e - s + 1), s + 1
2673 UTF ? SVf_UTF8 : 0);
2677 if (SvUTF8(res)) { /* Don't accept malformed input */
2678 const U8* first_bad_char_loc;
2680 const char* const str = SvPV_const(res, len);
2681 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2682 /* If warnings are on, this will print a more detailed analysis of
2683 * what is wrong than the error message below */
2684 utf8n_to_uvchr(first_bad_char_loc,
2685 (char *) first_bad_char_loc - str,
2688 /* We deliberately don't try to print the malformed character,
2689 * which might not print very well; it also may be just the first
2690 * of many malformations, so don't print what comes after it */
2693 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2694 (int) (e - backslash_ptr + 1), backslash_ptr,
2695 (int) ((char *) first_bad_char_loc - str), str
2706 /* The final %.*s makes sure that should the trailing NUL be missing
2707 * that this print won't run off the end of the string */
2710 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2711 (int)(s - backslash_ptr + 1), backslash_ptr,
2712 (int)(e - s + 1), s + 1
2714 UTF ? SVf_UTF8 : 0);
2721 "charnames alias definitions may not contain a sequence of "
2722 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2723 (int)(s - backslash_ptr + 1), backslash_ptr,
2724 (int)(e - s + 1), s + 1
2726 UTF ? SVf_UTF8 : 0);
2733 Extracts the next constant part of a pattern, double-quoted string,
2734 or transliteration. This is terrifying code.
2736 For example, in parsing the double-quoted string "ab\x63$d", it would
2737 stop at the '$' and return an OP_CONST containing 'abc'.
2739 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2740 processing a pattern (PL_lex_inpat is true), a transliteration
2741 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2743 Returns a pointer to the character scanned up to. If this is
2744 advanced from the start pointer supplied (i.e. if anything was
2745 successfully parsed), will leave an OP_CONST for the substring scanned
2746 in pl_yylval. Caller must intuit reason for not parsing further
2747 by looking at the next characters herself.
2751 \N{FOO} => \N{U+hex_for_character_FOO}
2752 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2755 all other \-char, including \N and \N{ apart from \N{ABC}
2758 @ and $ where it appears to be a var, but not for $ as tail anchor
2762 In transliterations:
2763 characters are VERY literal, except for - not at the start or end
2764 of the string, which indicates a range. If the range is in bytes,
2765 scan_const expands the range to the full set of intermediate
2766 characters. If the range is in utf8, the hyphen is replaced with
2767 a certain range mark which will be handled by pmtrans() in op.c.
2769 In double-quoted strings:
2771 double-quoted style: \r and \n
2772 constants: \x31, etc.
2773 deprecated backrefs: \1 (in substitution replacements)
2774 case and quoting: \U \Q \E
2777 scan_const does *not* construct ops to handle interpolated strings.
2778 It stops processing as soon as it finds an embedded $ or @ variable
2779 and leaves it to the caller to work out what's going on.
2781 embedded arrays (whether in pattern or not) could be:
2782 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2784 $ in double-quoted strings must be the symbol of an embedded scalar.
2786 $ in pattern could be $foo or could be tail anchor. Assumption:
2787 it's a tail anchor if $ is the last thing in the string, or if it's
2788 followed by one of "()| \r\n\t"
2790 \1 (backreferences) are turned into $1 in substitutions
2792 The structure of the code is
2793 while (there's a character to process) {
2794 handle transliteration ranges
2795 skip regexp comments /(?#comment)/ and codes /(?{code})/
2796 skip #-initiated comments in //x patterns
2797 check for embedded arrays
2798 check for embedded scalars
2800 deprecate \1 in substitution replacements
2801 handle string-changing backslashes \l \U \Q \E, etc.
2802 switch (what was escaped) {
2803 handle \- in a transliteration (becomes a literal -)
2804 if a pattern and not \N{, go treat as regular character
2805 handle \132 (octal characters)
2806 handle \x15 and \x{1234} (hex characters)
2807 handle \N{name} (named characters, also \N{3,5} in a pattern)
2808 handle \cV (control characters)
2809 handle printf-style backslashes (\f, \r, \n, etc)
2812 } (end if backslash)
2813 handle regular character
2814 } (end while character to read)
2819 S_scan_const(pTHX_ char *start)
2821 char *send = PL_bufend; /* end of the constant */
2822 SV *sv = newSV(send - start); /* sv for the constant. See note below
2824 char *s = start; /* start of the constant */
2825 char *d = SvPVX(sv); /* destination for copies */
2826 bool dorange = FALSE; /* are we in a translit range? */
2827 bool didrange = FALSE; /* did we just finish a range? */
2828 bool in_charclass = FALSE; /* within /[...]/ */
2829 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2830 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2831 UTF8? But, this can show as true
2832 when the source isn't utf8, as for
2833 example when it is entirely composed
2835 SV *res; /* result from charnames */
2837 /* Note on sizing: The scanned constant is placed into sv, which is
2838 * initialized by newSV() assuming one byte of output for every byte of
2839 * input. This routine expects newSV() to allocate an extra byte for a
2840 * trailing NUL, which this routine will append if it gets to the end of
2841 * the input. There may be more bytes of input than output (eg., \N{LATIN
2842 * CAPITAL LETTER A}), or more output than input if the constant ends up
2843 * recoded to utf8, but each time a construct is found that might increase
2844 * the needed size, SvGROW() is called. Its size parameter each time is
2845 * based on the best guess estimate at the time, namely the length used so
2846 * far, plus the length the current construct will occupy, plus room for
2847 * the trailing NUL, plus one byte for every input byte still unscanned */
2849 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2852 UV literal_endpoint = 0;
2853 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2856 PERL_ARGS_ASSERT_SCAN_CONST;
2858 assert(PL_lex_inwhat != OP_TRANSR);
2859 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2860 /* If we are doing a trans and we know we want UTF8 set expectation */
2861 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2862 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2865 /* Protect sv from errors and fatal warnings. */
2866 ENTER_with_name("scan_const");
2869 while (s < send || dorange) {
2871 /* get transliterations out of the way (they're most literal) */
2872 if (PL_lex_inwhat == OP_TRANS) {
2873 /* expand a range A-Z to the full set of characters. AIE! */
2875 I32 i; /* current expanded character */
2876 I32 min; /* first character in range */
2877 I32 max; /* last character in range */
2888 char * const c = (char*)utf8_hop((U8*)d, -1);
2892 *c = (char) ILLEGAL_UTF8_BYTE;
2893 /* mark the range as done, and continue */
2899 i = d - SvPVX_const(sv); /* remember current offset */
2902 SvLEN(sv) + ((has_utf8)
2903 ? (512 - UTF_CONTINUATION_MARK
2906 /* How many two-byte within 0..255: 128 in UTF-8,
2907 * 96 in UTF-8-mod. */
2909 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2911 d = SvPVX(sv) + i; /* refresh d after realloc */
2915 for (j = 0; j <= 1; j++) {
2916 char * const c = (char*)utf8_hop((U8*)d, -1);
2917 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2923 max = (U8)0xff; /* only to \xff */
2924 uvmax = uv; /* \x{100} to uvmax */
2926 d = c; /* eat endpoint chars */
2931 d -= 2; /* eat the first char and the - */
2932 min = (U8)*d; /* first char in range */
2933 max = (U8)d[1]; /* last char in range */
2940 "Invalid range \"%c-%c\" in transliteration operator",
2941 (char)min, (char)max);
2945 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2946 * any subsets of these ranges into individual characters */
2947 if (literal_endpoint == 2
2948 && ((isLOWER_A(min) && isLOWER_A(max))
2949 || (isUPPER_A(min) && isUPPER_A(max))))
2951 for (i = min; i <= max; i++) {
2958 for (i = min; i <= max; i++)
2961 append_utf8_from_native_byte(i, &d);
2969 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2971 *d++ = (char) ILLEGAL_UTF8_BYTE;
2973 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2977 /* mark the range as done, and continue */
2981 literal_endpoint = 0;
2986 /* range begins (ignore - as first or last char) */
2987 else if (*s == '-' && s+1 < send && s != start) {
2989 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2996 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
3006 literal_endpoint = 0;
3007 native_range = TRUE;
3012 /* if we get to any of these else's, we're not doing a
3013 * transliteration. */
3015 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3018 while (s1 >= start && *s1-- == '\\')
3021 in_charclass = TRUE;
3024 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3027 while (s1 >= start && *s1-- == '\\')
3030 in_charclass = FALSE;
3033 /* skip for regexp comments /(?#comment)/, except for the last
3034 * char, which will be done separately.
3035 * Stop on (?{..}) and friends */
3037 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3039 while (s+1 < send && *s != ')')
3042 else if (!PL_lex_casemods
3043 && ( s[2] == '{' /* This should match regcomp.c */
3044 || (s[2] == '?' && s[3] == '{')))
3050 /* likewise skip #-initiated comments in //x patterns */
3054 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3056 while (s+1 < send && *s != '\n')
3060 /* no further processing of single-quoted regex */
3061 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3062 goto default_action;
3064 /* check for embedded arrays
3065 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3067 else if (*s == '@' && s[1]) {
3068 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3070 if (strchr(":'{$", s[1]))
3072 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3073 break; /* in regexp, neither @+ nor @- are interpolated */
3076 /* check for embedded scalars. only stop if we're sure it's a
3079 else if (*s == '$') {
3080 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3082 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3084 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3085 "Possible unintended interpolation of $\\ in regex");
3087 break; /* in regexp, $ might be tail anchor */
3091 /* End of else if chain - OP_TRANS rejoin rest */
3094 if (*s == '\\' && s+1 < send) {
3095 char* e; /* Can be used for ending '}', etc. */
3099 /* warn on \1 - \9 in substitution replacements, but note that \11
3100 * is an octal; and \19 is \1 followed by '9' */
3101 if (PL_lex_inwhat == OP_SUBST
3107 /* diag_listed_as: \%d better written as $%d */
3108 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3113 /* string-change backslash escapes */
3114 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3118 /* In a pattern, process \N, but skip any other backslash escapes.
3119 * This is because we don't want to translate an escape sequence
3120 * into a meta symbol and have the regex compiler use the meta
3121 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3122 * in spite of this, we do have to process \N here while the proper
3123 * charnames handler is in scope. See bugs #56444 and #62056.
3125 * There is a complication because \N in a pattern may also stand
3126 * for 'match a non-nl', and not mean a charname, in which case its
3127 * processing should be deferred to the regex compiler. To be a
3128 * charname it must be followed immediately by a '{', and not look
3129 * like \N followed by a curly quantifier, i.e., not something like
3130 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3132 else if (PL_lex_inpat
3135 || regcurly(s + 1)))
3138 goto default_action;
3143 /* quoted - in transliterations */
3145 if (PL_lex_inwhat == OP_TRANS) {
3152 if ((isALPHANUMERIC(*s)))
3153 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3154 "Unrecognized escape \\%c passed through",
3156 /* default action is to copy the quoted character */
3157 goto default_action;
3160 /* eg. \132 indicates the octal constant 0132 */
3161 case '0': case '1': case '2': case '3':
3162 case '4': case '5': case '6': case '7':
3164 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3166 uv = grok_oct(s, &len, &flags, NULL);
3168 if (len < 3 && s < send && isDIGIT(*s)
3169 && ckWARN(WARN_MISC))
3171 Perl_warner(aTHX_ packWARN(WARN_MISC),
3172 "%s", form_short_octal_warning(s, len));
3175 goto NUM_ESCAPE_INSERT;
3177 /* eg. \o{24} indicates the octal constant \024 */
3182 bool valid = grok_bslash_o(&s, &uv, &error,
3183 TRUE, /* Output warning */
3184 FALSE, /* Not strict */
3185 TRUE, /* Output warnings for
3192 goto NUM_ESCAPE_INSERT;
3195 /* eg. \x24 indicates the hex constant 0x24 */
3200 bool valid = grok_bslash_x(&s, &uv, &error,
3201 TRUE, /* Output warning */
3202 FALSE, /* Not strict */
3203 TRUE, /* Output warnings for
3213 /* Insert oct or hex escaped character. There will always be
3214 * enough room in sv since such escapes will be longer than any
3215 * UTF-8 sequence they can end up as, except if they force us
3216 * to recode the rest of the string into utf8 */
3218 /* Here uv is the ordinal of the next character being added */
3219 if (!UVCHR_IS_INVARIANT(uv)) {
3220 if (!has_utf8 && uv > 255) {
3221 /* Might need to recode whatever we have accumulated so
3222 * far if it contains any chars variant in utf8 or
3225 SvCUR_set(sv, d - SvPVX_const(sv));
3228 /* See Note on sizing above. */
3229 sv_utf8_upgrade_flags_grow(
3231 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3232 /* Above-latin1 in string
3233 * implies no encoding */
3234 |SV_UTF8_NO_ENCODING,
3235 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3236 d = SvPVX(sv) + SvCUR(sv);
3241 d = (char*)uvchr_to_utf8((U8*)d, uv);
3242 if (PL_lex_inwhat == OP_TRANS
3243 && PL_sublex_info.sub_op)
3245 PL_sublex_info.sub_op->op_private |=
3246 (PL_lex_repl ? OPpTRANS_FROM_UTF
3250 if (uv > 255 && !dorange)
3251 native_range = FALSE;
3264 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3265 * named character, like \N{LATIN SMALL LETTER A}, or a named
3266 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3267 * GRAVE}. For convenience all three forms are referred to as
3268 * "named characters" below.
3270 * For patterns, \N also can mean to match a non-newline. Code
3271 * before this 'switch' statement should already have handled
3272 * this situation, and hence this code only has to deal with
3273 * the named character cases.
3275 * For non-patterns, the named characters are converted to
3276 * their string equivalents. In patterns, named characters are
3277 * not converted to their ultimate forms for the same reasons
3278 * that other escapes aren't. Instead, they are converted to
3279 * the \N{U+...} form to get the value from the charnames that
3280 * is in effect right now, while preserving the fact that it
3281 * was a named character, so that the regex compiler knows
3284 * The structure of this section of code (besides checking for
3285 * errors and upgrading to utf8) is:
3286 * If the named character is of the form \N{U+...}, pass it
3287 * through if a pattern; otherwise convert the code point
3289 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3290 * if a pattern; otherwise convert to utf8
3292 * Here, 's' points to the 'N'; the test below is guaranteed to
3293 * succeed if we are being called on a pattern, as we already
3294 * know from a test above that the next character is a '{'. A
3295 * non-pattern \N must mean 'named character', which requires
3299 yyerror("Missing braces on \\N{}");
3304 /* If there is no matching '}', it is an error. */
3305 if (! (e = strchr(s, '}'))) {
3306 if (! PL_lex_inpat) {
3307 yyerror("Missing right brace on \\N{}");
3309 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3314 /* Here it looks like a named character */
3316 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3317 s += 2; /* Skip to next char after the 'U+' */
3320 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3321 /* Check the syntax. */
3324 if (!isXDIGIT(*s)) {
3327 "Invalid hexadecimal number in \\N{U+...}"
3335 else if ((*s == '.' || *s == '_')
3341 /* Pass everything through unchanged.
3342 * +1 is for the '}' */
3343 Copy(orig_s, d, e - orig_s + 1, char);
3344 d += e - orig_s + 1;
3346 else { /* Not a pattern: convert the hex to string */
3347 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3348 | PERL_SCAN_SILENT_ILLDIGIT
3349 | PERL_SCAN_DISALLOW_PREFIX;
3351 uv = grok_hex(s, &len, &flags, NULL);
3352 if (len == 0 || (len != (STRLEN)(e - s)))
3355 /* If the destination is not in utf8, unconditionally
3356 * recode it to be so. This is because \N{} implies
3357 * Unicode semantics, and scalars have to be in utf8
3358 * to guarantee those semantics */
3360 SvCUR_set(sv, d - SvPVX_const(sv));
3363 /* See Note on sizing above. */
3364 sv_utf8_upgrade_flags_grow(
3366 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3367 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3368 d = SvPVX(sv) + SvCUR(sv);
3372 /* Add the (Unicode) code point to the output. */
3373 if (UNI_IS_INVARIANT(uv)) {
3374 *d++ = (char) LATIN1_TO_NATIVE(uv);
3377 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3381 else /* Here is \N{NAME} but not \N{U+...}. */
3382 if ((res = get_and_check_backslash_N_name(s, e)))
3385 const char *str = SvPV_const(res, len);
3388 if (! len) { /* The name resolved to an empty string */
3389 Copy("\\N{}", d, 4, char);
3393 /* In order to not lose information for the regex
3394 * compiler, pass the result in the specially made
3395 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3396 * the code points in hex of each character
3397 * returned by charnames */
3399 const char *str_end = str + len;
3400 const STRLEN off = d - SvPVX_const(sv);
3402 if (! SvUTF8(res)) {
3403 /* For the non-UTF-8 case, we can determine the
3404 * exact length needed without having to parse
3405 * through the string. Each character takes up
3406 * 2 hex digits plus either a trailing dot or
3408 const char initial_text[] = "\\N{U+";
3409 const STRLEN initial_len = sizeof(initial_text)
3411 d = off + SvGROW(sv, off
3414 /* +1 for trailing NUL */
3417 + (STRLEN)(send - e));
3418 Copy(initial_text, d, initial_len, char);
3420 while (str < str_end) {
3423 my_snprintf(hex_string,
3427 /* The regex compiler is
3428 * expecting Unicode, not
3430 (U8) NATIVE_TO_LATIN1(*str));
3431 PERL_MY_SNPRINTF_POST_GUARD(len,
3432 sizeof(hex_string));
3433 Copy(hex_string, d, 3, char);
3437 d--; /* Below, we will overwrite the final
3438 dot with a right brace */
3441 STRLEN char_length; /* cur char's byte length */
3443 /* and the number of bytes after this is
3444 * translated into hex digits */
3445 STRLEN output_length;
3447 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3448 * for max('U+', '.'); and 1 for NUL */
3449 char hex_string[2 * UTF8_MAXBYTES + 5];
3451 /* Get the first character of the result. */
3452 U32 uv = utf8n_to_uvchr((U8 *) str,
3456 /* Convert first code point to Unicode hex,
3457 * including the boiler plate before it. */
3459 my_snprintf(hex_string, sizeof(hex_string),
3461 (unsigned int) NATIVE_TO_UNI(uv));
3463 /* Make sure there is enough space to hold it */
3464 d = off + SvGROW(sv, off
3466 + (STRLEN)(send - e)
3467 + 2); /* '}' + NUL */
3469 Copy(hex_string, d, output_length, char);
3472 /* For each subsequent character, append dot and
3473 * its Unicode code point in hex */
3474 while ((str += char_length) < str_end) {
3475 const STRLEN off = d - SvPVX_const(sv);
3476 U32 uv = utf8n_to_uvchr((U8 *) str,
3481 my_snprintf(hex_string,
3484 (unsigned int) NATIVE_TO_UNI(uv));
3486 d = off + SvGROW(sv, off
3488 + (STRLEN)(send - e)
3489 + 2); /* '}' + NUL */
3490 Copy(hex_string, d, output_length, char);
3495 *d++ = '}'; /* Done. Add the trailing brace */
3498 else { /* Here, not in a pattern. Convert the name to a
3501 /* If destination is not in utf8, unconditionally
3502 * recode it to be so. This is because \N{} implies
3503 * Unicode semantics, and scalars have to be in utf8
3504 * to guarantee those semantics */
3506 SvCUR_set(sv, d - SvPVX_const(sv));
3509 /* See Note on sizing above. */
3510 sv_utf8_upgrade_flags_grow(sv,
3511 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3512 len + (STRLEN)(send - s) + 1);
3513 d = SvPVX(sv) + SvCUR(sv);
3515 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3517 /* See Note on sizing above. (NOTE: SvCUR() is not
3518 * set correctly here). */
3519 const STRLEN off = d - SvPVX_const(sv);
3520 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3522 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3523 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3524 str = SvPV_const(res, len);
3526 Copy(str, d, len, char);
3532 } /* End \N{NAME} */
3535 native_range = FALSE; /* \N{} is defined to be Unicode */
3537 s = e + 1; /* Point to just after the '}' */
3540 /* \c is a control character */
3544 *d++ = grok_bslash_c(*s++, 1);
3547 yyerror("Missing control char name in \\c");
3551 /* printf-style backslashes, formfeeds, newlines, etc */
3577 } /* end if (backslash) */
3584 /* If we started with encoded form, or already know we want it,
3585 then encode the next character */
3586 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3590 /* One might think that it is wasted effort in the case of the
3591 * source being utf8 (this_utf8 == TRUE) to take the next character
3592 * in the source, convert it to an unsigned value, and then convert
3593 * it back again. But the source has not been validated here. The
3594 * routine that does the conversion checks for errors like
3597 const UV nextuv = (this_utf8)
3598 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3600 const STRLEN need = UNISKIP(nextuv);
3602 SvCUR_set(sv, d - SvPVX_const(sv));
3605 /* See Note on sizing above. */
3606 sv_utf8_upgrade_flags_grow(sv,
3607 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3608 need + (STRLEN)(send - s) + 1);
3609 d = SvPVX(sv) + SvCUR(sv);
3611 } else if (need > len) {
3612 /* encoded value larger than old, may need extra space (NOTE:
3613 * SvCUR() is not set correctly here). See Note on sizing
3615 const STRLEN off = d - SvPVX_const(sv);
3616 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3620 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3622 if (uv > 255 && !dorange)
3623 native_range = FALSE;
3629 } /* while loop to process each character */
3631 /* terminate the string and set up the sv */
3633 SvCUR_set(sv, d - SvPVX_const(sv));
3634 if (SvCUR(sv) >= SvLEN(sv))
3635 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3636 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3639 if (IN_ENCODING && !has_utf8) {
3640 sv_recode_to_utf8(sv, _get_encoding());
3646 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3647 PL_sublex_info.sub_op->op_private |=
3648 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3652 /* shrink the sv if we allocated more than we used */
3653 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3654 SvPV_shrink_to_cur(sv);
3657 /* return the substring (via pl_yylval) only if we parsed anything */
3660 for (; s2 < s; s2++) {
3662 COPLINE_INC_WITH_HERELINES;
3664 SvREFCNT_inc_simple_void_NN(sv);
3665 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3666 && ! PL_parser->lex_re_reparsing)
3668 const char *const key = PL_lex_inpat ? "qr" : "q";
3669 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3673 if (PL_lex_inwhat == OP_TRANS) {
3676 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3679 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3687 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3690 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3692 LEAVE_with_name("scan_const");
3697 * Returns TRUE if there's more to the expression (e.g., a subscript),
3700 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3702 * ->[ and ->{ return TRUE
3703 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3704 * { and [ outside a pattern are always subscripts, so return TRUE
3705 * if we're outside a pattern and it's not { or [, then return FALSE
3706 * if we're in a pattern and the first char is a {
3707 * {4,5} (any digits around the comma) returns FALSE
3708 * if we're in a pattern and the first char is a [
3710 * [SOMETHING] has a funky algorithm to decide whether it's a
3711 * character class or not. It has to deal with things like
3712 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3713 * anything else returns TRUE
3716 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3719 S_intuit_more(pTHX_ char *s)
3721 PERL_ARGS_ASSERT_INTUIT_MORE;
3723 if (PL_lex_brackets)
3725 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3727 if (*s == '-' && s[1] == '>'
3728 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3729 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3730 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3732 if (*s != '{' && *s != '[')
3737 /* In a pattern, so maybe we have {n,m}. */
3745 /* On the other hand, maybe we have a character class */
3748 if (*s == ']' || *s == '^')
3751 /* this is terrifying, and it works */
3754 const char * const send = strchr(s,']');
3755 unsigned char un_char, last_un_char;
3756 char tmpbuf[sizeof PL_tokenbuf * 4];
3758 if (!send) /* has to be an expression */
3760 weight = 2; /* let's weigh the evidence */
3764 else if (isDIGIT(*s)) {
3766 if (isDIGIT(s[1]) && s[2] == ']')
3772 Zero(seen,256,char);
3774 for (; s < send; s++) {
3775 last_un_char = un_char;
3776 un_char = (unsigned char)*s;
3781 weight -= seen[un_char] * 10;
3782 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3784 char *tmp = PL_bufend;
3785 PL_bufend = (char*)send;
3786 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3788 len = (int)strlen(tmpbuf);
3789 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3790 UTF ? SVf_UTF8 : 0, SVt_PV))
3797 && strchr("[#!%*<>()-=",s[1]))
3799 if (/*{*/ strchr("])} =",s[2]))
3808 if (strchr("wds]",s[1]))
3810 else if (seen[(U8)'\''] || seen[(U8)'"'])
3812 else if (strchr("rnftbxcav",s[1]))
3814 else if (isDIGIT(s[1])) {
3816 while (s[1] && isDIGIT(s[1]))
3826 if (strchr("aA01! ",last_un_char))
3828 if (strchr("zZ79~",s[1]))
3830 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3831 weight -= 5; /* cope with negative subscript */
3834 if (!isWORDCHAR(last_un_char)
3835 && !(last_un_char == '$' || last_un_char == '@'
3836 || last_un_char == '&')
3837 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3841 if (keyword(d, s - d, 0))
3844 if (un_char == last_un_char + 1)
3846 weight -= seen[un_char];
3851 if (weight >= 0) /* probably a character class */
3861 * Does all the checking to disambiguate
3863 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3864 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3866 * First argument is the stuff after the first token, e.g. "bar".
3868 * Not a method if foo is a filehandle.
3869 * Not a method if foo is a subroutine prototyped to take a filehandle.
3870 * Not a method if it's really "Foo $bar"
3871 * Method if it's "foo $bar"
3872 * Not a method if it's really "print foo $bar"
3873 * Method if it's really "foo package::" (interpreted as package->foo)
3874 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3875 * Not a method if bar is a filehandle or package, but is quoted with
3880 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3882 char *s = start + (*start == '$');
3883 char tmpbuf[sizeof PL_tokenbuf];
3886 /* Mustn't actually add anything to a symbol table.
3887 But also don't want to "initialise" any placeholder
3888 constants that might already be there into full
3889 blown PVGVs with attached PVCV. */
3891 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3893 PERL_ARGS_ASSERT_INTUIT_METHOD;
3895 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3897 if (cv && SvPOK(cv)) {
3898 const char *proto = CvPROTO(cv);
3900 while (*proto && (isSPACE(*proto) || *proto == ';'))
3907 if (*start == '$') {
3908 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
3909 || isUPPER(*PL_tokenbuf))
3914 return *s == '(' ? FUNCMETH : METHOD;
3917 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3918 /* start is the beginning of the possible filehandle/object,
3919 * and s is the end of it
3920 * tmpbuf is a copy of it (but with single quotes as double colons)
3923 if (!keyword(tmpbuf, len, 0)) {
3924 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3929 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3930 if (indirgv && GvCVu(indirgv))
3932 /* filehandle or package name makes it a method */
3933 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3935 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3936 return 0; /* no assumptions -- "=>" quotes bareword */
3938 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3939 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3940 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3944 return *s == '(' ? FUNCMETH : METHOD;
3950 /* Encoded script support. filter_add() effectively inserts a
3951 * 'pre-processing' function into the current source input stream.
3952 * Note that the filter function only applies to the current source file
3953 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3955 * The datasv parameter (which may be NULL) can be used to pass
3956 * private data to this instance of the filter. The filter function
3957 * can recover the SV using the FILTER_DATA macro and use it to
3958 * store private buffers and state information.
3960 * The supplied datasv parameter is upgraded to a PVIO type
3961 * and the IoDIRP/IoANY field is used to store the function pointer,
3962 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3963 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3964 * private use must be set using malloc'd pointers.
3968 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3976 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3977 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3979 if (!PL_rsfp_filters)
3980 PL_rsfp_filters = newAV();
3983 SvUPGRADE(datasv, SVt_PVIO);
3984 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3985 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3986 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3987 FPTR2DPTR(void *, IoANY(datasv)),
3988 SvPV_nolen(datasv)));
3989 av_unshift(PL_rsfp_filters, 1);
3990 av_store(PL_rsfp_filters, 0, datasv) ;
3992 !PL_parser->filtered
3993 && PL_parser->lex_flags & LEX_EVALBYTES
3994 && PL_bufptr < PL_bufend
3996 const char *s = PL_bufptr;
3997 while (s < PL_bufend) {
3999 SV *linestr = PL_parser->linestr;
4000 char *buf = SvPVX(linestr);
4001 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4002 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4003 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4004 STRLEN const linestart_pos = PL_parser->linestart - buf;
4005 STRLEN const last_uni_pos =
4006 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4007 STRLEN const last_lop_pos =
4008 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4009 av_push(PL_rsfp_filters, linestr);
4010 PL_parser->linestr =
4011 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4012 buf = SvPVX(PL_parser->linestr);
4013 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4014 PL_parser->bufptr = buf + bufptr_pos;
4015 PL_parser->oldbufptr = buf + oldbufptr_pos;
4016 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4017 PL_parser->linestart = buf + linestart_pos;
4018 if (PL_parser->last_uni)
4019 PL_parser->last_uni = buf + last_uni_pos;
4020 if (PL_parser->last_lop)
4021 PL_parser->last_lop = buf + last_lop_pos;
4022 SvLEN(linestr) = SvCUR(linestr);
4023 SvCUR(linestr) = s-SvPVX(linestr);
4024 PL_parser->filtered = 1;
4034 /* Delete most recently added instance of this filter function. */
4036 Perl_filter_del(pTHX_ filter_t funcp)
4040 PERL_ARGS_ASSERT_FILTER_DEL;
4043 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4044 FPTR2DPTR(void*, funcp)));
4046 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4048 /* if filter is on top of stack (usual case) just pop it off */
4049 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4050 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4051 sv_free(av_pop(PL_rsfp_filters));
4055 /* we need to search for the correct entry and clear it */
4056 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4060 /* Invoke the idxth filter function for the current rsfp. */
4061 /* maxlen 0 = read one text line */
4063 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4067 /* This API is bad. It should have been using unsigned int for maxlen.
4068 Not sure if we want to change the API, but if not we should sanity
4069 check the value here. */
4070 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4072 PERL_ARGS_ASSERT_FILTER_READ;
4074 if (!PL_parser || !PL_rsfp_filters)
4076 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4077 /* Provide a default input filter to make life easy. */
4078 /* Note that we append to the line. This is handy. */
4079 DEBUG_P(PerlIO_printf(Perl_debug_log,
4080 "filter_read %d: from rsfp\n", idx));
4081 if (correct_length) {
4084 const int old_len = SvCUR(buf_sv);
4086 /* ensure buf_sv is large enough */
4087 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4088 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4089 correct_length)) <= 0) {
4090 if (PerlIO_error(PL_rsfp))
4091 return -1; /* error */
4093 return 0 ; /* end of file */
4095 SvCUR_set(buf_sv, old_len + len) ;
4096 SvPVX(buf_sv)[old_len + len] = '\0';
4099 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4100 if (PerlIO_error(PL_rsfp))
4101 return -1; /* error */
4103 return 0 ; /* end of file */
4106 return SvCUR(buf_sv);
4108 /* Skip this filter slot if filter has been deleted */
4109 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4110 DEBUG_P(PerlIO_printf(Perl_debug_log,
4111 "filter_read %d: skipped (filter deleted)\n",
4113 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4115 if (SvTYPE(datasv) != SVt_PVIO) {
4116 if (correct_length) {
4118 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4119 if (!remainder) return 0; /* eof */
4120 if (correct_length > remainder) correct_length = remainder;
4121 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4122 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4125 const char *s = SvEND(datasv);
4126 const char *send = SvPVX(datasv) + SvLEN(datasv);
4134 if (s == send) return 0; /* eof */
4135 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4136 SvCUR_set(datasv, s-SvPVX(datasv));
4138 return SvCUR(buf_sv);
4140 /* Get function pointer hidden within datasv */
4141 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4142 DEBUG_P(PerlIO_printf(Perl_debug_log,
4143 "filter_read %d: via function %p (%s)\n",
4144 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4145 /* Call function. The function is expected to */
4146 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4147 /* Return: <0:error, =0:eof, >0:not eof */
4148 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4152 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4154 PERL_ARGS_ASSERT_FILTER_GETS;
4156 #ifdef PERL_CR_FILTER
4157 if (!PL_rsfp_filters) {
4158 filter_add(S_cr_textfilter,NULL);
4161 if (PL_rsfp_filters) {
4163 SvCUR_set(sv, 0); /* start with empty line */
4164 if (FILTER_READ(0, sv, 0) > 0)
4165 return ( SvPVX(sv) ) ;
4170 return (sv_gets(sv, PL_rsfp, append));
4174 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4178 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4180 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4184 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4185 && (gv = gv_fetchpvn_flags(pkgname,
4187 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4189 return GvHV(gv); /* Foo:: */
4192 /* use constant CLASS => 'MyClass' */
4193 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4194 if (gv && GvCV(gv)) {
4195 SV * const sv = cv_const_sv(GvCV(gv));
4197 return gv_stashsv(sv, 0);
4200 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4205 S_tokenize_use(pTHX_ int is_use, char *s) {
4206 PERL_ARGS_ASSERT_TOKENIZE_USE;
4208 if (PL_expect != XSTATE)
4209 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4210 is_use ? "use" : "no"));
4213 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4214 s = force_version(s, TRUE);
4215 if (*s == ';' || *s == '}'
4216 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4217 NEXTVAL_NEXTTOKE.opval = NULL;
4220 else if (*s == 'v') {
4221 s = force_word(s,WORD,FALSE,TRUE);
4222 s = force_version(s, FALSE);
4226 s = force_word(s,WORD,FALSE,TRUE);
4227 s = force_version(s, FALSE);
4229 pl_yylval.ival = is_use;
4233 static const char* const exp_name[] =
4234 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4235 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4240 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4242 S_word_takes_any_delimeter(char *p, STRLEN len)
4244 return (len == 1 && strchr("msyq", p[0]))
4246 && ((p[0] == 't' && p[1] == 'r')
4247 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4251 S_check_scalar_slice(pTHX_ char *s)
4254 while (*s == ' ' || *s == '\t') s++;
4255 if (*s == 'q' && s[1] == 'w'
4256 && !isWORDCHAR_lazy_if(s+2,UTF))
4258 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4259 s += UTF ? UTF8SKIP(s) : 1;
4260 if (*s == '}' || *s == ']')
4261 pl_yylval.ival = OPpSLICEWARNING;
4267 Works out what to call the token just pulled out of the input
4268 stream. The yacc parser takes care of taking the ops we return and
4269 stitching them into a tree.
4272 The type of the next token
4275 Switch based on the current state:
4276 - if we already built the token before, use it
4277 - if we have a case modifier in a string, deal with that
4278 - handle other cases of interpolation inside a string
4279 - scan the next line if we are inside a format
4280 In the normal state switch on the next character:
4282 if alphabetic, go to key lookup
4283 unrecoginized character - croak
4284 - 0/4/26: handle end-of-line or EOF
4285 - cases for whitespace
4286 - \n and #: handle comments and line numbers
4287 - various operators, brackets and sigils
4290 - 'v': vstrings (or go to key lookup)
4291 - 'x' repetition operator (or go to key lookup)
4292 - other ASCII alphanumerics (key lookup begins here):
4295 scan built-in keyword (but do nothing with it yet)
4296 check for statement label
4297 check for lexical subs
4298 goto just_a_word if there is one
4299 see whether built-in keyword is overridden
4300 switch on keyword number:
4301 - default: just_a_word:
4302 not a built-in keyword; handle bareword lookup
4303 disambiguate between method and sub call
4304 fall back to bareword
4305 - cases for built-in keywords
4313 char *s = PL_bufptr;
4317 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4321 /* orig_keyword, gvp, and gv are initialized here because
4322 * jump to the label just_a_word_zero can bypass their
4323 * initialization later. */
4324 I32 orig_keyword = 0;
4329 SV* tmp = newSVpvs("");
4330 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4331 (IV)CopLINE(PL_curcop),
4332 lex_state_names[PL_lex_state],
4333 exp_name[PL_expect],
4334 pv_display(tmp, s, strlen(s), 0, 60));
4338 /* when we've already built the next token, just pull it out of the queue */
4341 pl_yylval = PL_nextval[PL_nexttoke];
4343 PL_lex_state = PL_lex_defer;
4344 PL_lex_defer = LEX_NORMAL;
4348 next_type = PL_nexttype[PL_nexttoke];
4349 if (next_type & (7<<24)) {
4350 if (next_type & (1<<24)) {
4351 if (PL_lex_brackets > 100)
4352 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4353 PL_lex_brackstack[PL_lex_brackets++] =
4354 (char) ((next_type >> 16) & 0xff);
4356 if (next_type & (2<<24))
4357 PL_lex_allbrackets++;
4358 if (next_type & (4<<24))
4359 PL_lex_allbrackets--;
4360 next_type &= 0xffff;
4362 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4366 switch (PL_lex_state) {
4368 case LEX_INTERPNORMAL:
4371 /* interpolated case modifiers like \L \U, including \Q and \E.
4372 when we get here, PL_bufptr is at the \
4374 case LEX_INTERPCASEMOD:
4376 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4378 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4379 PL_bufptr, PL_bufend, *PL_bufptr);
4381 /* handle \E or end of string */
4382 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4384 if (PL_lex_casemods) {
4385 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4386 PL_lex_casestack[PL_lex_casemods] = '\0';
4388 if (PL_bufptr != PL_bufend
4389 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4390 || oldmod == 'F')) {
4392 PL_lex_state = LEX_INTERPCONCAT;
4394 PL_lex_allbrackets--;
4397 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4398 /* Got an unpaired \E */
4399 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4400 "Useless use of \\E");
4402 if (PL_bufptr != PL_bufend)
4404 PL_lex_state = LEX_INTERPCONCAT;
4408 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4409 "### Saw case modifier\n"); });
4411 if (s[1] == '\\' && s[2] == 'E') {
4413 PL_lex_state = LEX_INTERPCONCAT;
4418 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4419 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4420 if ((*s == 'L' || *s == 'U' || *s == 'F')
4421 && (strchr(PL_lex_casestack, 'L')
4422 || strchr(PL_lex_casestack, 'U')
4423 || strchr(PL_lex_casestack, 'F')))
4425 PL_lex_casestack[--PL_lex_casemods] = '\0';
4426 PL_lex_allbrackets--;
4429 if (PL_lex_casemods > 10)
4430 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4431 PL_lex_casestack[PL_lex_casemods++] = *s;
4432 PL_lex_casestack[PL_lex_casemods] = '\0';
4433 PL_lex_state = LEX_INTERPCONCAT;
4434 NEXTVAL_NEXTTOKE.ival = 0;
4435 force_next((2<<24)|'(');
4437 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4439 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4441 NEXTVAL_NEXTTOKE.ival = OP_LC;
4443 NEXTVAL_NEXTTOKE.ival = OP_UC;
4445 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4447 NEXTVAL_NEXTTOKE.ival = OP_FC;
4449 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4453 if (PL_lex_starts) {
4456 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4457 if (PL_lex_casemods == 1 && PL_lex_inpat)
4460 AopNOASSIGN(OP_CONCAT);
4466 case LEX_INTERPPUSH:
4467 return REPORT(sublex_push());
4469 case LEX_INTERPSTART:
4470 if (PL_bufptr == PL_bufend)
4471 return REPORT(sublex_done());
4472 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4473 "### Interpolated variable\n"); });
4475 /* for /@a/, we leave the joining for the regex engine to do
4476 * (unless we're within \Q etc) */
4477 PL_lex_dojoin = (*PL_bufptr == '@'
4478 && (!PL_lex_inpat || PL_lex_casemods));
4479 PL_lex_state = LEX_INTERPNORMAL;
4480 if (PL_lex_dojoin) {
4481 NEXTVAL_NEXTTOKE.ival = 0;
4483 force_ident("\"", '$');
4484 NEXTVAL_NEXTTOKE.ival = 0;
4486 NEXTVAL_NEXTTOKE.ival = 0;
4487 force_next((2<<24)|'(');
4488 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4491 /* Convert (?{...}) and friends to 'do {...}' */
4492 if (PL_lex_inpat && *PL_bufptr == '(') {
4493 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4495 if (*PL_bufptr != '{')
4497 PL_expect = XTERMBLOCK;
4501 if (PL_lex_starts++) {
4503 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4504 if (!PL_lex_casemods && PL_lex_inpat)
4507 AopNOASSIGN(OP_CONCAT);
4511 case LEX_INTERPENDMAYBE:
4512 if (intuit_more(PL_bufptr)) {
4513 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4519 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4520 XXX This hack can be removed if we stop setting PL_lex_state to
4521 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4522 if (UNLIKELY(!PL_lex_inwhat)) {
4523 PL_lex_state = LEX_NORMAL;
4527 if (PL_lex_dojoin) {
4528 const U8 dojoin_was = PL_lex_dojoin;
4529 PL_lex_dojoin = FALSE;
4530 PL_lex_state = LEX_INTERPCONCAT;
4531 PL_lex_allbrackets--;
4532 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4534 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4535 && SvEVALED(PL_lex_repl))
4537 if (PL_bufptr != PL_bufend)
4538 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4541 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4542 re_eval_str. If the here-doc body’s length equals the previous
4543 value of re_eval_start, re_eval_start will now be null. So
4544 check re_eval_str as well. */
4545 if (PL_parser->lex_shared->re_eval_start
4546 || PL_parser->lex_shared->re_eval_str) {
4548 if (*PL_bufptr != ')')
4549 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4551 /* having compiled a (?{..}) expression, return the original
4552 * text too, as a const */
4553 if (PL_parser->lex_shared->re_eval_str) {
4554 sv = PL_parser->lex_shared->re_eval_str;
4555 PL_parser->lex_shared->re_eval_str = NULL;
4557 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4558 SvPV_shrink_to_cur(sv);
4560 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4561 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4562 NEXTVAL_NEXTTOKE.opval =
4563 (OP*)newSVOP(OP_CONST, 0,
4566 PL_parser->lex_shared->re_eval_start = NULL;
4572 case LEX_INTERPCONCAT:
4574 if (PL_lex_brackets)
4575 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4576 (long) PL_lex_brackets);
4578 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4579 XXX This hack can be removed if we stop setting PL_lex_state to
4581 if (UNLIKELY(!PL_lex_inwhat)) {
4582 PL_lex_state = LEX_NORMAL;
4586 if (PL_bufptr == PL_bufend)
4587 return REPORT(sublex_done());
4589 /* m'foo' still needs to be parsed for possible (?{...}) */
4590 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4591 SV *sv = newSVsv(PL_linestr);
4593 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4597 s = scan_const(PL_bufptr);
4599 PL_lex_state = LEX_INTERPCASEMOD;
4601 PL_lex_state = LEX_INTERPSTART;
4604 if (s != PL_bufptr) {
4605 NEXTVAL_NEXTTOKE = pl_yylval;
4608 if (PL_lex_starts++) {
4609 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4610 if (!PL_lex_casemods && PL_lex_inpat)
4613 AopNOASSIGN(OP_CONCAT);
4623 s = scan_formline(PL_bufptr);
4624 if (!PL_lex_formbrack)
4633 /* We really do *not* want PL_linestr ever becoming a COW. */
4634 assert (!SvIsCOW(PL_linestr));
4636 PL_oldoldbufptr = PL_oldbufptr;
4638 PL_parser->saw_infix_sigil = 0;
4643 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4646 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4647 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4649 SVs_TEMP | SVf_UTF8),
4650 10, UNI_DISPLAY_ISPRINT)
4651 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4652 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4653 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4654 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4658 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4659 UTF8fARG(UTF, (s - d), d),
4664 goto fake_eof; /* emulate EOF on ^D or ^Z */
4666 if ((!PL_rsfp || PL_lex_inwhat)
4667 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4671 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
4673 yyerror((const char *)
4675 ? "Format not terminated"
4676 : "Missing right curly or square bracket"));
4678 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4679 "### Tokener got EOF\n");
4683 if (s++ < PL_bufend)
4684 goto retry; /* ignore stray nulls */
4687 if (!PL_in_eval && !PL_preambled) {
4688 PL_preambled = TRUE;
4690 /* Generate a string of Perl code to load the debugger.
4691 * If PERL5DB is set, it will return the contents of that,
4692 * otherwise a compile-time require of perl5db.pl. */
4694 const char * const pdb = PerlEnv_getenv("PERL5DB");
4697 sv_setpv(PL_linestr, pdb);
4698 sv_catpvs(PL_linestr,";");
4700 SETERRNO(0,SS_NORMAL);
4701 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4703 PL_parser->preambling = CopLINE(PL_curcop);
4705 sv_setpvs(PL_linestr,"");
4706 if (PL_preambleav) {
4707 SV **svp = AvARRAY(PL_preambleav);
4708 SV **const end = svp + AvFILLp(PL_preambleav);
4710 sv_catsv(PL_linestr, *svp);
4712 sv_catpvs(PL_linestr, ";");
4714 sv_free(MUTABLE_SV(PL_preambleav));
4715 PL_preambleav = NULL;
4718 sv_catpvs(PL_linestr,
4719 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4720 if (PL_minus_n || PL_minus_p) {
4721 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4723 sv_catpvs(PL_linestr,"chomp;");
4726 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4727 || *PL_splitstr == '"')
4728 && strchr(PL_splitstr + 1, *PL_splitstr))
4729 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4731 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4732 bytes can be used as quoting characters. :-) */
4733 const char *splits = PL_splitstr;
4734 sv_catpvs(PL_linestr, "our @F=split(q\0");
4737 if (*splits == '\\')
4738 sv_catpvn(PL_linestr, splits, 1);
4739 sv_catpvn(PL_linestr, splits, 1);
4740 } while (*splits++);
4741 /* This loop will embed the trailing NUL of
4742 PL_linestr as the last thing it does before
4744 sv_catpvs(PL_linestr, ");");
4748 sv_catpvs(PL_linestr,"our @F=split(' ');");
4751 sv_catpvs(PL_linestr, "\n");
4752 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4753 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4754 PL_last_lop = PL_last_uni = NULL;
4755 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4756 update_debugger_info(PL_linestr, NULL, 0);
4761 bof = PL_rsfp ? TRUE : FALSE;
4764 fake_eof = LEX_FAKE_EOF;
4766 PL_bufptr = PL_bufend;
4767 COPLINE_INC_WITH_HERELINES;
4768 if (!lex_next_chunk(fake_eof)) {
4769 CopLINE_dec(PL_curcop);
4771 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4773 CopLINE_dec(PL_curcop);
4775 /* If it looks like the start of a BOM or raw UTF-16,
4776 * check if it in fact is. */
4779 || *(U8*)s == BOM_UTF8_FIRST_BYTE
4783 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4784 bof = (offset == (Off_t)SvCUR(PL_linestr));
4785 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4786 /* offset may include swallowed CR */
4788 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4791 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4792 s = swallow_bom((U8*)s);
4795 if (PL_parser->in_pod) {
4796 /* Incest with pod. */
4797 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4798 sv_setpvs(PL_linestr, "");
4799 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4800 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4801 PL_last_lop = PL_last_uni = NULL;
4802 PL_parser->in_pod = 0;
4805 if (PL_rsfp || PL_parser->filtered)
4807 } while (PL_parser->in_pod);
4808 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4809 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4810 PL_last_lop = PL_last_uni = NULL;
4811 if (CopLINE(PL_curcop) == 1) {
4812 while (s < PL_bufend && isSPACE(*s))
4814 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4818 if (*s == '#' && *(s+1) == '!')
4820 #ifdef ALTERNATE_SHEBANG
4822 static char const as[] = ALTERNATE_SHEBANG;
4823 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4824 d = s + (sizeof(as) - 1);
4826 #endif /* ALTERNATE_SHEBANG */
4835 while (*d && !isSPACE(*d))
4839 #ifdef ARG_ZERO_IS_SCRIPT
4840 if (ipathend > ipath) {
4842 * HP-UX (at least) sets argv[0] to the script name,
4843 * which makes $^X incorrect. And Digital UNIX and Linux,
4844 * at least, set argv[0] to the basename of the Perl
4845 * interpreter. So, having found "#!", we'll set it right.
4847 SV* copfilesv = CopFILESV(PL_curcop);
4850 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4852 assert(SvPOK(x) || SvGMAGICAL(x));
4853 if (sv_eq(x, copfilesv)) {
4854 sv_setpvn(x, ipath, ipathend - ipath);
4860 const char *bstart = SvPV_const(copfilesv, blen);
4861 const char * const lstart = SvPV_const(x, llen);
4863 bstart += blen - llen;
4864 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4865 sv_setpvn(x, ipath, ipathend - ipath);
4872 /* Anything to do if no copfilesv? */
4874 TAINT_NOT; /* $^X is always tainted, but that's OK */
4876 #endif /* ARG_ZERO_IS_SCRIPT */
4881 d = instr(s,"perl -");
4883 d = instr(s,"perl");
4884 if (d && d[4] == '6')
4887 /* avoid getting into infinite loops when shebang
4888 * line contains "Perl" rather than "perl" */
4890 for (d = ipathend-4; d >= ipath; --d) {
4891 if (isALPHA_FOLD_EQ(*d, 'p')
4892 && !ibcmp(d, "perl", 4))
4902 #ifdef ALTERNATE_SHEBANG
4904 * If the ALTERNATE_SHEBANG on this system starts with a
4905 * character that can be part of a Perl expression, then if
4906 * we see it but not "perl", we're probably looking at the
4907 * start of Perl code, not a request to hand off to some
4908 * other interpreter. Similarly, if "perl" is there, but
4909 * not in the first 'word' of the line, we assume the line
4910 * contains the start of the Perl program.
4912 if (d && *s != '#') {
4913 const char *c = ipath;
4914 while (*c && !strchr("; \t\r\n\f\v#", *c))
4917 d = NULL; /* "perl" not in first word; ignore */
4919 *s = '#'; /* Don't try to parse shebang line */
4921 #endif /* ALTERNATE_SHEBANG */
4926 && !instr(s,"indir")
4927 && instr(PL_origargv[0],"perl"))
4934 while (s < PL_bufend && isSPACE(*s))
4936 if (s < PL_bufend) {
4937 Newx(newargv,PL_origargc+3,char*);
4939 while (s < PL_bufend && !isSPACE(*s))
4942 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4945 newargv = PL_origargv;
4948 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4950 Perl_croak(aTHX_ "Can't exec %s", ipath);
4953 while (*d && !isSPACE(*d))
4955 while (SPACE_OR_TAB(*d))
4959 const bool switches_done = PL_doswitches;
4960 const U32 oldpdb = PL_perldb;
4961 const bool oldn = PL_minus_n;
4962 const bool oldp = PL_minus_p;
4966 bool baduni = FALSE;
4968 const char *d2 = d1 + 1;
4969 if (parse_unicode_opts((const char **)&d2)
4973 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4974 const char * const m = d1;
4975 while (*d1 && !isSPACE(*d1))
4977 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4980 d1 = moreswitches(d1);
4982 if (PL_doswitches && !switches_done) {
4983 int argc = PL_origargc;
4984 char **argv = PL_origargv;
4987 } while (argc && argv[0][0] == '-' && argv[0][1]);
4988 init_argv_symbols(argc,argv);
4990 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
4991 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4992 /* if we have already added "LINE: while (<>) {",
4993 we must not do it again */
4995 sv_setpvs(PL_linestr, "");
4996 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4997 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4998 PL_last_lop = PL_last_uni = NULL;
4999 PL_preambled = FALSE;
5000 if (PERLDB_LINE_OR_SAVESRC)
5001 (void)gv_fetchfile(PL_origfilename);
5008 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5009 PL_lex_state = LEX_FORMLINE;
5010 force_next(FORMRBRACK);
5015 #ifdef PERL_STRICT_CR
5016 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5018 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5020 case ' ': case '\t': case '\f': case '\v':
5025 if (PL_lex_state != LEX_NORMAL
5026 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5028 const bool in_comment = *s == '#';
5029 if (*s == '#' && s == PL_linestart && PL_in_eval
5030 && !PL_rsfp && !PL_parser->filtered) {
5031 /* handle eval qq[#line 1 "foo"\n ...] */
5032 CopLINE_dec(PL_curcop);
5036 while (d < PL_bufend && *d != '\n')
5040 else if (d > PL_bufend)
5041 /* Found by Ilya: feed random input to Perl. */
5042 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5045 if (in_comment && d == PL_bufend
5046 && PL_lex_state == LEX_INTERPNORMAL
5047 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5048 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5051 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5052 PL_lex_state = LEX_FORMLINE;
5053 force_next(FORMRBRACK);
5058 while (s < PL_bufend && *s != '\n')
5066 else if (s > PL_bufend)
5067 /* Found by Ilya: feed random input to Perl. */
5068 Perl_croak(aTHX_ "panic: input overflow");
5072 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5080 while (s < PL_bufend && SPACE_OR_TAB(*s))
5083 if (strnEQ(s,"=>",2)) {
5084 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5085 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5086 OPERATOR('-'); /* unary minus */
5089 case 'r': ftst = OP_FTEREAD; break;
5090 case 'w': ftst = OP_FTEWRITE; break;
5091 case 'x': ftst = OP_FTEEXEC; break;
5092 case 'o': ftst = OP_FTEOWNED; break;
5093 case 'R': ftst = OP_FTRREAD; break;
5094 case 'W': ftst = OP_FTRWRITE; break;
5095 case 'X': ftst = OP_FTREXEC; break;
5096 case 'O': ftst = OP_FTROWNED; break;
5097 case 'e': ftst = OP_FTIS; break;
5098 case 'z': ftst = OP_FTZERO; break;
5099 case 's': ftst = OP_FTSIZE; break;
5100 case 'f': ftst = OP_FTFILE; break;
5101 case 'd': ftst = OP_FTDIR; break;
5102 case 'l': ftst = OP_FTLINK; break;
5103 case 'p': ftst = OP_FTPIPE; break;
5104 case 'S': ftst = OP_FTSOCK; break;
5105 case 'u': ftst = OP_FTSUID; break;
5106 case 'g': ftst = OP_FTSGID; break;
5107 case 'k': ftst = OP_FTSVTX; break;
5108 case 'b': ftst = OP_FTBLK; break;
5109 case 'c': ftst = OP_FTCHR; break;
5110 case 't': ftst = OP_FTTTY; break;
5111 case 'T': ftst = OP_FTTEXT; break;
5112 case 'B': ftst = OP_FTBINARY; break;
5113 case 'M': case 'A': case 'C':
5114 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5116 case 'M': ftst = OP_FTMTIME; break;
5117 case 'A': ftst = OP_FTATIME; break;
5118 case 'C': ftst = OP_FTCTIME; break;
5126 PL_last_uni = PL_oldbufptr;
5127 PL_last_lop_op = (OPCODE)ftst;
5128 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5129 "### Saw file test %c\n", (int)tmp);
5134 /* Assume it was a minus followed by a one-letter named
5135 * subroutine call (or a -bareword), then. */
5136 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5137 "### '-%c' looked like a file test but was not\n",
5144 const char tmp = *s++;
5147 if (PL_expect == XOPERATOR)
5152 else if (*s == '>') {
5155 if (((*s == '$' || *s == '&') && s[1] == '*')
5156 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5157 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5158 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5161 PL_expect = XPOSTDEREF;
5164 if (isIDFIRST_lazy_if(s,UTF)) {
5165 s = force_word(s,METHOD,FALSE,TRUE);
5173 if (PL_expect == XOPERATOR) {
5175 && !PL_lex_allbrackets
5176 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5184 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5186 OPERATOR('-'); /* unary minus */
5192 const char tmp = *s++;
5195 if (PL_expect == XOPERATOR)
5200 if (PL_expect == XOPERATOR) {
5202 && !PL_lex_allbrackets
5203 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5211 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5218 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5219 if (PL_expect != XOPERATOR) {
5220 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5221 PL_expect = XOPERATOR;
5222 force_ident(PL_tokenbuf, '*');
5230 if (*s == '=' && !PL_lex_allbrackets
5231 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5239 && !PL_lex_allbrackets
5240 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5245 PL_parser->saw_infix_sigil = 1;
5250 if (PL_expect == XOPERATOR) {
5252 && !PL_lex_allbrackets
5253 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5258 PL_parser->saw_infix_sigil = 1;
5261 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5262 PL_tokenbuf[0] = '%';
5263 s = scan_ident(s, PL_tokenbuf + 1,
5264 sizeof PL_tokenbuf - 1, FALSE);
5266 if (!PL_tokenbuf[1]) {
5269 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5271 PL_tokenbuf[0] = '@';
5273 PL_expect = XOPERATOR;
5274 force_ident_maybe_lex('%');
5279 bof = FEATURE_BITWISE_IS_ENABLED;
5280 if (bof && s[1] == '.')
5282 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5283 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5289 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5291 if (PL_lex_brackets > 100)
5292 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5293 PL_lex_brackstack[PL_lex_brackets++] = 0;
5294 PL_lex_allbrackets++;
5296 const char tmp = *s++;
5301 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5303 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5306 Perl_ck_warner_d(aTHX_
5307 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5308 "Smartmatch is experimental");
5312 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5314 BCop(OP_SCOMPLEMENT);
5316 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5318 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5325 goto just_a_word_zero_gv;
5331 switch (PL_expect) {
5333 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5335 PL_bufptr = s; /* update in case we back off */
5338 "Use of := for an empty attribute list is not allowed");
5345 PL_expect = XTERMBLOCK;
5349 while (isIDFIRST_lazy_if(s,UTF)) {
5352 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5353 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5354 if (tmp < 0) tmp = -tmp;
5369 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5371 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5372 COPLINE_SET_FROM_MULTI_END;
5374 /* MUST advance bufptr here to avoid bogus
5375 "at end of line" context messages from yyerror().
5377 PL_bufptr = s + len;
5378 yyerror("Unterminated attribute parameter in attribute list");
5382 return REPORT(0); /* EOF indicator */
5386 sv_catsv(sv, PL_lex_stuff);
5387 attrs = op_append_elem(OP_LIST, attrs,
5388 newSVOP(OP_CONST, 0, sv));
5389 SvREFCNT_dec_NN(PL_lex_stuff);
5390 PL_lex_stuff = NULL;
5393 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5395 if (PL_in_my == KEY_our) {
5396 deprecate(":unique");
5399 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5402 /* NOTE: any CV attrs applied here need to be part of
5403 the CVf_BUILTIN_ATTRS define in cv.h! */
5404 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5406 CvLVALUE_on(PL_compcv);
5408 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5410 deprecate(":locked");
5412 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5414 CvMETHOD_on(PL_compcv);
5416 else if (!PL_in_my && len == 5
5417 && strnEQ(SvPVX(sv), "const", len))
5420 Perl_ck_warner_d(aTHX_
5421 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5422 ":const is experimental"
5424 CvANONCONST_on(PL_compcv);
5425 if (!CvANON(PL_compcv))
5426 yyerror(":const is not permitted on named "
5429 /* After we've set the flags, it could be argued that
5430 we don't need to do the attributes.pm-based setting
5431 process, and shouldn't bother appending recognized
5432 flags. To experiment with that, uncomment the
5433 following "else". (Note that's already been
5434 uncommented. That keeps the above-applied built-in
5435 attributes from being intercepted (and possibly
5436 rejected) by a package's attribute routines, but is
5437 justified by the performance win for the common case
5438 of applying only built-in attributes.) */
5440 attrs = op_append_elem(OP_LIST, attrs,
5441 newSVOP(OP_CONST, 0,
5445 if (*s == ':' && s[1] != ':')
5448 break; /* require real whitespace or :'s */
5449 /* XXX losing whitespace on sequential attributes here */
5454 && !(PL_expect == XOPERATOR
5455 ? (*s == '=' || *s == ')')
5456 : (*s == '{' || *s == '(')))
5458 const char q = ((*s == '\'') ? '"' : '\'');
5459 /* If here for an expression, and parsed no attrs, back
5461 if (PL_expect == XOPERATOR && !attrs) {
5465 /* MUST advance bufptr here to avoid bogus "at end of line"
5466 context messages from yyerror().
5469 yyerror( (const char *)
5471 ? Perl_form(aTHX_ "Invalid separator character "
5472 "%c%c%c in attribute list", q, *s, q)
5473 : "Unterminated attribute list" ) );
5481 NEXTVAL_NEXTTOKE.opval = attrs;
5487 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5491 PL_lex_allbrackets--;
5495 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5496 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5500 PL_lex_allbrackets++;
5503 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5510 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5513 PL_lex_allbrackets--;
5519 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5522 if (PL_lex_brackets <= 0)
5523 /* diag_listed_as: Unmatched right %s bracket */
5524 yyerror("Unmatched right square bracket");
5527 PL_lex_allbrackets--;
5528 if (PL_lex_state == LEX_INTERPNORMAL) {
5529 if (PL_lex_brackets == 0) {
5530 if (*s == '-' && s[1] == '>')
5531 PL_lex_state = LEX_INTERPENDMAYBE;
5532 else if (*s != '[' && *s != '{')
5533 PL_lex_state = LEX_INTERPEND;
5540 if (PL_lex_brackets > 100) {
5541 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5543 switch (PL_expect) {
5546 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5547 PL_lex_allbrackets++;
5548 OPERATOR(HASHBRACK);
5550 while (s < PL_bufend && SPACE_OR_TAB(*s))
5553 PL_tokenbuf[0] = '\0';
5554 if (d < PL_bufend && *d == '-') {
5555 PL_tokenbuf[0] = '-';
5557 while (d < PL_bufend && SPACE_OR_TAB(*d))
5560 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5561 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5563 while (d < PL_bufend && SPACE_OR_TAB(*d))
5566 const char minus = (PL_tokenbuf[0] == '-');
5567 s = force_word(s + minus, WORD, FALSE, TRUE);
5575 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5576 PL_lex_allbrackets++;
5581 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5582 PL_lex_allbrackets++;
5586 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5587 PL_lex_allbrackets++;
5592 if (PL_oldoldbufptr == PL_last_lop)
5593 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5595 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5596 PL_lex_allbrackets++;
5599 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5601 /* This hack is to get the ${} in the message. */
5603 yyerror("syntax error");
5606 OPERATOR(HASHBRACK);
5608 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5609 /* ${...} or @{...} etc., but not print {...}
5610 * Skip the disambiguation and treat this as a block.
5612 goto block_expectation;
5614 /* This hack serves to disambiguate a pair of curlies
5615 * as being a block or an anon hash. Normally, expectation
5616 * determines that, but in cases where we're not in a
5617 * position to expect anything in particular (like inside
5618 * eval"") we have to resolve the ambiguity. This code
5619 * covers the case where the first term in the curlies is a
5620 * quoted string. Most other cases need to be explicitly
5621 * disambiguated by prepending a "+" before the opening
5622 * curly in order to force resolution as an anon hash.
5624 * XXX should probably propagate the outer expectation
5625 * into eval"" to rely less on this hack, but that could
5626 * potentially break current behavior of eval"".
5630 if (*s == '\'' || *s == '"' || *s == '`') {
5631 /* common case: get past first string, handling escapes */
5632 for (t++; t < PL_bufend && *t != *s;)
5637 else if (*s == 'q') {
5640 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5641 && !isWORDCHAR(*t))))
5643 /* skip q//-like construct */
5645 char open, close, term;
5648 while (t < PL_bufend && isSPACE(*t))
5650 /* check for q => */
5651 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5652 OPERATOR(HASHBRACK);
5656 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5660 for (t++; t < PL_bufend; t++) {
5661 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5663 else if (*t == open)
5667 for (t++; t < PL_bufend; t++) {
5668 if (*t == '\\' && t+1 < PL_bufend)
5670 else if (*t == close && --brackets <= 0)
5672 else if (*t == open)
5679 /* skip plain q word */
5680 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5683 else if (isWORDCHAR_lazy_if(t,UTF)) {
5685 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5688 while (t < PL_bufend && isSPACE(*t))
5690 /* if comma follows first term, call it an anon hash */
5691 /* XXX it could be a comma expression with loop modifiers */
5692 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5693 || (*t == '=' && t[1] == '>')))
5694 OPERATOR(HASHBRACK);
5695 if (PL_expect == XREF)
5698 /* If there is an opening brace or 'sub:', treat it
5699 as a term to make ${{...}}{k} and &{sub:attr...}
5700 dwim. Otherwise, treat it as a statement, so
5701 map {no strict; ...} works.
5708 if (strnEQ(s, "sub", 3)) {
5719 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5725 pl_yylval.ival = CopLINE(PL_curcop);
5726 PL_copline = NOLINE; /* invalidate current command line number */
5727 TOKEN(formbrack ? '=' : '{');
5729 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5733 if (PL_lex_brackets <= 0)
5734 /* diag_listed_as: Unmatched right %s bracket */
5735 yyerror("Unmatched right curly bracket");
5737 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5738 PL_lex_allbrackets--;
5739 if (PL_lex_state == LEX_INTERPNORMAL) {
5740 if (PL_lex_brackets == 0) {
5741 if (PL_expect & XFAKEBRACK) {
5742 PL_expect &= XENUMMASK;
5743 PL_lex_state = LEX_INTERPEND;
5745 return yylex(); /* ignore fake brackets */
5747 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5748 && SvEVALED(PL_lex_repl))
5749 PL_lex_state = LEX_INTERPEND;
5750 else if (*s == '-' && s[1] == '>')
5751 PL_lex_state = LEX_INTERPENDMAYBE;
5752 else if (*s != '[' && *s != '{')
5753 PL_lex_state = LEX_INTERPEND;
5756 if (PL_expect & XFAKEBRACK) {
5757 PL_expect &= XENUMMASK;
5759 return yylex(); /* ignore fake brackets */
5761 force_next(formbrack ? '.' : '}');
5762 if (formbrack) LEAVE;
5763 if (formbrack == 2) { /* means . where arguments were expected */
5769 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5772 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5773 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5780 if (PL_expect == XOPERATOR) {
5781 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5782 && isIDFIRST_lazy_if(s,UTF))
5784 CopLINE_dec(PL_curcop);
5785 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5786 CopLINE_inc(PL_curcop);
5789 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5791 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5792 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5798 PL_parser->saw_infix_sigil = 1;
5799 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5805 PL_tokenbuf[0] = '&';
5806 s = scan_ident(s - 1, PL_tokenbuf + 1,
5807 sizeof PL_tokenbuf - 1, TRUE);
5808 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5809 if (PL_tokenbuf[1]) {
5810 force_ident_maybe_lex('&');
5819 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5820 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5828 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5830 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5831 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5835 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
5839 const char tmp = *s++;
5841 if (!PL_lex_allbrackets
5842 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5850 if (!PL_lex_allbrackets
5851 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5860 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5861 && strchr("+-*/%.^&|<",tmp))
5862 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5863 "Reversed %c= operator",(int)tmp);
5865 if (PL_expect == XSTATE
5867 && (s == PL_linestart+1 || s[-2] == '\n') )
5869 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5870 || PL_lex_state != LEX_NORMAL) {
5875 if (strnEQ(s,"=cut",4)) {
5889 PL_parser->in_pod = 1;
5893 if (PL_expect == XBLOCK) {
5895 #ifdef PERL_STRICT_CR
5896 while (SPACE_OR_TAB(*t))
5898 while (SPACE_OR_TAB(*t) || *t == '\r')
5901 if (*t == '\n' || *t == '#') {
5904 SAVEI8(PL_parser->form_lex_state);
5905 SAVEI32(PL_lex_formbrack);
5906 PL_parser->form_lex_state = PL_lex_state;
5907 PL_lex_formbrack = PL_lex_brackets + 1;
5911 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5920 const char tmp = *s++;
5922 /* was this !=~ where !~ was meant?
5923 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5925 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5926 const char *t = s+1;
5928 while (t < PL_bufend && isSPACE(*t))
5931 if (*t == '/' || *t == '?'
5932 || ((*t == 'm' || *t == 's' || *t == 'y')
5933 && !isWORDCHAR(t[1]))
5934 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5935 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5936 "!=~ should be !~");
5938 if (!PL_lex_allbrackets
5939 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5952 if (PL_expect != XOPERATOR) {
5953 if (s[1] != '<' && !strchr(s,'>'))
5955 if (s[1] == '<' && s[2] != '>')
5956 s = scan_heredoc(s);
5958 s = scan_inputsymbol(s);
5959 PL_expect = XOPERATOR;
5960 TOKEN(sublex_start());
5966 if (*s == '=' && !PL_lex_allbrackets
5967 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5972 SHop(OP_LEFT_SHIFT);
5977 if (!PL_lex_allbrackets
5978 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5986 if (!PL_lex_allbrackets
5987 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5996 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6004 const char tmp = *s++;
6006 if (*s == '=' && !PL_lex_allbrackets
6007 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6012 SHop(OP_RIGHT_SHIFT);
6014 else if (tmp == '=') {
6015 if (!PL_lex_allbrackets
6016 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6025 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6034 if (PL_expect == XOPERATOR) {
6035 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6036 return deprecate_commaless_var_list();
6039 else if (PL_expect == XPOSTDEREF) {
6042 POSTDEREF(DOLSHARP);
6047 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6048 PL_tokenbuf[0] = '@';
6049 s = scan_ident(s + 1, PL_tokenbuf + 1,
6050 sizeof PL_tokenbuf - 1, FALSE);
6051 if (PL_expect == XOPERATOR) {
6053 if (PL_bufptr > s) {
6055 PL_bufptr = PL_oldbufptr;
6057 no_op("Array length", d);
6059 if (!PL_tokenbuf[1])
6061 PL_expect = XOPERATOR;
6062 force_ident_maybe_lex('#');
6066 PL_tokenbuf[0] = '$';
6067 s = scan_ident(s, PL_tokenbuf + 1,
6068 sizeof PL_tokenbuf - 1, FALSE);
6069 if (PL_expect == XOPERATOR) {
6071 if (PL_bufptr > s) {
6073 PL_bufptr = PL_oldbufptr;
6077 if (!PL_tokenbuf[1]) {
6079 yyerror("Final $ should be \\$ or $name");
6085 const char tmp = *s;
6086 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6089 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6090 && intuit_more(s)) {
6092 PL_tokenbuf[0] = '@';
6093 if (ckWARN(WARN_SYNTAX)) {
6096 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6097 t += UTF ? UTF8SKIP(t) : 1;
6099 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6100 while (t < PL_bufend && *t != ']')
6102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6103 "Multidimensional syntax %"UTF8f" not supported",
6104 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6108 else if (*s == '{') {
6110 PL_tokenbuf[0] = '%';
6111 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6112 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6114 char tmpbuf[sizeof PL_tokenbuf];
6117 } while (isSPACE(*t));
6118 if (isIDFIRST_lazy_if(t,UTF)) {
6120 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6125 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6126 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6127 "You need to quote \"%"UTF8f"\"",
6128 UTF8fARG(UTF, len, tmpbuf));
6134 PL_expect = XOPERATOR;
6135 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6136 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6137 if (!islop || PL_last_lop_op == OP_GREPSTART)
6138 PL_expect = XOPERATOR;
6139 else if (strchr("$@\"'`q", *s))
6140 PL_expect = XTERM; /* e.g. print $fh "foo" */
6141 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6142 PL_expect = XTERM; /* e.g. print $fh &sub */
6143 else if (isIDFIRST_lazy_if(s,UTF)) {
6144 char tmpbuf[sizeof PL_tokenbuf];
6146 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6147 if ((t2 = keyword(tmpbuf, len, 0))) {
6148 /* binary operators exclude handle interpretations */
6160 PL_expect = XTERM; /* e.g. print $fh length() */
6165 PL_expect = XTERM; /* e.g. print $fh subr() */
6168 else if (isDIGIT(*s))
6169 PL_expect = XTERM; /* e.g. print $fh 3 */
6170 else if (*s == '.' && isDIGIT(s[1]))
6171 PL_expect = XTERM; /* e.g. print $fh .3 */
6172 else if ((*s == '?' || *s == '-' || *s == '+')
6173 && !isSPACE(s[1]) && s[1] != '=')
6174 PL_expect = XTERM; /* e.g. print $fh -1 */
6175 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6177 PL_expect = XTERM; /* e.g. print $fh /.../
6178 XXX except DORDOR operator
6180 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6182 PL_expect = XTERM; /* print $fh <<"EOF" */
6185 force_ident_maybe_lex('$');
6189 if (PL_expect == XOPERATOR)
6191 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6192 PL_tokenbuf[0] = '@';
6193 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6195 if (!PL_tokenbuf[1]) {
6198 if (PL_lex_state == LEX_NORMAL)
6200 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6202 PL_tokenbuf[0] = '%';
6204 /* Warn about @ where they meant $. */
6205 if (*s == '[' || *s == '{') {
6206 if (ckWARN(WARN_SYNTAX)) {
6207 S_check_scalar_slice(aTHX_ s);
6211 PL_expect = XOPERATOR;
6212 force_ident_maybe_lex('@');
6215 case '/': /* may be division, defined-or, or pattern */
6216 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6217 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6218 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6223 else if (PL_expect == XOPERATOR) {
6225 if (*s == '=' && !PL_lex_allbrackets
6226 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6234 /* Disable warning on "study /blah/" */
6235 if (PL_oldoldbufptr == PL_last_uni
6236 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6237 || memNE(PL_last_uni, "study", 5)
6238 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6241 s = scan_pat(s,OP_MATCH);
6242 TERM(sublex_start());
6245 case '?': /* conditional */
6247 if (!PL_lex_allbrackets
6248 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6253 PL_lex_allbrackets++;
6257 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6258 #ifdef PERL_STRICT_CR
6261 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6263 && (s == PL_linestart || s[-1] == '\n') )
6266 formbrack = 2; /* dot seen where arguments expected */
6269 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6273 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6276 if (!PL_lex_allbrackets
6277 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6285 pl_yylval.ival = OPf_SPECIAL;
6291 if (*s == '=' && !PL_lex_allbrackets
6292 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6300 case '0': case '1': case '2': case '3': case '4':
6301 case '5': case '6': case '7': case '8': case '9':
6302 s = scan_num(s, &pl_yylval);
6303 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6304 if (PL_expect == XOPERATOR)
6309 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6312 COPLINE_SET_FROM_MULTI_END;
6313 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6314 if (PL_expect == XOPERATOR) {
6315 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6316 return deprecate_commaless_var_list();
6321 pl_yylval.ival = OP_CONST;
6322 TERM(sublex_start());
6325 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6328 printbuf("### Saw string before %s\n", s);
6330 PerlIO_printf(Perl_debug_log,
6331 "### Saw unterminated string\n");
6333 if (PL_expect == XOPERATOR) {
6334 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6335 return deprecate_commaless_var_list();
6342 pl_yylval.ival = OP_CONST;
6343 /* FIXME. I think that this can be const if char *d is replaced by
6344 more localised variables. */
6345 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6346 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6347 pl_yylval.ival = OP_STRINGIFY;
6351 if (pl_yylval.ival == OP_CONST)
6352 COPLINE_SET_FROM_MULTI_END;
6353 TERM(sublex_start());
6356 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6359 printbuf("### Saw backtick string before %s\n", s);
6361 PerlIO_printf(Perl_debug_log,
6362 "### Saw unterminated backtick string\n");
6364 if (PL_expect == XOPERATOR)
6365 no_op("Backticks",s);
6368 pl_yylval.ival = OP_BACKTICK;
6369 TERM(sublex_start());
6373 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6375 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6377 if (PL_expect == XOPERATOR)
6378 no_op("Backslash",s);
6382 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6383 char *start = s + 2;
6384 while (isDIGIT(*start) || *start == '_')
6386 if (*start == '.' && isDIGIT(start[1])) {
6387 s = scan_num(s, &pl_yylval);
6390 else if ((*start == ':' && start[1] == ':')
6391 || (PL_expect == XSTATE && *start == ':'))
6393 else if (PL_expect == XSTATE) {
6395 while (d < PL_bufend && isSPACE(*d)) d++;
6396 if (*d == ':') goto keylookup;
6398 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6399 if (!isALPHA(*start) && (PL_expect == XTERM
6400 || PL_expect == XREF || PL_expect == XSTATE
6401 || PL_expect == XTERMORDORDOR)) {
6402 GV *const gv = gv_fetchpvn_flags(s, start - s,
6403 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6405 s = scan_num(s, &pl_yylval);
6412 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6465 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6467 /* Some keywords can be followed by any delimiter, including ':' */
6468 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6470 /* x::* is just a word, unless x is "CORE" */
6471 if (!anydelim && *s == ':' && s[1] == ':') {
6472 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6477 while (d < PL_bufend && isSPACE(*d))
6478 d++; /* no comments skipped here, or s### is misparsed */
6480 /* Is this a word before a => operator? */
6481 if (*d == '=' && d[1] == '>') {
6485 = (OP*)newSVOP(OP_CONST, 0,
6486 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6487 pl_yylval.opval->op_private = OPpCONST_BARE;
6491 /* Check for plugged-in keyword */
6495 char *saved_bufptr = PL_bufptr;
6497 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6499 if (result == KEYWORD_PLUGIN_DECLINE) {
6500 /* not a plugged-in keyword */
6501 PL_bufptr = saved_bufptr;
6502 } else if (result == KEYWORD_PLUGIN_STMT) {
6503 pl_yylval.opval = o;
6505 if (!PL_nexttoke) PL_expect = XSTATE;
6506 return REPORT(PLUGSTMT);
6507 } else if (result == KEYWORD_PLUGIN_EXPR) {
6508 pl_yylval.opval = o;
6510 if (!PL_nexttoke) PL_expect = XOPERATOR;
6511 return REPORT(PLUGEXPR);
6513 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6518 /* Check for built-in keyword */
6519 tmp = keyword(PL_tokenbuf, len, 0);
6521 /* Is this a label? */
6522 if (!anydelim && PL_expect == XSTATE
6523 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6525 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6526 pl_yylval.pval[len] = '\0';
6527 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6532 /* Check for lexical sub */
6533 if (PL_expect != XOPERATOR) {
6534 char tmpbuf[sizeof PL_tokenbuf + 1];
6536 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6537 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6538 if (off != NOT_IN_PAD) {
6539 assert(off); /* we assume this is boolean-true below */
6540 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6541 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6542 HEK * const stashname = HvNAME_HEK(stash);
6543 sv = newSVhek(stashname);
6544 sv_catpvs(sv, "::");
6545 sv_catpvn_flags(sv, PL_tokenbuf, len,
6546 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6547 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6557 rv2cv_op = newOP(OP_PADANY, 0);
6558 rv2cv_op->op_targ = off;
6559 cv = find_lexical_cv(off);
6567 if (tmp < 0) { /* second-class keyword? */
6568 GV *ogv = NULL; /* override (winner) */
6569 GV *hgv = NULL; /* hidden (loser) */
6570 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6572 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6573 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6575 && (cv = GvCVu(gv)))
6577 if (GvIMPORTED_CV(gv))
6579 else if (! CvMETHOD(cv))
6583 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6586 && (isGV_with_GP(gv)
6587 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6588 : SvPCS_IMPORTED(gv)
6589 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6597 tmp = 0; /* overridden by import or by GLOBAL */
6600 && -tmp==KEY_lock /* XXX generalizable kludge */
6603 tmp = 0; /* any sub overrides "weak" keyword */
6605 else { /* no override */
6607 if (tmp == KEY_dump) {
6608 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6609 "dump() better written as CORE::dump()");
6613 if (hgv && tmp != KEY_x) /* never ambiguous */
6614 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6615 "Ambiguous call resolved as CORE::%s(), "
6616 "qualify as such or use &",
6621 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6622 && (!anydelim || *s != '#')) {
6623 /* no override, and not s### either; skipspace is safe here
6624 * check for => on following line */
6626 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6627 STRLEN soff = s - SvPVX(PL_linestr);
6628 s = skipspace_flags(s, LEX_NO_INCLINE);
6629 arrow = *s == '=' && s[1] == '>';
6630 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6631 s = SvPVX(PL_linestr) + soff;
6639 default: /* not a keyword */
6640 /* Trade off - by using this evil construction we can pull the
6641 variable gv into the block labelled keylookup. If not, then
6642 we have to give it function scope so that the goto from the
6643 earlier ':' case doesn't bypass the initialisation. */
6645 just_a_word_zero_gv:
6657 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6661 /* Get the rest if it looks like a package qualifier */
6663 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6665 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6668 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6669 UTF8fARG(UTF, len, PL_tokenbuf),
6670 *s == '\'' ? "'" : "::");
6675 if (PL_expect == XOPERATOR) {
6676 if (PL_bufptr == PL_linestart) {
6677 CopLINE_dec(PL_curcop);
6678 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6679 CopLINE_inc(PL_curcop);
6682 no_op("Bareword",s);
6685 /* See if the name is "Foo::",
6686 in which case Foo is a bareword
6687 (and a package name). */
6690 && PL_tokenbuf[len - 2] == ':'
6691 && PL_tokenbuf[len - 1] == ':')
6693 if (ckWARN(WARN_BAREWORD)
6694 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6695 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6696 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6697 UTF8fARG(UTF, len, PL_tokenbuf));
6699 PL_tokenbuf[len] = '\0';
6708 /* if we saw a global override before, get the right name */
6711 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6714 SV * const tmp_sv = sv;
6715 sv = newSVpvs("CORE::GLOBAL::");
6716 sv_catsv(sv, tmp_sv);
6717 SvREFCNT_dec(tmp_sv);
6721 /* Presume this is going to be a bareword of some sort. */
6723 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6724 pl_yylval.opval->op_private = OPpCONST_BARE;
6726 /* And if "Foo::", then that's what it certainly is. */
6732 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6733 const_op->op_private = OPpCONST_BARE;
6735 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6739 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6742 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6745 /* Use this var to track whether intuit_method has been
6746 called. intuit_method returns 0 or > 255. */
6749 /* See if it's the indirect object for a list operator. */
6752 && PL_oldoldbufptr < PL_bufptr
6753 && (PL_oldoldbufptr == PL_last_lop
6754 || PL_oldoldbufptr == PL_last_uni)
6755 && /* NO SKIPSPACE BEFORE HERE! */
6757 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
6760 bool immediate_paren = *s == '(';
6762 /* (Now we can afford to cross potential line boundary.) */
6765 /* Two barewords in a row may indicate method call. */
6767 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$')
6768 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
6773 /* If not a declared subroutine, it's an indirect object. */
6774 /* (But it's an indir obj regardless for sort.) */
6775 /* Also, if "_" follows a filetest operator, it's a bareword */
6778 ( !immediate_paren && (PL_last_lop_op == OP_SORT
6780 && (PL_last_lop_op != OP_MAPSTART
6781 && PL_last_lop_op != OP_GREPSTART))))
6782 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6783 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
6787 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6792 PL_expect = XOPERATOR;
6795 /* Is this a word before a => operator? */
6796 if (*s == '=' && s[1] == '>' && !pkgname) {
6799 if (gvp || (lex && !off)) {
6800 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6801 /* This is our own scalar, created a few lines
6802 above, so this is safe. */
6804 sv_setpv(sv, PL_tokenbuf);
6805 if (UTF && !IN_BYTES
6806 && is_utf8_string((U8*)PL_tokenbuf, len))
6813 /* If followed by a paren, it's certainly a subroutine. */
6818 while (SPACE_OR_TAB(*d))
6820 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6825 NEXTVAL_NEXTTOKE.opval =
6826 off ? rv2cv_op : pl_yylval.opval;
6828 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6829 else op_free(rv2cv_op), force_next(WORD);
6834 /* If followed by var or block, call it a method (unless sub) */
6836 if ((*s == '$' || *s == '{') && !cv) {
6838 PL_last_lop = PL_oldbufptr;
6839 PL_last_lop_op = OP_METHOD;
6840 if (!PL_lex_allbrackets
6841 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6843 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6845 PL_expect = XBLOCKTERM;
6847 return REPORT(METHOD);
6850 /* If followed by a bareword, see if it looks like indir obj. */
6852 if (tmp == 1 && !orig_keyword
6853 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6854 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6857 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6859 sv_setpvn(sv, PL_tokenbuf, len);
6860 if (UTF && !IN_BYTES
6861 && is_utf8_string((U8*)PL_tokenbuf, len))
6863 else SvUTF8_off(sv);
6866 if (tmp == METHOD && !PL_lex_allbrackets
6867 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6869 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6874 /* Not a method, so call it a subroutine (if defined) */
6877 /* Check for a constant sub */
6878 if ((sv = cv_const_sv_or_av(cv))) {
6881 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6882 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6883 if (SvTYPE(sv) == SVt_PVAV)
6884 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6887 pl_yylval.opval->op_private = 0;
6888 pl_yylval.opval->op_folded = 1;
6889 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6894 op_free(pl_yylval.opval);
6896 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6897 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6898 PL_last_lop = PL_oldbufptr;
6899 PL_last_lop_op = OP_ENTERSUB;
6900 /* Is there a prototype? */
6904 STRLEN protolen = CvPROTOLEN(cv);
6905 const char *proto = CvPROTO(cv);
6907 proto = S_strip_spaces(aTHX_ proto, &protolen);
6910 if ((optional = *proto == ';'))
6913 while (*proto == ';');
6917 *proto == '$' || *proto == '_'
6918 || *proto == '*' || *proto == '+'
6923 *proto == '\\' && proto[1] && proto[2] == '\0'
6926 UNIPROTO(UNIOPSUB,optional);
6927 if (*proto == '\\' && proto[1] == '[') {
6928 const char *p = proto + 2;
6929 while(*p && *p != ']')
6931 if(*p == ']' && !p[1])
6932 UNIPROTO(UNIOPSUB,optional);
6934 if (*proto == '&' && *s == '{') {
6936 sv_setpvs(PL_subname, "__ANON__");
6938 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6939 if (!PL_lex_allbrackets
6940 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6942 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6947 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6949 force_next(off ? PRIVATEREF : WORD);
6950 if (!PL_lex_allbrackets
6951 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6953 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6958 /* Call it a bare word */
6960 if (PL_hints & HINT_STRICT_SUBS)
6961 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6964 /* after "print" and similar functions (corresponding to
6965 * "F? L" in opcode.pl), whatever wasn't already parsed as
6966 * a filehandle should be subject to "strict subs".
6967 * Likewise for the optional indirect-object argument to system
6968 * or exec, which can't be a bareword */
6969 if ((PL_last_lop_op == OP_PRINT
6970 || PL_last_lop_op == OP_PRTF
6971 || PL_last_lop_op == OP_SAY
6972 || PL_last_lop_op == OP_SYSTEM
6973 || PL_last_lop_op == OP_EXEC)
6974 && (PL_hints & HINT_STRICT_SUBS))
6975 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6976 if (lastchar != '-') {
6977 if (ckWARN(WARN_RESERVED)) {
6981 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6983 /* PL_warn_reserved is constant */
6984 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6985 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6995 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6996 && saw_infix_sigil) {
6997 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6998 "Operator or semicolon missing before %c%"UTF8f,
7000 UTF8fARG(UTF, strlen(PL_tokenbuf),
7002 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7003 "Ambiguous use of %c resolved as operator %c",
7004 lastchar, lastchar);
7011 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7016 (OP*)newSVOP(OP_CONST, 0,
7017 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7020 case KEY___PACKAGE__:
7022 (OP*)newSVOP(OP_CONST, 0,
7024 ? newSVhek(HvNAME_HEK(PL_curstash))
7031 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7032 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7035 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7037 gv_init(gv,stash,"DATA",4,0);
7040 GvIOp(gv) = newIO();
7041 IoIFP(GvIOp(gv)) = PL_rsfp;
7042 #if defined(HAS_FCNTL) && defined(F_SETFD)
7044 const int fd = PerlIO_fileno(PL_rsfp);
7045 fcntl(fd,F_SETFD,fd >= 3);
7048 /* Mark this internal pseudo-handle as clean */
7049 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7050 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7051 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7053 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7054 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7055 /* if the script was opened in binmode, we need to revert
7056 * it to text mode for compatibility; but only iff it has CRs
7057 * XXX this is a questionable hack at best. */
7058 if (PL_bufend-PL_bufptr > 2
7059 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7062 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7063 loc = PerlIO_tell(PL_rsfp);
7064 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7067 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7069 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7070 #endif /* NETWARE */
7072 PerlIO_seek(PL_rsfp, loc, 0);
7076 #ifdef PERLIO_LAYERS
7079 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7080 else if (IN_ENCODING) {
7086 XPUSHs(_get_encoding());
7088 call_method("name", G_SCALAR);
7092 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7093 Perl_form(aTHX_ ":encoding(%"SVf")",
7106 FUN0OP(CvCLONE(PL_compcv)
7107 ? newOP(OP_RUNCV, 0)
7108 : newPVOP(OP_RUNCV,0,NULL));
7117 if (PL_expect == XSTATE) {
7128 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7129 if ((*s == ':' && s[1] == ':')
7130 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7134 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7138 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7139 UTF8fARG(UTF, len, PL_tokenbuf));
7142 else if (tmp == KEY_require || tmp == KEY_do
7144 /* that's a way to remember we saw "CORE::" */
7156 LOP(OP_ACCEPT,XTERM);
7159 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7164 LOP(OP_ATAN2,XTERM);
7170 LOP(OP_BINMODE,XTERM);
7173 LOP(OP_BLESS,XTERM);
7182 /* We have to disambiguate the two senses of
7183 "continue". If the next token is a '{' then
7184 treat it as the start of a continue block;
7185 otherwise treat it as a control operator.
7195 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7205 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7214 if (!PL_cryptseen) {
7215 PL_cryptseen = TRUE;
7219 LOP(OP_CRYPT,XTERM);
7222 LOP(OP_CHMOD,XTERM);
7225 LOP(OP_CHOWN,XTERM);
7228 LOP(OP_CONNECT,XTERM);
7248 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7250 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7251 && !keyword(PL_tokenbuf + 1, len, 0)) {
7254 force_ident_maybe_lex('&');
7259 if (orig_keyword == KEY_do) {
7268 PL_hints |= HINT_BLOCK_SCOPE;
7278 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7279 STR_WITH_LEN("NDBM_File::"),
7280 STR_WITH_LEN("DB_File::"),
7281 STR_WITH_LEN("GDBM_File::"),
7282 STR_WITH_LEN("SDBM_File::"),
7283 STR_WITH_LEN("ODBM_File::"),
7285 LOP(OP_DBMOPEN,XTERM);
7297 pl_yylval.ival = CopLINE(PL_curcop);
7301 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7313 if (*s == '{') { /* block eval */
7314 PL_expect = XTERMBLOCK;
7315 UNIBRACK(OP_ENTERTRY);
7317 else { /* string eval */
7319 UNIBRACK(OP_ENTEREVAL);
7324 UNIBRACK(-OP_ENTEREVAL);
7338 case KEY_endhostent:
7344 case KEY_endservent:
7347 case KEY_endprotoent:
7358 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7360 pl_yylval.ival = CopLINE(PL_curcop);
7362 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7365 if ((PL_bufend - p) >= 3
7366 && strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7370 else if ((PL_bufend - p) >= 4
7371 && strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7374 /* skip optional package name, as in "for my abc $x (..)" */
7375 if (isIDFIRST_lazy_if(p,UTF)) {
7376 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7380 Perl_croak(aTHX_ "Missing $ on loop variable");
7385 LOP(OP_FORMLINE,XTERM);
7394 LOP(OP_FCNTL,XTERM);
7400 LOP(OP_FLOCK,XTERM);
7403 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7408 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7413 LOP(OP_GREPSTART, XREF);
7430 case KEY_getpriority:
7431 LOP(OP_GETPRIORITY,XTERM);
7433 case KEY_getprotobyname:
7436 case KEY_getprotobynumber:
7437 LOP(OP_GPBYNUMBER,XTERM);
7439 case KEY_getprotoent:
7451 case KEY_getpeername:
7452 UNI(OP_GETPEERNAME);
7454 case KEY_gethostbyname:
7457 case KEY_gethostbyaddr:
7458 LOP(OP_GHBYADDR,XTERM);
7460 case KEY_gethostent:
7463 case KEY_getnetbyname:
7466 case KEY_getnetbyaddr:
7467 LOP(OP_GNBYADDR,XTERM);
7472 case KEY_getservbyname:
7473 LOP(OP_GSBYNAME,XTERM);
7475 case KEY_getservbyport:
7476 LOP(OP_GSBYPORT,XTERM);
7478 case KEY_getservent:
7481 case KEY_getsockname:
7482 UNI(OP_GETSOCKNAME);
7484 case KEY_getsockopt:
7485 LOP(OP_GSOCKOPT,XTERM);
7500 pl_yylval.ival = CopLINE(PL_curcop);
7501 Perl_ck_warner_d(aTHX_
7502 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7503 "given is experimental");
7508 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7516 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7518 pl_yylval.ival = CopLINE(PL_curcop);
7522 LOP(OP_INDEX,XTERM);
7528 LOP(OP_IOCTL,XTERM);
7556 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7561 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7575 LOP(OP_LISTEN,XTERM);
7584 s = scan_pat(s,OP_MATCH);
7585 TERM(sublex_start());
7588 LOP(OP_MAPSTART, XREF);
7591 LOP(OP_MKDIR,XTERM);
7594 LOP(OP_MSGCTL,XTERM);
7597 LOP(OP_MSGGET,XTERM);
7600 LOP(OP_MSGRCV,XTERM);
7603 LOP(OP_MSGSND,XTERM);
7609 yyerror(Perl_form(aTHX_
7610 "Can't redeclare \"%s\" in \"%s\"",
7611 tmp == KEY_my ? "my" :
7612 tmp == KEY_state ? "state" : "our",
7613 PL_in_my == KEY_my ? "my" :
7614 PL_in_my == KEY_state ? "state" : "our"));
7616 PL_in_my = (U16)tmp;
7618 if (isIDFIRST_lazy_if(s,UTF)) {
7619 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7620 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7622 if (!FEATURE_LEXSUBS_IS_ENABLED)
7624 "Experimental \"%s\" subs not enabled",
7625 tmp == KEY_my ? "my" :
7626 tmp == KEY_state ? "state" : "our");
7627 Perl_ck_warner_d(aTHX_
7628 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7629 "The lexical_subs feature is experimental");
7632 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7633 if (!PL_in_my_stash) {
7637 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7638 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7639 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7649 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7654 s = tokenize_use(0, s);
7658 if (*s == '(' || (s = skipspace(s), *s == '('))
7661 if (!PL_lex_allbrackets
7662 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7664 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7671 if (isIDFIRST_lazy_if(s,UTF)) {
7673 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7675 for (t=d; isSPACE(*t);)
7677 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7679 && !(t[0] == '=' && t[1] == '>')
7680 && !(t[0] == ':' && t[1] == ':')
7681 && !keyword(s, d-s, 0)
7683 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7684 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7685 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7691 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7693 pl_yylval.ival = OP_OR;
7703 LOP(OP_OPEN_DIR,XTERM);
7706 checkcomma(s,PL_tokenbuf,"filehandle");
7710 checkcomma(s,PL_tokenbuf,"filehandle");
7729 s = force_word(s,WORD,FALSE,TRUE);
7731 s = force_strict_version(s);
7735 LOP(OP_PIPE_OP,XTERM);
7738 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7741 COPLINE_SET_FROM_MULTI_END;
7742 pl_yylval.ival = OP_CONST;
7743 TERM(sublex_start());
7750 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7753 COPLINE_SET_FROM_MULTI_END;
7754 PL_expect = XOPERATOR;
7755 if (SvCUR(PL_lex_stuff)) {
7756 int warned_comma = !ckWARN(WARN_QW);
7757 int warned_comment = warned_comma;
7758 d = SvPV_force(PL_lex_stuff, len);
7760 for (; isSPACE(*d) && len; --len, ++d)
7765 if (!warned_comma || !warned_comment) {
7766 for (; !isSPACE(*d) && len; --len, ++d) {
7767 if (!warned_comma && *d == ',') {
7768 Perl_warner(aTHX_ packWARN(WARN_QW),
7769 "Possible attempt to separate words with commas");
7772 else if (!warned_comment && *d == '#') {
7773 Perl_warner(aTHX_ packWARN(WARN_QW),
7774 "Possible attempt to put comments in qw() list");
7780 for (; !isSPACE(*d) && len; --len, ++d)
7783 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7784 words = op_append_elem(OP_LIST, words,
7785 newSVOP(OP_CONST, 0, tokeq(sv)));
7790 words = newNULLLIST();
7791 SvREFCNT_dec_NN(PL_lex_stuff);
7792 PL_lex_stuff = NULL;
7793 PL_expect = XOPERATOR;
7794 pl_yylval.opval = sawparens(words);
7799 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7802 pl_yylval.ival = OP_STRINGIFY;
7803 if (SvIVX(PL_lex_stuff) == '\'')
7804 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7805 TERM(sublex_start());
7808 s = scan_pat(s,OP_QR);
7809 TERM(sublex_start());
7812 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7815 pl_yylval.ival = OP_BACKTICK;
7816 TERM(sublex_start());
7824 s = force_version(s, FALSE);
7826 else if (*s != 'v' || !isDIGIT(s[1])
7827 || (s = force_version(s, TRUE), *s == 'v'))
7829 *PL_tokenbuf = '\0';
7830 s = force_word(s,WORD,TRUE,TRUE);
7831 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7832 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7833 GV_ADD | (UTF ? SVf_UTF8 : 0));
7835 yyerror("<> at require-statement should be quotes");
7837 if (orig_keyword == KEY_require) {
7843 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7845 PL_last_uni = PL_oldbufptr;
7846 PL_last_lop_op = OP_REQUIRE;
7848 return REPORT( (int)REQUIRE );
7857 LOP(OP_RENAME,XTERM);
7866 LOP(OP_RINDEX,XTERM);
7875 UNIDOR(OP_READLINE);
7878 UNIDOR(OP_BACKTICK);
7887 LOP(OP_REVERSE,XTERM);
7890 UNIDOR(OP_READLINK);
7897 if (pl_yylval.opval)
7898 TERM(sublex_start());
7900 TOKEN(1); /* force error */
7903 checkcomma(s,PL_tokenbuf,"filehandle");
7913 LOP(OP_SELECT,XTERM);
7919 LOP(OP_SEMCTL,XTERM);
7922 LOP(OP_SEMGET,XTERM);
7925 LOP(OP_SEMOP,XTERM);
7931 LOP(OP_SETPGRP,XTERM);
7933 case KEY_setpriority:
7934 LOP(OP_SETPRIORITY,XTERM);
7936 case KEY_sethostent:
7942 case KEY_setservent:
7945 case KEY_setprotoent:
7955 LOP(OP_SEEKDIR,XTERM);
7957 case KEY_setsockopt:
7958 LOP(OP_SSOCKOPT,XTERM);
7964 LOP(OP_SHMCTL,XTERM);
7967 LOP(OP_SHMGET,XTERM);
7970 LOP(OP_SHMREAD,XTERM);
7973 LOP(OP_SHMWRITE,XTERM);
7976 LOP(OP_SHUTDOWN,XTERM);
7985 LOP(OP_SOCKET,XTERM);
7987 case KEY_socketpair:
7988 LOP(OP_SOCKPAIR,XTERM);
7991 checkcomma(s,PL_tokenbuf,"subroutine name");
7994 s = force_word(s,WORD,TRUE,TRUE);
7998 LOP(OP_SPLIT,XTERM);
8001 LOP(OP_SPRINTF,XTERM);
8004 LOP(OP_SPLICE,XTERM);
8019 LOP(OP_SUBSTR,XTERM);
8025 char * const tmpbuf = PL_tokenbuf + 1;
8026 expectation attrful;
8027 bool have_name, have_proto;
8028 const int key = tmp;
8029 SV *format_name = NULL;
8034 if (isIDFIRST_lazy_if(s,UTF)
8036 || (*s == ':' && s[1] == ':'))
8040 attrful = XATTRBLOCK;
8041 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8043 if (key == KEY_format)
8044 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8046 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8048 PL_tokenbuf, len + 1, 0
8050 sv_setpvn(PL_subname, tmpbuf, len);
8052 sv_setsv(PL_subname,PL_curstname);
8053 sv_catpvs(PL_subname,"::");
8054 sv_catpvn(PL_subname,tmpbuf,len);
8056 if (SvUTF8(PL_linestr))
8057 SvUTF8_on(PL_subname);
8064 if (key == KEY_my || key == KEY_our || key==KEY_state)
8067 /* diag_listed_as: Missing name in "%s sub" */
8069 "Missing name in \"%s\"", PL_bufptr);
8071 PL_expect = XTERMBLOCK;
8072 attrful = XATTRTERM;
8073 sv_setpvs(PL_subname,"?");
8077 if (key == KEY_format) {
8079 NEXTVAL_NEXTTOKE.opval
8080 = (OP*)newSVOP(OP_CONST,0, format_name);
8081 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8087 /* Look for a prototype */
8088 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8089 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8090 COPLINE_SET_FROM_MULTI_END;
8092 Perl_croak(aTHX_ "Prototype not terminated");
8093 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8101 if (*s == ':' && s[1] != ':')
8102 PL_expect = attrful;
8103 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
8105 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8106 else if (*s != ';' && *s != '}')
8107 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8111 NEXTVAL_NEXTTOKE.opval =
8112 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8113 PL_lex_stuff = NULL;
8118 sv_setpvs(PL_subname, "__ANON__");
8120 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8123 force_ident_maybe_lex('&');
8128 LOP(OP_SYSTEM,XREF);
8131 LOP(OP_SYMLINK,XTERM);
8134 LOP(OP_SYSCALL,XTERM);
8137 LOP(OP_SYSOPEN,XTERM);
8140 LOP(OP_SYSSEEK,XTERM);
8143 LOP(OP_SYSREAD,XTERM);
8146 LOP(OP_SYSWRITE,XTERM);
8151 TERM(sublex_start());
8172 LOP(OP_TRUNCATE,XTERM);
8184 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8186 pl_yylval.ival = CopLINE(PL_curcop);
8190 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8192 pl_yylval.ival = CopLINE(PL_curcop);
8196 LOP(OP_UNLINK,XTERM);
8202 LOP(OP_UNPACK,XTERM);
8205 LOP(OP_UTIME,XTERM);
8211 LOP(OP_UNSHIFT,XTERM);
8214 s = tokenize_use(1, s);
8224 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8226 pl_yylval.ival = CopLINE(PL_curcop);
8227 Perl_ck_warner_d(aTHX_
8228 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8229 "when is experimental");
8233 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8235 pl_yylval.ival = CopLINE(PL_curcop);
8239 PL_hints |= HINT_BLOCK_SCOPE;
8246 LOP(OP_WAITPID,XTERM);
8252 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8253 * we use the same number on EBCDIC */
8254 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8258 if (PL_expect == XOPERATOR) {
8259 if (*s == '=' && !PL_lex_allbrackets
8260 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8270 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8272 pl_yylval.ival = OP_XOR;
8281 Looks up an identifier in the pad or in a package
8284 PRIVATEREF if this is a lexical name.
8285 WORD if this belongs to a package.
8288 if we're in a my declaration
8289 croak if they tried to say my($foo::bar)
8290 build the ops for a my() declaration
8291 if it's an access to a my() variable
8292 build ops for access to a my() variable
8293 if in a dq string, and they've said @foo and we can't find @foo
8295 build ops for a bareword
8299 S_pending_ident(pTHX)
8302 const char pit = (char)pl_yylval.ival;
8303 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8304 /* All routes through this function want to know if there is a colon. */
8305 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8307 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8308 "### Pending identifier '%s'\n", PL_tokenbuf); });
8310 /* if we're in a my(), we can't allow dynamics here.
8311 $foo'bar has already been turned into $foo::bar, so
8312 just check for colons.
8314 if it's a legal name, the OP is a PADANY.
8317 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8319 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8320 "variable %s in \"our\"",
8321 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8322 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8326 /* "my" variable %s can't be in a package */
8327 /* PL_no_myglob is constant */
8328 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8329 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8330 PL_in_my == KEY_my ? "my" : "state",
8331 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8333 UTF ? SVf_UTF8 : 0);
8337 pl_yylval.opval = newOP(OP_PADANY, 0);
8338 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8339 UTF ? SVf_UTF8 : 0);
8345 build the ops for accesses to a my() variable.
8350 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8352 if (tmp != NOT_IN_PAD) {
8353 /* might be an "our" variable" */
8354 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8355 /* build ops for a bareword */
8356 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8357 HEK * const stashname = HvNAME_HEK(stash);
8358 SV * const sym = newSVhek(stashname);
8359 sv_catpvs(sym, "::");
8360 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8361 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8362 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8366 ((PL_tokenbuf[0] == '$') ? SVt_PV
8367 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8372 pl_yylval.opval = newOP(OP_PADANY, 0);
8373 pl_yylval.opval->op_targ = tmp;
8379 Whine if they've said @foo in a doublequoted string,
8380 and @foo isn't a variable we can find in the symbol
8383 if (ckWARN(WARN_AMBIGUOUS)
8385 && PL_lex_state != LEX_NORMAL
8386 && !PL_lex_brackets)
8388 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8389 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8390 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8391 /* DO NOT warn for @- and @+ */
8392 && !( PL_tokenbuf[2] == '\0'
8393 && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8396 /* Downgraded from fatal to warning 20000522 mjd */
8397 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8398 "Possible unintended interpolation of %"UTF8f
8400 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8404 /* build ops for a bareword */
8405 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8406 newSVpvn_flags(PL_tokenbuf + 1,
8408 UTF ? SVf_UTF8 : 0 ));
8409 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8411 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8412 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8413 | ( UTF ? SVf_UTF8 : 0 ),
8414 ((PL_tokenbuf[0] == '$') ? SVt_PV
8415 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8421 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8423 PERL_ARGS_ASSERT_CHECKCOMMA;
8425 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8426 if (ckWARN(WARN_SYNTAX)) {
8429 for (w = s+2; *w && level; w++) {
8437 /* the list of chars below is for end of statements or
8438 * block / parens, boolean operators (&&, ||, //) and branch
8439 * constructs (or, and, if, until, unless, while, err, for).
8440 * Not a very solid hack... */
8441 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8442 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8443 "%s (...) interpreted as function",name);
8446 while (s < PL_bufend && isSPACE(*s))
8450 while (s < PL_bufend && isSPACE(*s))
8452 if (isIDFIRST_lazy_if(s,UTF)) {
8453 const char * const w = s;
8454 s += UTF ? UTF8SKIP(s) : 1;
8455 while (isWORDCHAR_lazy_if(s,UTF))
8456 s += UTF ? UTF8SKIP(s) : 1;
8457 while (s < PL_bufend && isSPACE(*s))
8462 if (keyword(w, s - w, 0))
8465 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8466 if (gv && GvCVu(gv))
8470 Copy(w, tmpbuf+1, s - w, char);
8472 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8473 if (off != NOT_IN_PAD) return;
8475 Perl_croak(aTHX_ "No comma allowed after %s", what);
8480 /* S_new_constant(): do any overload::constant lookup.
8482 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8483 Best used as sv=new_constant(..., sv, ...).
8484 If s, pv are NULL, calls subroutine with one argument,
8485 and <type> is used with error messages only.
8486 <type> is assumed to be well formed UTF-8 */
8489 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8490 SV *sv, SV *pv, const char *type, STRLEN typelen)
8493 HV * table = GvHV(PL_hintgv); /* ^H */
8498 const char *why1 = "", *why2 = "", *why3 = "";
8500 PERL_ARGS_ASSERT_NEW_CONSTANT;
8501 /* We assume that this is true: */
8502 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8505 /* charnames doesn't work well if there have been errors found */
8506 if (PL_error_count > 0 && *key == 'c')
8508 SvREFCNT_dec_NN(sv);
8509 return &PL_sv_undef;
8512 sv_2mortal(sv); /* Parent created it permanently */
8514 || ! (PL_hints & HINT_LOCALIZE_HH)
8515 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8520 /* Here haven't found what we're looking for. If it is charnames,
8521 * perhaps it needs to be loaded. Try doing that before giving up */
8523 Perl_load_module(aTHX_
8525 newSVpvs("_charnames"),
8526 /* version parameter; no need to specify it, as if
8527 * we get too early a version, will fail anyway,
8528 * not being able to find '_charnames' */
8533 assert(sp == PL_stack_sp);
8534 table = GvHV(PL_hintgv);
8536 && (PL_hints & HINT_LOCALIZE_HH)
8537 && (cvp = hv_fetch(table, key, keylen, FALSE))
8543 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8544 msg = Perl_form(aTHX_
8545 "Constant(%.*s) unknown",
8546 (int)(type ? typelen : len),
8552 why3 = "} is not defined";
8555 msg = Perl_form(aTHX_
8556 /* The +3 is for '\N{'; -4 for that, plus '}' */
8557 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8561 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8562 (int)(type ? typelen : len),
8563 (type ? type: s), why1, why2, why3);
8566 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8567 return SvREFCNT_inc_simple_NN(sv);
8572 pv = newSVpvn_flags(s, len, SVs_TEMP);
8574 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8576 typesv = &PL_sv_undef;
8578 PUSHSTACKi(PERLSI_OVERLOAD);
8590 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8594 /* Check the eval first */
8595 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8597 const char * errstr;
8598 sv_catpvs(errsv, "Propagated");
8599 errstr = SvPV_const(errsv, errlen);
8600 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8602 res = SvREFCNT_inc_simple_NN(sv);
8606 SvREFCNT_inc_simple_void_NN(res);
8615 why1 = "Call to &{$^H{";
8617 why3 = "}} did not return a defined value";
8619 (void)sv_2mortal(sv);
8626 PERL_STATIC_INLINE void
8627 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8628 PERL_ARGS_ASSERT_PARSE_IDENT;
8632 Perl_croak(aTHX_ "%s", ident_too_long);
8633 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8634 /* The UTF-8 case must come first, otherwise things
8635 * like c\N{COMBINING TILDE} would start failing, as the
8636 * isWORDCHAR_A case below would gobble the 'c' up.
8639 char *t = *s + UTF8SKIP(*s);
8640 while (isIDCONT_utf8((U8*)t))
8642 if (*d + (t - *s) > e)
8643 Perl_croak(aTHX_ "%s", ident_too_long);
8644 Copy(*s, *d, t - *s, char);
8648 else if ( isWORDCHAR_A(**s) ) {
8651 } while (isWORDCHAR_A(**s) && *d < e);
8653 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8658 else if (allow_package && **s == ':' && (*s)[1] == ':'
8659 /* Disallow things like Foo::$bar. For the curious, this is
8660 * the code path that triggers the "Bad name after" warning
8661 * when looking for barewords.
8663 && (*s)[2] != '$') {
8673 /* Returns a NUL terminated string, with the length of the string written to
8677 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8680 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8681 bool is_utf8 = cBOOL(UTF);
8683 PERL_ARGS_ASSERT_SCAN_WORD;
8685 parse_ident(&s, &d, e, allow_package, is_utf8);
8691 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8692 * iff Unicode semantics are to be used. The legal ones are any of:
8693 * a) all ASCII characters except:
8694 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
8696 * The final case currently doesn't get this far in the program, so we
8697 * don't test for it. If that were to change, it would be ok to allow it.
8698 * c) When not under Unicode rules, any upper Latin1 character
8699 * d) Otherwise, when unicode rules are used, all XIDS characters.
8701 * Because all ASCII characters have the same representation whether
8702 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8703 * '{' without knowing if is UTF-8 or not.
8704 * EBCDIC already uses the rules that ASCII platforms will use after the
8705 * deprecation cycle; see comment below about the deprecation. */
8707 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8708 (isGRAPH_A(*(s)) || ((is_utf8) \
8709 ? isIDFIRST_utf8((U8*) (s)) \
8711 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8713 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8714 (isGRAPH_A(*(s)) || ((is_utf8) \
8715 ? isIDFIRST_utf8((U8*) (s)) \
8716 : ! isASCII_utf8((U8*) (s))))
8720 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8722 I32 herelines = PL_parser->herelines;
8723 SSize_t bracket = -1;
8726 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8727 bool is_utf8 = cBOOL(UTF);
8728 I32 orig_copline = 0, tmp_copline = 0;
8730 PERL_ARGS_ASSERT_SCAN_IDENT;
8732 if (isSPACE(*s) || !*s)
8735 while (isDIGIT(*s)) {
8737 Perl_croak(aTHX_ "%s", ident_too_long);
8741 else { /* See if it is a "normal" identifier */
8742 parse_ident(&s, &d, e, 1, is_utf8);
8747 /* Either a digit variable, or parse_ident() found an identifier
8748 (anything valid as a bareword), so job done and return. */
8749 if (PL_lex_state != LEX_NORMAL)
8750 PL_lex_state = LEX_INTERPENDMAYBE;
8754 /* Here, it is not a run-of-the-mill identifier name */
8756 if (*s == '$' && s[1]
8757 && (isIDFIRST_lazy_if(s+1,is_utf8)
8758 || isDIGIT_A((U8)s[1])
8761 || strnEQ(s+1,"::",2)) )
8763 /* Dereferencing a value in a scalar variable.
8764 The alternatives are different syntaxes for a scalar variable.
8765 Using ' as a leading package separator isn't allowed. :: is. */
8768 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8770 bracket = s - SvPVX(PL_linestr);
8772 orig_copline = CopLINE(PL_curcop);
8773 if (s < PL_bufend && isSPACE(*s)) {
8777 if ((s <= PL_bufend - (is_utf8)
8780 && VALID_LEN_ONE_IDENT(s, is_utf8))
8782 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8783 * because often it has no graphic representation. (We can't get to
8784 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8787 ? ! isGRAPH_utf8( (U8*) s)
8788 : (! isGRAPH_L1( (U8) *s)
8789 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8791 deprecate("literal non-graphic characters in variable names");
8795 const STRLEN skip = UTF8SKIP(s);
8798 for ( i = 0; i < skip; i++ )
8806 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8807 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8811 /* Warn about ambiguous code after unary operators if {...} notation isn't
8812 used. There's no difference in ambiguity; it's merely a heuristic
8813 about when not to warn. */
8814 else if (ck_uni && bracket == -1)
8816 if (bracket != -1) {
8817 /* If we were processing {...} notation then... */
8818 if (isIDFIRST_lazy_if(d,is_utf8)) {
8819 /* if it starts as a valid identifier, assume that it is one.
8820 (the later check for } being at the expected point will trap
8821 cases where this doesn't pan out.) */
8822 d += is_utf8 ? UTF8SKIP(d) : 1;
8823 parse_ident(&s, &d, e, 1, is_utf8);
8825 tmp_copline = CopLINE(PL_curcop);
8826 if (s < PL_bufend && isSPACE(*s)) {
8829 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8830 /* ${foo[0]} and ${foo{bar}} notation. */
8831 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8832 const char * const brack =
8834 ((*s == '[') ? "[...]" : "{...}");
8835 orig_copline = CopLINE(PL_curcop);
8836 CopLINE_set(PL_curcop, tmp_copline);
8837 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8838 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8839 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8840 funny, dest, brack, funny, dest, brack);
8841 CopLINE_set(PL_curcop, orig_copline);
8844 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8845 PL_lex_allbrackets++;
8849 /* Handle extended ${^Foo} variables
8850 * 1999-02-27 mjd-perl-patch@plover.com */
8851 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8855 while (isWORDCHAR(*s) && d < e) {
8859 Perl_croak(aTHX_ "%s", ident_too_long);
8864 tmp_copline = CopLINE(PL_curcop);
8865 if (s < PL_bufend && isSPACE(*s)) {
8869 /* Expect to find a closing } after consuming any trailing whitespace.
8873 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8874 PL_lex_state = LEX_INTERPEND;
8877 if (PL_lex_state == LEX_NORMAL) {
8878 if (ckWARN(WARN_AMBIGUOUS)
8879 && (keyword(dest, d - dest, 0)
8880 || get_cvn_flags(dest, d - dest, is_utf8
8884 SV *tmp = newSVpvn_flags( dest, d - dest,
8885 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8888 orig_copline = CopLINE(PL_curcop);
8889 CopLINE_set(PL_curcop, tmp_copline);
8890 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8891 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8892 funny, SVfARG(tmp), funny, SVfARG(tmp));
8893 CopLINE_set(PL_curcop, orig_copline);
8898 /* Didn't find the closing } at the point we expected, so restore
8899 state such that the next thing to process is the opening { and */
8900 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8901 CopLINE_set(PL_curcop, orig_copline);
8902 PL_parser->herelines = herelines;
8906 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8907 PL_lex_state = LEX_INTERPEND;
8912 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8914 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8915 * found in the parse starting at 's', based on the subset that are valid
8916 * in this context input to this routine in 'valid_flags'. Advances s.
8917 * Returns TRUE if the input should be treated as a valid flag, so the next
8918 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8919 * upon first call on the current regex. This routine will set it to any
8920 * charset modifier found. The caller shouldn't change it. This way,
8921 * another charset modifier encountered in the parse can be detected as an
8922 * error, as we have decided to allow only one */
8925 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8927 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8928 if (isWORDCHAR_lazy_if(*s, UTF)) {
8929 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8930 UTF ? SVf_UTF8 : 0);
8932 /* Pretend that it worked, so will continue processing before
8941 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8942 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8943 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8944 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8945 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8946 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8947 case LOCALE_PAT_MOD:
8949 goto multiple_charsets;
8951 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8954 case UNICODE_PAT_MOD:
8956 goto multiple_charsets;
8958 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8961 case ASCII_RESTRICT_PAT_MOD:
8963 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8967 /* Error if previous modifier wasn't an 'a', but if it was, see
8968 * if, and accept, a second occurrence (only) */
8970 || get_regex_charset(*pmfl)
8971 != REGEX_ASCII_RESTRICTED_CHARSET)
8973 goto multiple_charsets;
8975 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8979 case DEPENDS_PAT_MOD:
8981 goto multiple_charsets;
8983 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8992 if (*charset != c) {
8993 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8995 else if (c == 'a') {
8996 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8997 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9000 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9003 /* Pretend that it worked, so will continue processing before dieing */
9009 S_scan_pat(pTHX_ char *start, I32 type)
9013 const char * const valid_flags =
9014 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9015 char charset = '\0'; /* character set modifier */
9016 unsigned int x_mod_count = 0;
9018 PERL_ARGS_ASSERT_SCAN_PAT;
9020 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9022 Perl_croak(aTHX_ "Search pattern not terminated");
9024 pm = (PMOP*)newPMOP(type, 0);
9025 if (PL_multi_open == '?') {
9026 /* This is the only point in the code that sets PMf_ONCE: */
9027 pm->op_pmflags |= PMf_ONCE;
9029 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9030 allows us to restrict the list needed by reset to just the ??
9032 assert(type != OP_TRANS);
9034 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9037 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9040 elements = mg->mg_len / sizeof(PMOP**);
9041 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9042 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9043 mg->mg_len = elements * sizeof(PMOP**);
9044 PmopSTASH_set(pm,PL_curstash);
9048 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9049 * anon CV. False positives like qr/[(?{]/ are harmless */
9051 if (type == OP_QR) {
9053 char *e, *p = SvPV(PL_lex_stuff, len);
9055 for (; p < e; p++) {
9056 if (p[0] == '(' && p[1] == '?'
9057 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9059 pm->op_pmflags |= PMf_HAS_CV;
9063 pm->op_pmflags |= PMf_IS_QR;
9066 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9067 &s, &charset, &x_mod_count))
9069 /* issue a warning if /c is specified,but /g is not */
9070 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9072 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9073 "Use of /c modifier is meaningless without /g" );
9076 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9078 PL_lex_op = (OP*)pm;
9079 pl_yylval.ival = OP_MATCH;
9084 S_scan_subst(pTHX_ char *start)
9091 char charset = '\0'; /* character set modifier */
9092 unsigned int x_mod_count = 0;
9095 PERL_ARGS_ASSERT_SCAN_SUBST;
9097 pl_yylval.ival = OP_NULL;
9099 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9102 Perl_croak(aTHX_ "Substitution pattern not terminated");
9106 first_start = PL_multi_start;
9107 first_line = CopLINE(PL_curcop);
9108 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9110 SvREFCNT_dec_NN(PL_lex_stuff);
9111 PL_lex_stuff = NULL;
9112 Perl_croak(aTHX_ "Substitution replacement not terminated");
9114 PL_multi_start = first_start; /* so whole substitution is taken together */
9116 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9120 if (*s == EXEC_PAT_MOD) {
9124 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9125 &s, &charset, &x_mod_count))
9131 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9133 if ((pm->op_pmflags & PMf_CONTINUE)) {
9134 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9138 SV * const repl = newSVpvs("");
9141 pm->op_pmflags |= PMf_EVAL;
9144 sv_catpvs(repl, "eval ");
9146 sv_catpvs(repl, "do ");
9148 sv_catpvs(repl, "{");
9149 sv_catsv(repl, PL_sublex_info.repl);
9150 sv_catpvs(repl, "}");
9152 SvREFCNT_dec(PL_sublex_info.repl);
9153 PL_sublex_info.repl = repl;
9155 if (CopLINE(PL_curcop) != first_line) {
9156 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9157 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9158 CopLINE(PL_curcop) - first_line;
9159 CopLINE_set(PL_curcop, first_line);
9162 PL_lex_op = (OP*)pm;
9163 pl_yylval.ival = OP_SUBST;
9168 S_scan_trans(pTHX_ char *start)
9175 bool nondestruct = 0;
9178 PERL_ARGS_ASSERT_SCAN_TRANS;
9180 pl_yylval.ival = OP_NULL;
9182 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9184 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9188 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9190 SvREFCNT_dec_NN(PL_lex_stuff);
9191 PL_lex_stuff = NULL;
9192 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9195 complement = del = squash = 0;
9199 complement = OPpTRANS_COMPLEMENT;
9202 del = OPpTRANS_DELETE;
9205 squash = OPpTRANS_SQUASH;
9217 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9218 o->op_private &= ~OPpTRANS_ALL;
9219 o->op_private |= del|squash|complement|
9220 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9221 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9224 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9231 Takes a pointer to the first < in <<FOO.
9232 Returns a pointer to the byte following <<FOO.
9234 This function scans a heredoc, which involves different methods
9235 depending on whether we are in a string eval, quoted construct, etc.
9236 This is because PL_linestr could containing a single line of input, or
9237 a whole string being evalled, or the contents of the current quote-
9240 The two basic methods are:
9241 - Steal lines from the input stream
9242 - Scan the heredoc in PL_linestr and remove it therefrom
9244 In a file scope or filtered eval, the first method is used; in a
9245 string eval, the second.
9247 In a quote-like operator, we have to choose between the two,
9248 depending on where we can find a newline. We peek into outer lex-
9249 ing scopes until we find one with a newline in it. If we reach the
9250 outermost lexing scope and it is a file, we use the stream method.
9251 Otherwise it is treated as an eval.
9255 S_scan_heredoc(pTHX_ char *s)
9257 I32 op_type = OP_SCALAR;
9264 const bool infile = PL_rsfp || PL_parser->filtered;
9265 const line_t origline = CopLINE(PL_curcop);
9266 LEXSHARED *shared = PL_parser->lex_shared;
9268 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9271 d = PL_tokenbuf + 1;
9272 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9273 *PL_tokenbuf = '\n';
9275 while (SPACE_OR_TAB(*peek))
9277 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9280 s = delimcpy(d, e, s, PL_bufend, term, &len);
9282 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9288 /* <<\FOO is equivalent to <<'FOO' */
9292 if (!isWORDCHAR_lazy_if(s,UTF))
9293 deprecate("bare << to mean <<\"\"");
9295 while (isWORDCHAR_lazy_if(peek,UTF)) {
9296 peek += UTF ? UTF8SKIP(peek) : 1;
9298 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9299 Copy(s, d, len, char);
9303 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9304 Perl_croak(aTHX_ "Delimiter for here document is too long");
9307 len = d - PL_tokenbuf;
9309 #ifndef PERL_STRICT_CR
9310 d = strchr(s, '\r');
9312 char * const olds = s;
9314 while (s < PL_bufend) {
9320 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9329 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9334 tmpstr = newSV_type(SVt_PVIV);
9338 SvIV_set(tmpstr, -1);
9340 else if (term == '`') {
9341 op_type = OP_BACKTICK;
9342 SvIV_set(tmpstr, '\\');
9345 PL_multi_start = origline + 1 + PL_parser->herelines;
9346 PL_multi_open = PL_multi_close = '<';
9347 /* inside a string eval or quote-like operator */
9348 if (!infile || PL_lex_inwhat) {
9351 char * const olds = s;
9352 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9353 /* These two fields are not set until an inner lexing scope is
9354 entered. But we need them set here. */
9355 shared->ls_bufptr = s;
9356 shared->ls_linestr = PL_linestr;
9358 /* Look for a newline. If the current buffer does not have one,
9359 peek into the line buffer of the parent lexing scope, going
9360 up as many levels as necessary to find one with a newline
9363 while (!(s = (char *)memchr(
9364 (void *)shared->ls_bufptr, '\n',
9365 SvEND(shared->ls_linestr)-shared->ls_bufptr
9367 shared = shared->ls_prev;
9368 /* shared is only null if we have gone beyond the outermost
9369 lexing scope. In a file, we will have broken out of the
9370 loop in the previous iteration. In an eval, the string buf-
9371 fer ends with "\n;", so the while condition above will have
9372 evaluated to false. So shared can never be null. Or so you
9373 might think. Odd syntax errors like s;@{<<; can gobble up
9374 the implicit semicolon at the end of a flie, causing the
9375 file handle to be closed even when we are not in a string
9376 eval. So shared may be null in that case. */
9377 if (UNLIKELY(!shared))
9379 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9380 most lexing scope. In a file, shared->ls_linestr at that
9381 level is just one line, so there is no body to steal. */
9382 if (infile && !shared->ls_prev) {
9388 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9391 linestr = shared->ls_linestr;
9392 bufend = SvEND(linestr);
9394 while (s < bufend - len + 1
9395 && memNE(s,PL_tokenbuf,len) )
9398 ++PL_parser->herelines;
9400 if (s >= bufend - len + 1) {
9403 sv_setpvn(tmpstr,d+1,s-d);
9405 /* the preceding stmt passes a newline */
9406 PL_parser->herelines++;
9408 /* s now points to the newline after the heredoc terminator.
9409 d points to the newline before the body of the heredoc.
9412 /* We are going to modify linestr in place here, so set
9413 aside copies of the string if necessary for re-evals or
9415 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9416 check shared->re_eval_str. */
9417 if (shared->re_eval_start || shared->re_eval_str) {
9418 /* Set aside the rest of the regexp */
9419 if (!shared->re_eval_str)
9420 shared->re_eval_str =
9421 newSVpvn(shared->re_eval_start,
9422 bufend - shared->re_eval_start);
9423 shared->re_eval_start -= s-d;
9426 && CxTYPE(cx) == CXt_EVAL
9427 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
9428 && cx->blk_eval.cur_text == linestr)
9430 cx->blk_eval.cur_text = newSVsv(linestr);
9431 SvSCREAM_on(cx->blk_eval.cur_text);
9433 /* Copy everything from s onwards back to d. */
9434 Move(s,d,bufend-s + 1,char);
9435 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9436 /* Setting PL_bufend only applies when we have not dug deeper
9437 into other scopes, because sublex_done sets PL_bufend to
9438 SvEND(PL_linestr). */
9439 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9446 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9447 term = PL_tokenbuf[1];
9449 linestr_save = PL_linestr; /* must restore this afterwards */
9450 d = s; /* and this */
9451 PL_linestr = newSVpvs("");
9452 PL_bufend = SvPVX(PL_linestr);
9454 PL_bufptr = PL_bufend;
9455 CopLINE_set(PL_curcop,
9456 origline + 1 + PL_parser->herelines);
9457 if (!lex_next_chunk(LEX_NO_TERM)
9458 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9459 /* Simply freeing linestr_save might seem simpler here, as it
9460 does not matter what PL_linestr points to, since we are
9461 about to croak; but in a quote-like op, linestr_save
9462 will have been prospectively freed already, via
9463 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9464 restore PL_linestr. */
9465 SvREFCNT_dec_NN(PL_linestr);
9466 PL_linestr = linestr_save;
9469 CopLINE_set(PL_curcop, origline);
9470 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9471 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9472 /* ^That should be enough to avoid this needing to grow: */
9473 sv_catpvs(PL_linestr, "\n\0");
9474 assert(s == SvPVX(PL_linestr));
9475 PL_bufend = SvEND(PL_linestr);
9478 PL_parser->herelines++;
9479 PL_last_lop = PL_last_uni = NULL;
9480 #ifndef PERL_STRICT_CR
9481 if (PL_bufend - PL_linestart >= 2) {
9482 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
9483 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9485 PL_bufend[-2] = '\n';
9487 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9489 else if (PL_bufend[-1] == '\r')
9490 PL_bufend[-1] = '\n';
9492 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9493 PL_bufend[-1] = '\n';
9495 if (*s == term && PL_bufend-s >= len
9496 && memEQ(s,PL_tokenbuf + 1,len)) {
9497 SvREFCNT_dec(PL_linestr);
9498 PL_linestr = linestr_save;
9499 PL_linestart = SvPVX(linestr_save);
9500 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9505 sv_catsv(tmpstr,PL_linestr);
9509 PL_multi_end = origline + PL_parser->herelines;
9510 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9511 SvPV_shrink_to_cur(tmpstr);
9514 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9516 else if (IN_ENCODING)
9517 sv_recode_to_utf8(tmpstr, _get_encoding());
9519 PL_lex_stuff = tmpstr;
9520 pl_yylval.ival = op_type;
9524 SvREFCNT_dec(tmpstr);
9525 CopLINE_set(PL_curcop, origline);
9526 missingterm(PL_tokenbuf + 1);
9530 takes: current position in input buffer
9531 returns: new position in input buffer
9532 side-effects: pl_yylval and lex_op are set.
9537 <<>> read from ARGV without magic open
9538 <FH> read from filehandle
9539 <pkg::FH> read from package qualified filehandle
9540 <pkg'FH> read from package qualified filehandle
9541 <$fh> read from filehandle in $fh
9547 S_scan_inputsymbol(pTHX_ char *start)
9549 char *s = start; /* current position in buffer */
9552 bool nomagicopen = FALSE;
9553 char *d = PL_tokenbuf; /* start of temp holding space */
9554 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9556 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9558 end = strchr(s, '\n');
9561 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9568 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9570 /* die if we didn't have space for the contents of the <>,
9571 or if it didn't end, or if we see a newline
9574 if (len >= (I32)sizeof PL_tokenbuf)
9575 Perl_croak(aTHX_ "Excessively long <> operator");
9577 Perl_croak(aTHX_ "Unterminated <> operator");
9582 Remember, only scalar variables are interpreted as filehandles by
9583 this code. Anything more complex (e.g., <$fh{$num}>) will be
9584 treated as a glob() call.
9585 This code makes use of the fact that except for the $ at the front,
9586 a scalar variable and a filehandle look the same.
9588 if (*d == '$' && d[1]) d++;
9590 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9591 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9592 d += UTF ? UTF8SKIP(d) : 1;
9594 /* If we've tried to read what we allow filehandles to look like, and
9595 there's still text left, then it must be a glob() and not a getline.
9596 Use scan_str to pull out the stuff between the <> and treat it
9597 as nothing more than a string.
9600 if (d - PL_tokenbuf != len) {
9601 pl_yylval.ival = OP_GLOB;
9602 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9604 Perl_croak(aTHX_ "Glob not terminated");
9608 bool readline_overriden = FALSE;
9610 /* we're in a filehandle read situation */
9613 /* turn <> into <ARGV> */
9615 Copy("ARGV",d,5,char);
9617 /* Check whether readline() is overriden */
9618 if ((gv_readline = gv_override("readline",8)))
9619 readline_overriden = TRUE;
9621 /* if <$fh>, create the ops to turn the variable into a
9625 /* try to find it in the pad for this block, otherwise find
9626 add symbol table ops
9628 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9629 if (tmp != NOT_IN_PAD) {
9630 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9631 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9632 HEK * const stashname = HvNAME_HEK(stash);
9633 SV * const sym = sv_2mortal(newSVhek(stashname));
9634 sv_catpvs(sym, "::");
9640 OP * const o = newOP(OP_PADSV, 0);
9642 PL_lex_op = readline_overriden
9643 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9644 op_append_elem(OP_LIST, o,
9645 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9646 : (OP*)newUNOP(OP_READLINE, 0, o);
9654 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9656 PL_lex_op = readline_overriden
9657 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9658 op_append_elem(OP_LIST,
9659 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9660 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9661 : (OP*)newUNOP(OP_READLINE, 0,
9662 newUNOP(OP_RV2SV, 0,
9663 newGVOP(OP_GV, 0, gv)));
9665 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9666 pl_yylval.ival = OP_NULL;
9669 /* If it's none of the above, it must be a literal filehandle
9670 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9672 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9673 PL_lex_op = readline_overriden
9674 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9675 op_append_elem(OP_LIST,
9676 newGVOP(OP_GV, 0, gv),
9677 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9678 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9679 pl_yylval.ival = OP_NULL;
9689 start position in buffer
9690 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9691 only if they are of the open/close form
9692 keep_delims preserve the delimiters around the string
9693 re_reparse compiling a run-time /(?{})/:
9694 collapse // to /, and skip encoding src
9695 delimp if non-null, this is set to the position of
9696 the closing delimiter, or just after it if
9697 the closing and opening delimiters differ
9698 (i.e., the opening delimiter of a substitu-
9700 returns: position to continue reading from buffer
9701 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9702 updates the read buffer.
9704 This subroutine pulls a string out of the input. It is called for:
9705 q single quotes q(literal text)
9706 ' single quotes 'literal text'
9707 qq double quotes qq(interpolate $here please)
9708 " double quotes "interpolate $here please"
9709 qx backticks qx(/bin/ls -l)
9710 ` backticks `/bin/ls -l`
9711 qw quote words @EXPORT_OK = qw( func() $spam )
9712 m// regexp match m/this/
9713 s/// regexp substitute s/this/that/
9714 tr/// string transliterate tr/this/that/
9715 y/// string transliterate y/this/that/
9716 ($*@) sub prototypes sub foo ($)
9717 (stuff) sub attr parameters sub foo : attr(stuff)
9718 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9720 In most of these cases (all but <>, patterns and transliterate)
9721 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9722 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9723 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9726 It skips whitespace before the string starts, and treats the first
9727 character as the delimiter. If the delimiter is one of ([{< then
9728 the corresponding "close" character )]}> is used as the closing
9729 delimiter. It allows quoting of delimiters, and if the string has
9730 balanced delimiters ([{<>}]) it allows nesting.
9732 On success, the SV with the resulting string is put into lex_stuff or,
9733 if that is already non-NULL, into lex_repl. The second case occurs only
9734 when parsing the RHS of the special constructs s/// and tr/// (y///).
9735 For convenience, the terminating delimiter character is stuffed into
9740 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9744 SV *sv; /* scalar value: string */
9745 const char *tmps; /* temp string, used for delimiter matching */
9746 char *s = start; /* current position in the buffer */
9747 char term; /* terminating character */
9748 char *to; /* current position in the sv's data */
9749 I32 brackets = 1; /* bracket nesting level */
9750 bool has_utf8 = FALSE; /* is there any utf8 content? */
9751 I32 termcode; /* terminating char. code */
9752 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9753 STRLEN termlen; /* length of terminating string */
9754 int last_off = 0; /* last position for nesting bracket */
9757 PERL_ARGS_ASSERT_SCAN_STR;
9759 /* skip space before the delimiter */
9764 /* mark where we are, in case we need to report errors */
9767 /* after skipping whitespace, the next character is the terminator */
9770 termcode = termstr[0] = term;
9774 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9775 Copy(s, termstr, termlen, U8);
9776 if (!UTF8_IS_INVARIANT(term))
9780 /* mark where we are */
9781 PL_multi_start = CopLINE(PL_curcop);
9782 PL_multi_open = term;
9783 herelines = PL_parser->herelines;
9785 /* find corresponding closing delimiter */
9786 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9787 termcode = termstr[0] = term = tmps[5];
9789 PL_multi_close = term;
9791 if (PL_multi_open == PL_multi_close) {
9792 keep_bracketed_quoted = FALSE;
9795 /* create a new SV to hold the contents. 79 is the SV's initial length.
9796 What a random number. */
9797 sv = newSV_type(SVt_PVIV);
9799 SvIV_set(sv, termcode);
9800 (void)SvPOK_only(sv); /* validate pointer */
9802 /* move past delimiter and try to read a complete string */
9804 sv_catpvn(sv, s, termlen);
9807 if (IN_ENCODING && !UTF && !re_reparse) {
9811 int offset = s - SvPVX_const(PL_linestr);
9812 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9813 &offset, (char*)termstr, termlen);
9817 if (SvIsCOW(PL_linestr)) {
9818 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9819 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9820 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9821 char *buf = SvPVX(PL_linestr);
9822 bufend_pos = PL_parser->bufend - buf;
9823 bufptr_pos = PL_parser->bufptr - buf;
9824 oldbufptr_pos = PL_parser->oldbufptr - buf;
9825 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9826 linestart_pos = PL_parser->linestart - buf;
9827 last_uni_pos = PL_parser->last_uni
9828 ? PL_parser->last_uni - buf
9830 last_lop_pos = PL_parser->last_lop
9831 ? PL_parser->last_lop - buf
9834 PL_parser->lex_shared->re_eval_start ?
9835 PL_parser->lex_shared->re_eval_start - buf : 0;
9838 sv_force_normal(PL_linestr);
9840 buf = SvPVX(PL_linestr);
9841 PL_parser->bufend = buf + bufend_pos;
9842 PL_parser->bufptr = buf + bufptr_pos;
9843 PL_parser->oldbufptr = buf + oldbufptr_pos;
9844 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9845 PL_parser->linestart = buf + linestart_pos;
9846 if (PL_parser->last_uni)
9847 PL_parser->last_uni = buf + last_uni_pos;
9848 if (PL_parser->last_lop)
9849 PL_parser->last_lop = buf + last_lop_pos;
9850 if (PL_parser->lex_shared->re_eval_start)
9851 PL_parser->lex_shared->re_eval_start =
9852 buf + re_eval_start_pos;
9855 ns = SvPVX_const(PL_linestr) + offset;
9856 svlast = SvEND(sv) - 1;
9858 for (; s < ns; s++) {
9859 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9860 COPLINE_INC_WITH_HERELINES;
9863 goto read_more_line;
9865 /* handle quoted delimiters */
9866 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9868 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9870 if ((svlast-1 - t) % 2) {
9871 if (!keep_bracketed_quoted) {
9874 SvCUR_set(sv, SvCUR(sv) - 1);
9879 if (PL_multi_open == PL_multi_close) {
9885 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9886 /* At here, all closes are "was quoted" one,
9887 so we don't check PL_multi_close. */
9889 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9894 else if (*t == PL_multi_open)
9902 SvCUR_set(sv, w - SvPVX_const(sv));
9904 last_off = w - SvPVX(sv);
9905 if (--brackets <= 0)
9911 SvCUR_set(sv, SvCUR(sv) - 1);
9917 /* extend sv if need be */
9918 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9919 /* set 'to' to the next character in the sv's string */
9920 to = SvPVX(sv)+SvCUR(sv);
9922 /* if open delimiter is the close delimiter read unbridle */
9923 if (PL_multi_open == PL_multi_close) {
9924 for (; s < PL_bufend; s++,to++) {
9925 /* embedded newlines increment the current line number */
9926 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9927 COPLINE_INC_WITH_HERELINES;
9928 /* handle quoted delimiters */
9929 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9930 if (!keep_bracketed_quoted
9932 || (re_reparse && s[1] == '\\'))
9935 else /* any other quotes are simply copied straight through */
9938 /* terminate when run out of buffer (the for() condition), or
9939 have found the terminator */
9940 else if (*s == term) {
9943 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9946 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9952 /* if the terminator isn't the same as the start character (e.g.,
9953 matched brackets), we have to allow more in the quoting, and
9954 be prepared for nested brackets.
9957 /* read until we run out of string, or we find the terminator */
9958 for (; s < PL_bufend; s++,to++) {
9959 /* embedded newlines increment the line count */
9960 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9961 COPLINE_INC_WITH_HERELINES;
9962 /* backslashes can escape the open or closing characters */
9963 if (*s == '\\' && s+1 < PL_bufend) {
9964 if (!keep_bracketed_quoted
9965 && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9972 /* allow nested opens and closes */
9973 else if (*s == PL_multi_close && --brackets <= 0)
9975 else if (*s == PL_multi_open)
9977 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9982 /* terminate the copied string and update the sv's end-of-string */
9984 SvCUR_set(sv, to - SvPVX_const(sv));
9987 * this next chunk reads more into the buffer if we're not done yet
9991 break; /* handle case where we are done yet :-) */
9993 #ifndef PERL_STRICT_CR
9994 if (to - SvPVX_const(sv) >= 2) {
9995 if ( (to[-2] == '\r' && to[-1] == '\n')
9996 || (to[-2] == '\n' && to[-1] == '\r'))
10000 SvCUR_set(sv, to - SvPVX_const(sv));
10002 else if (to[-1] == '\r')
10005 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10010 /* if we're out of file, or a read fails, bail and reset the current
10011 line marker so we can report where the unterminated string began
10013 COPLINE_INC_WITH_HERELINES;
10014 PL_bufptr = PL_bufend;
10015 if (!lex_next_chunk(0)) {
10017 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10023 /* at this point, we have successfully read the delimited string */
10025 if (!IN_ENCODING || UTF || re_reparse) {
10028 sv_catpvn(sv, s, termlen);
10031 if (has_utf8 || (IN_ENCODING && !re_reparse))
10034 PL_multi_end = CopLINE(PL_curcop);
10035 CopLINE_set(PL_curcop, PL_multi_start);
10036 PL_parser->herelines = herelines;
10038 /* if we allocated too much space, give some back */
10039 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10040 SvLEN_set(sv, SvCUR(sv) + 1);
10041 SvPV_renew(sv, SvLEN(sv));
10044 /* decide whether this is the first or second quoted string we've read
10049 PL_sublex_info.repl = sv;
10052 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10058 takes: pointer to position in buffer
10059 returns: pointer to new position in buffer
10060 side-effects: builds ops for the constant in pl_yylval.op
10062 Read a number in any of the formats that Perl accepts:
10064 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10065 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10066 0b[01](_?[01])* binary integers
10067 0[0-7](_?[0-7])* octal integers
10068 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10069 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10071 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10074 If it reads a number without a decimal point or an exponent, it will
10075 try converting the number to an integer and see if it can do so
10076 without loss of precision.
10080 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10082 const char *s = start; /* current position in buffer */
10083 char *d; /* destination in temp buffer */
10084 char *e; /* end of temp buffer */
10085 NV nv; /* number read, as a double */
10086 SV *sv = NULL; /* place to put the converted number */
10087 bool floatit; /* boolean: int or float? */
10088 const char *lastub = NULL; /* position of last underbar */
10089 static const char* const number_too_long = "Number too long";
10090 /* Hexadecimal floating point.
10092 * In many places (where we have quads and NV is IEEE 754 double)
10093 * we can fit the mantissa bits of a NV into an unsigned quad.
10094 * (Note that UVs might not be quads even when we have quads.)
10095 * This will not work everywhere, though (either no quads, or
10096 * using long doubles), in which case we have to resort to NV,
10097 * which will probably mean horrible loss of precision due to
10098 * multiple fp operations. */
10099 bool hexfp = FALSE;
10100 int total_bits = 0;
10101 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10102 # define HEXFP_UQUAD
10103 Uquad_t hexfp_uquad = 0;
10104 int hexfp_frac_bits = 0;
10109 NV hexfp_mult = 1.0;
10110 UV high_non_zero = 0; /* highest digit */
10112 PERL_ARGS_ASSERT_SCAN_NUM;
10114 /* We use the first character to decide what type of number this is */
10118 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10120 /* if it starts with a 0, it could be an octal number, a decimal in
10121 0.13 disguise, or a hexadecimal number, or a binary number. */
10125 u holds the "number so far"
10126 shift the power of 2 of the base
10127 (hex == 4, octal == 3, binary == 1)
10128 overflowed was the number more than we can hold?
10130 Shift is used when we add a digit. It also serves as an "are
10131 we in octal/hex/binary?" indicator to disallow hex characters
10132 when in octal mode.
10137 bool overflowed = FALSE;
10138 bool just_zero = TRUE; /* just plain 0 or binary number? */
10139 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10140 static const char* const bases[5] =
10141 { "", "binary", "", "octal", "hexadecimal" };
10142 static const char* const Bases[5] =
10143 { "", "Binary", "", "Octal", "Hexadecimal" };
10144 static const char* const maxima[5] =
10146 "0b11111111111111111111111111111111",
10150 const char *base, *Base, *max;
10152 /* check for hex */
10153 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10157 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10162 /* check for a decimal in disguise */
10163 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10165 /* so it must be octal */
10172 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10173 "Misplaced _ in number");
10177 base = bases[shift];
10178 Base = Bases[shift];
10179 max = maxima[shift];
10181 /* read the rest of the number */
10183 /* x is used in the overflow test,
10184 b is the digit we're adding on. */
10189 /* if we don't mention it, we're done */
10193 /* _ are ignored -- but warned about if consecutive */
10195 if (lastub && s == lastub + 1)
10196 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10197 "Misplaced _ in number");
10201 /* 8 and 9 are not octal */
10202 case '8': case '9':
10204 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10208 case '2': case '3': case '4':
10209 case '5': case '6': case '7':
10211 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10214 case '0': case '1':
10215 b = *s++ & 15; /* ASCII digit -> value of digit */
10219 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10220 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10221 /* make sure they said 0x */
10224 b = (*s++ & 7) + 9;
10226 /* Prepare to put the digit we have onto the end
10227 of the number so far. We check for overflows.
10233 x = u << shift; /* make room for the digit */
10235 total_bits += shift;
10237 if ((x >> shift) != u
10238 && !(PL_hints & HINT_NEW_BINARY)) {
10241 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10242 "Integer overflow in %s number",
10245 u = x | b; /* add the digit to the end */
10248 n *= nvshift[shift];
10249 /* If an NV has not enough bits in its
10250 * mantissa to represent an UV this summing of
10251 * small low-order numbers is a waste of time
10252 * (because the NV cannot preserve the
10253 * low-order bits anyway): we could just
10254 * remember when did we overflow and in the
10255 * end just multiply n by the right
10260 if (high_non_zero == 0 && b > 0)
10263 /* this could be hexfp, but peek ahead
10264 * to avoid matching ".." */
10265 if (UNLIKELY(HEXFP_PEEK(s))) {
10273 /* if we get here, we had success: make a scalar value from
10278 /* final misplaced underbar check */
10279 if (s[-1] == '_') {
10280 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10283 if (UNLIKELY(HEXFP_PEEK(s))) {
10284 /* Do sloppy (on the underbars) but quick detection
10285 * (and value construction) for hexfp, the decimal
10286 * detection will shortly be more thorough with the
10287 * underbar checks. */
10291 #else /* HEXFP_NV */
10296 NV mult = 1 / 16.0;
10299 while (isXDIGIT(*h) || *h == '_') {
10300 if (isXDIGIT(*h)) {
10301 U8 b = XDIGIT_VALUE(*h);
10302 total_bits += shift;
10304 hexfp_uquad <<= shift;
10306 hexfp_frac_bits += shift;
10307 #else /* HEXFP_NV */
10308 hexfp_nv += b * mult;
10316 if (total_bits >= 4) {
10317 if (high_non_zero < 0x8)
10319 if (high_non_zero < 0x4)
10321 if (high_non_zero < 0x2)
10325 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10326 bool negexp = FALSE;
10330 else if (*h == '-') {
10336 while (isDIGIT(*h) || *h == '_') {
10339 hexfp_exp += *h - '0';
10342 && -hexfp_exp < NV_MIN_EXP - 1)
10344 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10345 "Hexadecimal float: exponent underflow");
10352 && hexfp_exp > NV_MAX_EXP - 1)
10354 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10355 "Hexadecimal float: exponent overflow");
10364 hexfp_exp = -hexfp_exp;
10366 hexfp_exp -= hexfp_frac_bits;
10368 hexfp_mult = pow(2.0, hexfp_exp);
10376 if (n > 4294967295.0)
10377 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10378 "%s number > %s non-portable",
10384 if (u > 0xffffffff)
10385 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10386 "%s number > %s non-portable",
10391 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10392 sv = new_constant(start, s - start, "integer",
10393 sv, NULL, NULL, 0);
10394 else if (PL_hints & HINT_NEW_BINARY)
10395 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10400 handle decimal numbers.
10401 we're also sent here when we read a 0 as the first digit
10403 case '1': case '2': case '3': case '4': case '5':
10404 case '6': case '7': case '8': case '9': case '.':
10407 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10416 /* read next group of digits and _ and copy into d */
10419 || UNLIKELY(hexfp && isXDIGIT(*s)))
10421 /* skip underscores, checking for misplaced ones
10425 if (lastub && s == lastub + 1)
10426 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10427 "Misplaced _ in number");
10431 /* check for end of fixed-length buffer */
10433 Perl_croak(aTHX_ "%s", number_too_long);
10434 /* if we're ok, copy the character */
10439 /* final misplaced underbar check */
10440 if (lastub && s == lastub + 1) {
10441 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10444 /* read a decimal portion if there is one. avoid
10445 3..5 being interpreted as the number 3. followed
10448 if (*s == '.' && s[1] != '.') {
10453 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10454 "Misplaced _ in number");
10458 /* copy, ignoring underbars, until we run out of digits.
10462 || UNLIKELY(hexfp && isXDIGIT(*s));
10465 /* fixed length buffer check */
10467 Perl_croak(aTHX_ "%s", number_too_long);
10469 if (lastub && s == lastub + 1)
10470 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10471 "Misplaced _ in number");
10477 /* fractional part ending in underbar? */
10478 if (s[-1] == '_') {
10479 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10480 "Misplaced _ in number");
10482 if (*s == '.' && isDIGIT(s[1])) {
10483 /* oops, it's really a v-string, but without the "v" */
10489 /* read exponent part, if present */
10490 if ((isALPHA_FOLD_EQ(*s, 'e')
10491 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10492 && strchr("+-0123456789_", s[1]))
10496 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10497 ditto for p (hexfloats) */
10498 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10499 /* At least some Mach atof()s don't grok 'E' */
10502 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10509 /* stray preinitial _ */
10511 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10512 "Misplaced _ in number");
10516 /* allow positive or negative exponent */
10517 if (*s == '+' || *s == '-')
10520 /* stray initial _ */
10522 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10523 "Misplaced _ in number");
10527 /* read digits of exponent */
10528 while (isDIGIT(*s) || *s == '_') {
10531 Perl_croak(aTHX_ "%s", number_too_long);
10535 if (((lastub && s == lastub + 1)
10536 || (!isDIGIT(s[1]) && s[1] != '_')))
10537 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10538 "Misplaced _ in number");
10546 We try to do an integer conversion first if no characters
10547 indicating "float" have been found.
10552 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10554 if (flags == IS_NUMBER_IN_UV) {
10556 sv = newSViv(uv); /* Prefer IVs over UVs. */
10559 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10560 if (uv <= (UV) IV_MIN)
10561 sv = newSViv(-(IV)uv);
10568 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10569 /* terminate the string */
10571 if (UNLIKELY(hexfp)) {
10572 # ifdef NV_MANT_DIG
10573 if (total_bits > NV_MANT_DIG)
10574 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10575 "Hexadecimal float: mantissa overflow");
10578 nv = hexfp_uquad * hexfp_mult;
10579 #else /* HEXFP_NV */
10580 nv = hexfp_nv * hexfp_mult;
10583 nv = Atof(PL_tokenbuf);
10585 RESTORE_LC_NUMERIC_UNDERLYING();
10590 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10591 const char *const key = floatit ? "float" : "integer";
10592 const STRLEN keylen = floatit ? 5 : 7;
10593 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10594 key, keylen, sv, NULL, NULL, 0);
10598 /* if it starts with a v, it could be a v-string */
10601 sv = newSV(5); /* preallocate storage space */
10602 ENTER_with_name("scan_vstring");
10604 s = scan_vstring(s, PL_bufend, sv);
10605 SvREFCNT_inc_simple_void_NN(sv);
10606 LEAVE_with_name("scan_vstring");
10610 /* make the op for the constant and return */
10613 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10615 lvalp->opval = NULL;
10621 S_scan_formline(pTHX_ char *s)
10625 SV * const stuff = newSVpvs("");
10626 bool needargs = FALSE;
10627 bool eofmt = FALSE;
10629 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10631 while (!needargs) {
10634 #ifdef PERL_STRICT_CR
10635 while (SPACE_OR_TAB(*t))
10638 while (SPACE_OR_TAB(*t) || *t == '\r')
10641 if (*t == '\n' || t == PL_bufend) {
10646 eol = (char *) memchr(s,'\n',PL_bufend-s);
10650 for (t = s; t < eol; t++) {
10651 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10653 goto enough; /* ~~ must be first line in formline */
10655 if (*t == '@' || *t == '^')
10659 sv_catpvn(stuff, s, eol-s);
10660 #ifndef PERL_STRICT_CR
10661 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10662 char *end = SvPVX(stuff) + SvCUR(stuff);
10665 SvCUR_set(stuff, SvCUR(stuff) - 1);
10673 if ((PL_rsfp || PL_parser->filtered)
10674 && PL_parser->form_lex_state == LEX_NORMAL) {
10676 PL_bufptr = PL_bufend;
10677 COPLINE_INC_WITH_HERELINES;
10678 got_some = lex_next_chunk(0);
10679 CopLINE_dec(PL_curcop);
10687 if (!SvCUR(stuff) || needargs)
10688 PL_lex_state = PL_parser->form_lex_state;
10689 if (SvCUR(stuff)) {
10690 PL_expect = XSTATE;
10692 const char *s2 = s;
10693 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10697 PL_expect = XTERMBLOCK;
10698 NEXTVAL_NEXTTOKE.ival = 0;
10701 NEXTVAL_NEXTTOKE.ival = 0;
10702 force_next(FORMLBRACK);
10705 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10707 else if (IN_ENCODING)
10708 sv_recode_to_utf8(stuff, _get_encoding());
10710 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10714 SvREFCNT_dec(stuff);
10716 PL_lex_formbrack = 0;
10722 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10724 const I32 oldsavestack_ix = PL_savestack_ix;
10725 CV* const outsidecv = PL_compcv;
10727 SAVEI32(PL_subline);
10728 save_item(PL_subname);
10729 SAVESPTR(PL_compcv);
10731 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10732 CvFLAGS(PL_compcv) |= flags;
10734 PL_subline = CopLINE(PL_curcop);
10735 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10736 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10737 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10738 if (outsidecv && CvPADLIST(outsidecv))
10739 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10741 return oldsavestack_ix;
10745 S_yywarn(pTHX_ const char *const s, U32 flags)
10747 PERL_ARGS_ASSERT_YYWARN;
10749 PL_in_eval |= EVAL_WARNONLY;
10750 yyerror_pv(s, flags);
10755 Perl_yyerror(pTHX_ const char *const s)
10757 PERL_ARGS_ASSERT_YYERROR;
10758 return yyerror_pvn(s, strlen(s), 0);
10762 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10764 PERL_ARGS_ASSERT_YYERROR_PV;
10765 return yyerror_pvn(s, strlen(s), flags);
10769 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10771 const char *context = NULL;
10774 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10775 int yychar = PL_parser->yychar;
10777 PERL_ARGS_ASSERT_YYERROR_PVN;
10779 if (!yychar || (yychar == ';' && !PL_rsfp))
10780 sv_catpvs(where_sv, "at EOF");
10781 else if ( PL_oldoldbufptr
10782 && PL_bufptr > PL_oldoldbufptr
10783 && PL_bufptr - PL_oldoldbufptr < 200
10784 && PL_oldoldbufptr != PL_oldbufptr
10785 && PL_oldbufptr != PL_bufptr)
10789 The code below is removed for NetWare because it abends/crashes on NetWare
10790 when the script has error such as not having the closing quotes like:
10791 if ($var eq "value)
10792 Checking of white spaces is anyway done in NetWare code.
10795 while (isSPACE(*PL_oldoldbufptr))
10798 context = PL_oldoldbufptr;
10799 contlen = PL_bufptr - PL_oldoldbufptr;
10801 else if ( PL_oldbufptr
10802 && PL_bufptr > PL_oldbufptr
10803 && PL_bufptr - PL_oldbufptr < 200
10804 && PL_oldbufptr != PL_bufptr) {
10807 The code below is removed for NetWare because it abends/crashes on NetWare
10808 when the script has error such as not having the closing quotes like:
10809 if ($var eq "value)
10810 Checking of white spaces is anyway done in NetWare code.
10813 while (isSPACE(*PL_oldbufptr))
10816 context = PL_oldbufptr;
10817 contlen = PL_bufptr - PL_oldbufptr;
10819 else if (yychar > 255)
10820 sv_catpvs(where_sv, "next token ???");
10821 else if (yychar == YYEMPTY) {
10822 if ( PL_lex_state == LEX_NORMAL
10823 || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10824 sv_catpvs(where_sv, "at end of line");
10825 else if (PL_lex_inpat)
10826 sv_catpvs(where_sv, "within pattern");
10828 sv_catpvs(where_sv, "within string");
10831 sv_catpvs(where_sv, "next char ");
10833 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10834 else if (isPRINT_LC(yychar)) {
10835 const char string = yychar;
10836 sv_catpvn(where_sv, &string, 1);
10839 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10841 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10842 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10843 OutCopFILE(PL_curcop),
10844 (IV)(PL_parser->preambling == NOLINE
10845 ? CopLINE(PL_curcop)
10846 : PL_parser->preambling));
10848 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10849 UTF8fARG(UTF, contlen, context));
10851 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10852 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10853 Perl_sv_catpvf(aTHX_ msg,
10854 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10855 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10858 if (PL_in_eval & EVAL_WARNONLY) {
10859 PL_in_eval &= ~EVAL_WARNONLY;
10860 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10864 if (PL_error_count >= 10) {
10866 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10867 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10868 SVfARG(errsv), OutCopFILE(PL_curcop));
10870 Perl_croak(aTHX_ "%s has too many errors.\n",
10871 OutCopFILE(PL_curcop));
10874 PL_in_my_stash = NULL;
10879 S_swallow_bom(pTHX_ U8 *s)
10881 const STRLEN slen = SvCUR(PL_linestr);
10883 PERL_ARGS_ASSERT_SWALLOW_BOM;
10887 if (s[1] == 0xFE) {
10888 /* UTF-16 little-endian? (or UTF-32LE?) */
10889 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10890 /* diag_listed_as: Unsupported script encoding %s */
10891 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10892 #ifndef PERL_NO_UTF16_FILTER
10893 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10895 if (PL_bufend > (char*)s) {
10896 s = add_utf16_textfilter(s, TRUE);
10899 /* diag_listed_as: Unsupported script encoding %s */
10900 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10905 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10906 #ifndef PERL_NO_UTF16_FILTER
10907 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10909 if (PL_bufend > (char *)s) {
10910 s = add_utf16_textfilter(s, FALSE);
10913 /* diag_listed_as: Unsupported script encoding %s */
10914 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10918 case BOM_UTF8_FIRST_BYTE: {
10919 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10920 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10921 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10922 s += len + 1; /* UTF-8 */
10929 if (s[2] == 0xFE && s[3] == 0xFF) {
10930 /* UTF-32 big-endian */
10931 /* diag_listed_as: Unsupported script encoding %s */
10932 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10935 else if (s[2] == 0 && s[3] != 0) {
10938 * are a good indicator of UTF-16BE. */
10939 #ifndef PERL_NO_UTF16_FILTER
10940 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10941 s = add_utf16_textfilter(s, FALSE);
10943 /* diag_listed_as: Unsupported script encoding %s */
10944 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10951 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10954 * are a good indicator of UTF-16LE. */
10955 #ifndef PERL_NO_UTF16_FILTER
10956 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10957 s = add_utf16_textfilter(s, TRUE);
10959 /* diag_listed_as: Unsupported script encoding %s */
10960 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10968 #ifndef PERL_NO_UTF16_FILTER
10970 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10972 SV *const filter = FILTER_DATA(idx);
10973 /* We re-use this each time round, throwing the contents away before we
10975 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10976 SV *const utf8_buffer = filter;
10977 IV status = IoPAGE(filter);
10978 const bool reverse = cBOOL(IoLINES(filter));
10981 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10983 /* As we're automatically added, at the lowest level, and hence only called
10984 from this file, we can be sure that we're not called in block mode. Hence
10985 don't bother writing code to deal with block mode. */
10987 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10990 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10992 DEBUG_P(PerlIO_printf(Perl_debug_log,
10993 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10994 FPTR2DPTR(void *, S_utf16_textfilter),
10995 reverse ? 'l' : 'b', idx, maxlen, status,
10996 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11003 /* First, look in our buffer of existing UTF-8 data: */
11004 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11008 } else if (status == 0) {
11010 IoPAGE(filter) = 0;
11011 nl = SvEND(utf8_buffer);
11014 STRLEN got = nl - SvPVX(utf8_buffer);
11015 /* Did we have anything to append? */
11017 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11018 /* Everything else in this code works just fine if SVp_POK isn't
11019 set. This, however, needs it, and we need it to work, else
11020 we loop infinitely because the buffer is never consumed. */
11021 sv_chop(utf8_buffer, nl);
11025 /* OK, not a complete line there, so need to read some more UTF-16.
11026 Read an extra octect if the buffer currently has an odd number. */
11030 if (SvCUR(utf16_buffer) >= 2) {
11031 /* Location of the high octet of the last complete code point.
11032 Gosh, UTF-16 is a pain. All the benefits of variable length,
11033 *coupled* with all the benefits of partial reads and
11035 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11036 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11038 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11042 /* We have the first half of a surrogate. Read more. */
11043 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11046 status = FILTER_READ(idx + 1, utf16_buffer,
11047 160 + (SvCUR(utf16_buffer) & 1));
11048 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11049 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11052 IoPAGE(filter) = status;
11057 chars = SvCUR(utf16_buffer) >> 1;
11058 have = SvCUR(utf8_buffer);
11059 SvGROW(utf8_buffer, have + chars * 3 + 1);
11062 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11063 (U8*)SvPVX_const(utf8_buffer) + have,
11064 chars * 2, &newlen);
11066 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11067 (U8*)SvPVX_const(utf8_buffer) + have,
11068 chars * 2, &newlen);
11070 SvCUR_set(utf8_buffer, have + newlen);
11073 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11074 it's private to us, and utf16_to_utf8{,reversed} take a
11075 (pointer,length) pair, rather than a NUL-terminated string. */
11076 if(SvCUR(utf16_buffer) & 1) {
11077 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11078 SvCUR_set(utf16_buffer, 1);
11080 SvCUR_set(utf16_buffer, 0);
11083 DEBUG_P(PerlIO_printf(Perl_debug_log,
11084 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11086 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11087 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11092 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11094 SV *filter = filter_add(S_utf16_textfilter, NULL);
11096 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11098 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11099 sv_setpvs(filter, "");
11100 IoLINES(filter) = reversed;
11101 IoPAGE(filter) = 1; /* Not EOF */
11103 /* Sadly, we have to return a valid pointer, come what may, so we have to
11104 ignore any error return from this. */
11105 SvCUR_set(PL_linestr, 0);
11106 if (FILTER_READ(0, PL_linestr, 0)) {
11107 SvUTF8_on(PL_linestr);
11109 SvUTF8_on(PL_linestr);
11111 PL_bufend = SvEND(PL_linestr);
11112 return (U8*)SvPVX(PL_linestr);
11117 Returns a pointer to the next character after the parsed
11118 vstring, as well as updating the passed in sv.
11120 Function must be called like
11122 sv = sv_2mortal(newSV(5));
11123 s = scan_vstring(s,e,sv);
11125 where s and e are the start and end of the string.
11126 The sv should already be large enough to store the vstring
11127 passed in, for performance reasons.
11129 This function may croak if fatal warnings are enabled in the
11130 calling scope, hence the sv_2mortal in the example (to prevent
11131 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11137 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11139 const char *pos = s;
11140 const char *start = s;
11142 PERL_ARGS_ASSERT_SCAN_VSTRING;
11144 if (*pos == 'v') pos++; /* get past 'v' */
11145 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11147 if ( *pos != '.') {
11148 /* this may not be a v-string if followed by => */
11149 const char *next = pos;
11150 while (next < e && isSPACE(*next))
11152 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11153 /* return string not v-string */
11154 sv_setpvn(sv,(char *)s,pos-s);
11155 return (char *)pos;
11159 if (!isALPHA(*pos)) {
11160 U8 tmpbuf[UTF8_MAXBYTES+1];
11163 s++; /* get past 'v' */
11168 /* this is atoi() that tolerates underscores */
11171 const char *end = pos;
11173 while (--end >= s) {
11175 const UV orev = rev;
11176 rev += (*end - '0') * mult;
11179 /* diag_listed_as: Integer overflow in %s number */
11180 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11181 "Integer overflow in decimal number");
11185 if (rev > 0x7FFFFFFF)
11186 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11188 /* Append native character for the rev point */
11189 tmpend = uvchr_to_utf8(tmpbuf, rev);
11190 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11191 if (!UVCHR_IS_INVARIANT(rev))
11193 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11199 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11203 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11210 Perl_keyword_plugin_standard(pTHX_
11211 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11213 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11214 PERL_UNUSED_CONTEXT;
11215 PERL_UNUSED_ARG(keyword_ptr);
11216 PERL_UNUSED_ARG(keyword_len);
11217 PERL_UNUSED_ARG(op_ptr);
11218 return KEYWORD_PLUGIN_DECLINE;
11221 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11223 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11225 SAVEI32(PL_lex_brackets);
11226 if (PL_lex_brackets > 100)
11227 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11228 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11229 SAVEI32(PL_lex_allbrackets);
11230 PL_lex_allbrackets = 0;
11231 SAVEI8(PL_lex_fakeeof);
11232 PL_lex_fakeeof = (U8)fakeeof;
11233 if(yyparse(gramtype) && !PL_parser->error_count)
11234 qerror(Perl_mess(aTHX_ "Parse error"));
11237 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11239 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11243 SAVEVPTR(PL_eval_root);
11244 PL_eval_root = NULL;
11245 parse_recdescent(gramtype, fakeeof);
11251 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11253 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11256 if (flags & ~PARSE_OPTIONAL)
11257 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11258 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11259 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11260 if (!PL_parser->error_count)
11261 qerror(Perl_mess(aTHX_ "Parse error"));
11262 exprop = newOP(OP_NULL, 0);
11268 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11270 Parse a Perl arithmetic expression. This may contain operators of precedence
11271 down to the bit shift operators. The expression must be followed (and thus
11272 terminated) either by a comparison or lower-precedence operator or by
11273 something that would normally terminate an expression such as semicolon.
11274 If C<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11275 otherwise it is mandatory. It is up to the caller to ensure that the
11276 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11277 the source of the code to be parsed and the lexical context for the
11280 The op tree representing the expression is returned. If an optional
11281 expression is absent, a null pointer is returned, otherwise the pointer
11284 If an error occurs in parsing or compilation, in most cases a valid op
11285 tree is returned anyway. The error is reflected in the parser state,
11286 normally resulting in a single exception at the top level of parsing
11287 which covers all the compilation errors that occurred. Some compilation
11288 errors, however, will throw an exception immediately.
11294 Perl_parse_arithexpr(pTHX_ U32 flags)
11296 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11300 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11302 Parse a Perl term expression. This may contain operators of precedence
11303 down to the assignment operators. The expression must be followed (and thus
11304 terminated) either by a comma or lower-precedence operator or by
11305 something that would normally terminate an expression such as semicolon.
11306 If C<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11307 otherwise it is mandatory. It is up to the caller to ensure that the
11308 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11309 the source of the code to be parsed and the lexical context for the
11312 The op tree representing the expression is returned. If an optional
11313 expression is absent, a null pointer is returned, otherwise the pointer
11316 If an error occurs in parsing or compilation, in most cases a valid op
11317 tree is returned anyway. The error is reflected in the parser state,
11318 normally resulting in a single exception at the top level of parsing
11319 which covers all the compilation errors that occurred. Some compilation
11320 errors, however, will throw an exception immediately.
11326 Perl_parse_termexpr(pTHX_ U32 flags)
11328 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11332 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11334 Parse a Perl list expression. This may contain operators of precedence
11335 down to the comma operator. The expression must be followed (and thus
11336 terminated) either by a low-precedence logic operator such as C<or> or by
11337 something that would normally terminate an expression such as semicolon.
11338 If C<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11339 otherwise it is mandatory. It is up to the caller to ensure that the
11340 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11341 the source of the code to be parsed and the lexical context for the
11344 The op tree representing the expression is returned. If an optional
11345 expression is absent, a null pointer is returned, otherwise the pointer
11348 If an error occurs in parsing or compilation, in most cases a valid op
11349 tree is returned anyway. The error is reflected in the parser state,
11350 normally resulting in a single exception at the top level of parsing
11351 which covers all the compilation errors that occurred. Some compilation
11352 errors, however, will throw an exception immediately.
11358 Perl_parse_listexpr(pTHX_ U32 flags)
11360 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11364 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11366 Parse a single complete Perl expression. This allows the full
11367 expression grammar, including the lowest-precedence operators such
11368 as C<or>. The expression must be followed (and thus terminated) by a
11369 token that an expression would normally be terminated by: end-of-file,
11370 closing bracketing punctuation, semicolon, or one of the keywords that
11371 signals a postfix expression-statement modifier. If C<flags> includes
11372 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11373 mandatory. It is up to the caller to ensure that the dynamic parser
11374 state (L</PL_parser> et al) is correctly set to reflect the source of
11375 the code to be parsed and the lexical context for the expression.
11377 The op tree representing the expression is returned. If an optional
11378 expression is absent, a null pointer is returned, otherwise the pointer
11381 If an error occurs in parsing or compilation, in most cases a valid op
11382 tree is returned anyway. The error is reflected in the parser state,
11383 normally resulting in a single exception at the top level of parsing
11384 which covers all the compilation errors that occurred. Some compilation
11385 errors, however, will throw an exception immediately.
11391 Perl_parse_fullexpr(pTHX_ U32 flags)
11393 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11397 =for apidoc Amx|OP *|parse_block|U32 flags
11399 Parse a single complete Perl code block. This consists of an opening
11400 brace, a sequence of statements, and a closing brace. The block
11401 constitutes a lexical scope, so C<my> variables and various compile-time
11402 effects can be contained within it. It is up to the caller to ensure
11403 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11404 reflect the source of the code to be parsed and the lexical context for
11407 The op tree representing the code block is returned. This is always a
11408 real op, never a null pointer. It will normally be a C<lineseq> list,
11409 including C<nextstate> or equivalent ops. No ops to construct any kind
11410 of runtime scope are included by virtue of it being a block.
11412 If an error occurs in parsing or compilation, in most cases a valid op
11413 tree (most likely null) is returned anyway. The error is reflected in
11414 the parser state, normally resulting in a single exception at the top
11415 level of parsing which covers all the compilation errors that occurred.
11416 Some compilation errors, however, will throw an exception immediately.
11418 The C<flags> parameter is reserved for future use, and must always
11425 Perl_parse_block(pTHX_ U32 flags)
11428 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11429 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11433 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11435 Parse a single unadorned Perl statement. This may be a normal imperative
11436 statement or a declaration that has compile-time effect. It does not
11437 include any label or other affixture. It is up to the caller to ensure
11438 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11439 reflect the source of the code to be parsed and the lexical context for
11442 The op tree representing the statement is returned. This may be a
11443 null pointer if the statement is null, for example if it was actually
11444 a subroutine definition (which has compile-time side effects). If not
11445 null, it will be ops directly implementing the statement, suitable to
11446 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11447 equivalent op (except for those embedded in a scope contained entirely
11448 within the statement).
11450 If an error occurs in parsing or compilation, in most cases a valid op
11451 tree (most likely null) is returned anyway. The error is reflected in
11452 the parser state, normally resulting in a single exception at the top
11453 level of parsing which covers all the compilation errors that occurred.
11454 Some compilation errors, however, will throw an exception immediately.
11456 The C<flags> parameter is reserved for future use, and must always
11463 Perl_parse_barestmt(pTHX_ U32 flags)
11466 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11467 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11471 =for apidoc Amx|SV *|parse_label|U32 flags
11473 Parse a single label, possibly optional, of the type that may prefix a
11474 Perl statement. It is up to the caller to ensure that the dynamic parser
11475 state (L</PL_parser> et al) is correctly set to reflect the source of
11476 the code to be parsed. If C<flags> includes C<PARSE_OPTIONAL> then the
11477 label is optional, otherwise it is mandatory.
11479 The name of the label is returned in the form of a fresh scalar. If an
11480 optional label is absent, a null pointer is returned.
11482 If an error occurs in parsing, which can only occur if the label is
11483 mandatory, a valid label is returned anyway. The error is reflected in
11484 the parser state, normally resulting in a single exception at the top
11485 level of parsing which covers all the compilation errors that occurred.
11491 Perl_parse_label(pTHX_ U32 flags)
11493 if (flags & ~PARSE_OPTIONAL)
11494 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11495 if (PL_lex_state == LEX_KNOWNEXT) {
11496 PL_parser->yychar = yylex();
11497 if (PL_parser->yychar == LABEL) {
11498 char * const lpv = pl_yylval.pval;
11499 STRLEN llen = strlen(lpv);
11500 PL_parser->yychar = YYEMPTY;
11501 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11508 STRLEN wlen, bufptr_pos;
11511 if (!isIDFIRST_lazy_if(s, UTF))
11513 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11514 if (word_takes_any_delimeter(s, wlen))
11516 bufptr_pos = s - SvPVX(PL_linestr);
11518 lex_read_space(LEX_KEEP_PREVIOUS);
11520 s = SvPVX(PL_linestr) + bufptr_pos;
11521 if (t[0] == ':' && t[1] != ':') {
11522 PL_oldoldbufptr = PL_oldbufptr;
11525 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11529 if (flags & PARSE_OPTIONAL) {
11532 qerror(Perl_mess(aTHX_ "Parse error"));
11533 return newSVpvs("x");
11540 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11542 Parse a single complete Perl statement. This may be a normal imperative
11543 statement or a declaration that has compile-time effect, and may include
11544 optional labels. It is up to the caller to ensure that the dynamic
11545 parser state (L</PL_parser> et al) is correctly set to reflect the source
11546 of the code to be parsed and the lexical context for the statement.
11548 The op tree representing the statement is returned. This may be a
11549 null pointer if the statement is null, for example if it was actually
11550 a subroutine definition (which has compile-time side effects). If not
11551 null, it will be the result of a L</newSTATEOP> call, normally including
11552 a C<nextstate> or equivalent op.
11554 If an error occurs in parsing or compilation, in most cases a valid op
11555 tree (most likely null) is returned anyway. The error is reflected in
11556 the parser state, normally resulting in a single exception at the top
11557 level of parsing which covers all the compilation errors that occurred.
11558 Some compilation errors, however, will throw an exception immediately.
11560 The C<flags> parameter is reserved for future use, and must always
11567 Perl_parse_fullstmt(pTHX_ U32 flags)
11570 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11571 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11575 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11577 Parse a sequence of zero or more Perl statements. These may be normal
11578 imperative statements, including optional labels, or declarations
11579 that have compile-time effect, or any mixture thereof. The statement
11580 sequence ends when a closing brace or end-of-file is encountered in a
11581 place where a new statement could have validly started. It is up to
11582 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11583 is correctly set to reflect the source of the code to be parsed and the
11584 lexical context for the statements.
11586 The op tree representing the statement sequence is returned. This may
11587 be a null pointer if the statements were all null, for example if there
11588 were no statements or if there were only subroutine definitions (which
11589 have compile-time side effects). If not null, it will be a C<lineseq>
11590 list, normally including C<nextstate> or equivalent ops.
11592 If an error occurs in parsing or compilation, in most cases a valid op
11593 tree is returned anyway. The error is reflected in the parser state,
11594 normally resulting in a single exception at the top level of parsing
11595 which covers all the compilation errors that occurred. Some compilation
11596 errors, however, will throw an exception immediately.
11598 The C<flags> parameter is reserved for future use, and must always
11605 Perl_parse_stmtseq(pTHX_ U32 flags)
11610 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11611 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11612 c = lex_peek_unichar(0);
11613 if (c != -1 && c != /*{*/'}')
11614 qerror(Perl_mess(aTHX_ "Parse error"));
11618 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11620 S_lex_token_boundary(pTHX)
11622 PL_oldoldbufptr = PL_oldbufptr;
11623 PL_oldbufptr = PL_bufptr;
11626 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11628 S_parse_opt_lexvar(pTHX)
11633 lex_token_boundary();
11634 sigil = lex_read_unichar(0);
11635 if (lex_peek_unichar(0) == '#') {
11636 qerror(Perl_mess(aTHX_ "Parse error"));
11640 c = lex_peek_unichar(0);
11641 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11644 d = PL_tokenbuf + 1;
11645 PL_tokenbuf[0] = (char)sigil;
11646 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11648 if (d == PL_tokenbuf+1)
11650 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11651 OPf_MOD | (OPpLVAL_INTRO<<8));
11652 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11657 Perl_parse_subsignature(pTHX)
11660 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11661 OP *initops = NULL;
11663 c = lex_peek_unichar(0);
11664 while (c != /*(*/')') {
11668 if (prev_type == 2)
11669 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11670 var = parse_opt_lexvar();
11672 newBINOP(OP_AELEM, 0,
11673 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11675 newSVOP(OP_CONST, 0, newSViv(pos))) :
11678 c = lex_peek_unichar(0);
11680 lex_token_boundary();
11681 lex_read_unichar(0);
11683 c = lex_peek_unichar(0);
11684 if (c == ',' || c == /*(*/')') {
11686 qerror(Perl_mess(aTHX_ "Optional parameter "
11687 "lacks default expression"));
11689 OP *defexpr = parse_termexpr(0);
11690 if (defexpr->op_type == OP_UNDEF
11691 && !(defexpr->op_flags & OPf_KIDS))
11697 scalar(newUNOP(OP_RV2AV, 0,
11698 newGVOP(OP_GV, 0, PL_defgv))),
11699 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11701 newCONDOP(0, ifop, expr, defexpr) :
11702 newLOGOP(OP_OR, 0, ifop, defexpr);
11707 if (prev_type == 1)
11708 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11709 "follows optional parameter"));
11711 min_arity = pos + 1;
11713 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11715 initops = op_append_list(OP_LINESEQ, initops,
11716 newSTATEOP(0, NULL, expr));
11722 if (prev_type == 2)
11723 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11724 var = parse_opt_lexvar();
11726 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11727 newBINOP(OP_BIT_AND, 0,
11728 scalar(newUNOP(OP_RV2AV, 0,
11729 newGVOP(OP_GV, 0, PL_defgv))),
11730 newSVOP(OP_CONST, 0, newSViv(1))),
11731 op_convert_list(OP_DIE, 0,
11732 op_convert_list(OP_SPRINTF, 0,
11733 op_append_list(OP_LIST,
11734 newSVOP(OP_CONST, 0,
11735 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11737 op_append_list(OP_LIST,
11738 newSVOP(OP_CONST, 0, newSViv(1)),
11739 newSVOP(OP_CONST, 0, newSViv(2))),
11740 newOP(OP_CALLER, 0))))));
11741 if (pos != min_arity)
11742 chkop = newLOGOP(OP_AND, 0,
11744 scalar(newUNOP(OP_RV2AV, 0,
11745 newGVOP(OP_GV, 0, PL_defgv))),
11746 newSVOP(OP_CONST, 0, newSViv(pos))),
11748 initops = op_append_list(OP_LINESEQ,
11749 newSTATEOP(0, NULL, chkop),
11754 op_prepend_elem(OP_ASLICE,
11755 newOP(OP_PUSHMARK, 0),
11756 newLISTOP(OP_ASLICE, 0,
11758 newSVOP(OP_CONST, 0, newSViv(pos)),
11759 newUNOP(OP_AV2ARYLEN, 0,
11760 ref(newUNOP(OP_RV2AV, 0,
11761 newGVOP(OP_GV, 0, PL_defgv)),
11763 ref(newUNOP(OP_RV2AV, 0,
11764 newGVOP(OP_GV, 0, PL_defgv)),
11766 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11767 initops = op_append_list(OP_LINESEQ, initops,
11768 newSTATEOP(0, NULL,
11769 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11776 qerror(Perl_mess(aTHX_ "Parse error"));
11780 c = lex_peek_unichar(0);
11782 case /*(*/')': break;
11785 lex_token_boundary();
11786 lex_read_unichar(0);
11788 c = lex_peek_unichar(0);
11789 } while (c == ',');
11795 if (min_arity != 0) {
11796 initops = op_append_list(OP_LINESEQ,
11797 newSTATEOP(0, NULL,
11800 scalar(newUNOP(OP_RV2AV, 0,
11801 newGVOP(OP_GV, 0, PL_defgv))),
11802 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11803 op_convert_list(OP_DIE, 0,
11804 op_convert_list(OP_SPRINTF, 0,
11805 op_append_list(OP_LIST,
11806 newSVOP(OP_CONST, 0,
11807 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11809 op_append_list(OP_LIST,
11810 newSVOP(OP_CONST, 0, newSViv(1)),
11811 newSVOP(OP_CONST, 0, newSViv(2))),
11812 newOP(OP_CALLER, 0))))))),
11815 if (max_arity != -1) {
11816 initops = op_append_list(OP_LINESEQ,
11817 newSTATEOP(0, NULL,
11820 scalar(newUNOP(OP_RV2AV, 0,
11821 newGVOP(OP_GV, 0, PL_defgv))),
11822 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11823 op_convert_list(OP_DIE, 0,
11824 op_convert_list(OP_SPRINTF, 0,
11825 op_append_list(OP_LIST,
11826 newSVOP(OP_CONST, 0,
11827 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11829 op_append_list(OP_LIST,
11830 newSVOP(OP_CONST, 0, newSViv(1)),
11831 newSVOP(OP_CONST, 0, newSViv(2))),
11832 newOP(OP_CALLER, 0))))))),
11839 * ex: set ts=8 sts=4 sw=4 et: