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_static.c"
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 I<line> and I<rsfp>. I<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 I<line>
658 does not affect parsing. I<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 I<line> comes first and must consist of complete lines of input,
661 and I<rsfp> supplies the remainder of the source.
663 The I<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 I<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 I<len> octets starting
952 at I<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 I<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 I<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 I<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 I<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 I<ptr>. Text following I<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 I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<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 I<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. I<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 I<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) {
1275 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1277 if (PL_parser->last_uni != PL_parser->bufend)
1278 PL_parser->last_uni = NULL;
1279 if (PL_parser->last_lop != PL_parser->bufend)
1280 PL_parser->last_lop = NULL;
1281 last_uni_pos = last_lop_pos = 0;
1285 old_bufend_pos = PL_parser->bufend - buf;
1286 bufptr_pos = PL_parser->bufptr - buf;
1287 oldbufptr_pos = PL_parser->oldbufptr - buf;
1288 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1289 linestart_pos = PL_parser->linestart - buf;
1290 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1291 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1293 if (flags & LEX_FAKE_EOF) {
1295 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1297 } else if (filter_gets(linestr, old_bufend_pos)) {
1299 got_some_for_debugger = 1;
1300 } else if (flags & LEX_NO_TERM) {
1303 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1304 sv_setpvs(linestr, "");
1306 /* End of real input. Close filehandle (unless it was STDIN),
1307 * then add implicit termination.
1309 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1310 PerlIO_clearerr(PL_parser->rsfp);
1311 else if (PL_parser->rsfp)
1312 (void)PerlIO_close(PL_parser->rsfp);
1313 PL_parser->rsfp = NULL;
1314 PL_parser->in_pod = PL_parser->filtered = 0;
1315 if (!PL_in_eval && PL_minus_p) {
1317 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1318 PL_minus_n = PL_minus_p = 0;
1319 } else if (!PL_in_eval && PL_minus_n) {
1320 sv_catpvs(linestr, /*{*/";}");
1323 sv_catpvs(linestr, ";");
1326 buf = SvPVX(linestr);
1327 new_bufend_pos = SvCUR(linestr);
1328 PL_parser->bufend = buf + new_bufend_pos;
1329 PL_parser->bufptr = buf + bufptr_pos;
1330 PL_parser->oldbufptr = buf + oldbufptr_pos;
1331 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1332 PL_parser->linestart = buf + linestart_pos;
1333 if (PL_parser->last_uni)
1334 PL_parser->last_uni = buf + last_uni_pos;
1335 if (PL_parser->last_lop)
1336 PL_parser->last_lop = buf + last_lop_pos;
1337 if (PL_parser->preambling != NOLINE) {
1338 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1339 PL_parser->preambling = NOLINE;
1341 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1342 PL_curstash != PL_debstash) {
1343 /* debugger active and we're not compiling the debugger code,
1344 * so store the line into the debugger's array of lines
1346 update_debugger_info(NULL, buf+old_bufend_pos,
1347 new_bufend_pos-old_bufend_pos);
1353 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1355 Looks ahead one (Unicode) character in the text currently being lexed.
1356 Returns the codepoint (unsigned integer value) of the next character,
1357 or -1 if lexing has reached the end of the input text. To consume the
1358 peeked character, use L</lex_read_unichar>.
1360 If the next character is in (or extends into) the next chunk of input
1361 text, the next chunk will be read in. Normally the current chunk will be
1362 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1363 then the current chunk will not be discarded.
1365 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1366 is encountered, an exception is generated.
1372 Perl_lex_peek_unichar(pTHX_ U32 flags)
1376 if (flags & ~(LEX_KEEP_PREVIOUS))
1377 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1378 s = PL_parser->bufptr;
1379 bufend = PL_parser->bufend;
1385 if (!lex_next_chunk(flags))
1387 s = PL_parser->bufptr;
1388 bufend = PL_parser->bufend;
1391 if (UTF8_IS_INVARIANT(head))
1393 if (UTF8_IS_START(head)) {
1394 len = UTF8SKIP(&head);
1395 while ((STRLEN)(bufend-s) < len) {
1396 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1398 s = PL_parser->bufptr;
1399 bufend = PL_parser->bufend;
1402 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1403 if (retlen == (STRLEN)-1) {
1404 /* malformed UTF-8 */
1406 SAVESPTR(PL_warnhook);
1407 PL_warnhook = PERL_WARNHOOK_FATAL;
1408 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1414 if (!lex_next_chunk(flags))
1416 s = PL_parser->bufptr;
1423 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1425 Reads the next (Unicode) character in the text currently being lexed.
1426 Returns the codepoint (unsigned integer value) of the character read,
1427 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1428 if lexing has reached the end of the input text. To non-destructively
1429 examine the next character, use L</lex_peek_unichar> instead.
1431 If the next character is in (or extends into) the next chunk of input
1432 text, the next chunk will be read in. Normally the current chunk will be
1433 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1434 then the current chunk will not be discarded.
1436 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1437 is encountered, an exception is generated.
1443 Perl_lex_read_unichar(pTHX_ U32 flags)
1446 if (flags & ~(LEX_KEEP_PREVIOUS))
1447 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1448 c = lex_peek_unichar(flags);
1451 COPLINE_INC_WITH_HERELINES;
1453 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1455 ++(PL_parser->bufptr);
1461 =for apidoc Amx|void|lex_read_space|U32 flags
1463 Reads optional spaces, in Perl style, in the text currently being
1464 lexed. The spaces may include ordinary whitespace characters and
1465 Perl-style comments. C<#line> directives are processed if encountered.
1466 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1467 at a non-space character (or the end of the input text).
1469 If spaces extend into the next chunk of input text, the next chunk will
1470 be read in. Normally the current chunk will be discarded at the same
1471 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1472 chunk will not be discarded.
1477 #define LEX_NO_INCLINE 0x40000000
1478 #define LEX_NO_NEXT_CHUNK 0x80000000
1481 Perl_lex_read_space(pTHX_ U32 flags)
1484 const bool can_incline = !(flags & LEX_NO_INCLINE);
1485 bool need_incline = 0;
1486 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1487 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1488 s = PL_parser->bufptr;
1489 bufend = PL_parser->bufend;
1495 } while (!(c == '\n' || (c == 0 && s == bufend)));
1496 } else if (c == '\n') {
1499 PL_parser->linestart = s;
1505 } else if (isSPACE(c)) {
1507 } else if (c == 0 && s == bufend) {
1510 if (flags & LEX_NO_NEXT_CHUNK)
1512 PL_parser->bufptr = s;
1513 l = CopLINE(PL_curcop);
1514 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1515 got_more = lex_next_chunk(flags);
1516 CopLINE_set(PL_curcop, l);
1517 s = PL_parser->bufptr;
1518 bufend = PL_parser->bufend;
1521 if (can_incline && need_incline && PL_parser->rsfp) {
1531 PL_parser->bufptr = s;
1536 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1538 This function performs syntax checking on a prototype, C<proto>.
1539 If C<warn> is true, any illegal characters or mismatched brackets
1540 will trigger illegalproto warnings, declaring that they were
1541 detected in the prototype for C<name>.
1543 The return value is C<true> if this is a valid prototype, and
1544 C<false> if it is not, regardless of whether C<warn> was C<true> or
1547 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1554 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1556 STRLEN len, origlen;
1557 char *p = proto ? SvPV(proto, len) : NULL;
1558 bool bad_proto = FALSE;
1559 bool in_brackets = FALSE;
1560 bool after_slash = FALSE;
1561 char greedy_proto = ' ';
1562 bool proto_after_greedy_proto = FALSE;
1563 bool must_be_last = FALSE;
1564 bool underscore = FALSE;
1565 bool bad_proto_after_underscore = FALSE;
1567 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1573 for (; len--; p++) {
1576 proto_after_greedy_proto = TRUE;
1578 if (!strchr(";@%", *p))
1579 bad_proto_after_underscore = TRUE;
1582 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1589 in_brackets = FALSE;
1590 else if ((*p == '@' || *p == '%') &&
1593 must_be_last = TRUE;
1602 after_slash = FALSE;
1607 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1610 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1611 origlen, UNI_DISPLAY_ISPRINT)
1612 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1614 if (proto_after_greedy_proto)
1615 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1616 "Prototype after '%c' for %"SVf" : %s",
1617 greedy_proto, SVfARG(name), p);
1619 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1620 "Missing ']' in prototype for %"SVf" : %s",
1623 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1624 "Illegal character in prototype for %"SVf" : %s",
1626 if (bad_proto_after_underscore)
1627 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1628 "Illegal character after '_' in prototype for %"SVf" : %s",
1632 return (! (proto_after_greedy_proto || bad_proto) );
1637 * This subroutine has nothing to do with tilting, whether at windmills
1638 * or pinball tables. Its name is short for "increment line". It
1639 * increments the current line number in CopLINE(PL_curcop) and checks
1640 * to see whether the line starts with a comment of the form
1641 * # line 500 "foo.pm"
1642 * If so, it sets the current line number and file to the values in the comment.
1646 S_incline(pTHX_ const char *s)
1654 PERL_ARGS_ASSERT_INCLINE;
1656 COPLINE_INC_WITH_HERELINES;
1657 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1658 && s+1 == PL_bufend && *s == ';') {
1659 /* fake newline in string eval */
1660 CopLINE_dec(PL_curcop);
1665 while (SPACE_OR_TAB(*s))
1667 if (strnEQ(s, "line", 4))
1671 if (SPACE_OR_TAB(*s))
1675 while (SPACE_OR_TAB(*s))
1683 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1685 while (SPACE_OR_TAB(*s))
1687 if (*s == '"' && (t = strchr(s+1, '"'))) {
1693 while (!isSPACE(*t))
1697 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1699 if (*e != '\n' && *e != '\0')
1700 return; /* false alarm */
1702 if (!grok_atoUV(n, &uv, &e))
1704 line_num = ((line_t)uv) - 1;
1707 const STRLEN len = t - s;
1709 if (!PL_rsfp && !PL_parser->filtered) {
1710 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1711 * to *{"::_<newfilename"} */
1712 /* However, the long form of evals is only turned on by the
1713 debugger - usually they're "(eval %lu)" */
1714 GV * const cfgv = CopFILEGV(PL_curcop);
1717 STRLEN tmplen2 = len;
1721 if (tmplen2 + 2 <= sizeof smallbuf)
1724 Newx(tmpbuf2, tmplen2 + 2, char);
1729 memcpy(tmpbuf2 + 2, s, tmplen2);
1732 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1734 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1735 /* adjust ${"::_<newfilename"} to store the new file name */
1736 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1737 /* The line number may differ. If that is the case,
1738 alias the saved lines that are in the array.
1739 Otherwise alias the whole array. */
1740 if (CopLINE(PL_curcop) == line_num) {
1741 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1742 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1744 else if (GvAV(cfgv)) {
1745 AV * const av = GvAV(cfgv);
1746 const I32 start = CopLINE(PL_curcop)+1;
1747 I32 items = AvFILLp(av) - start;
1749 AV * const av2 = GvAVn(gv2);
1750 SV **svp = AvARRAY(av) + start;
1751 I32 l = (I32)line_num+1;
1753 av_store(av2, l++, SvREFCNT_inc(*svp++));
1758 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1761 CopFILE_free(PL_curcop);
1762 CopFILE_setn(PL_curcop, s, len);
1764 CopLINE_set(PL_curcop, line_num);
1767 #define skipspace(s) skipspace_flags(s, 0)
1771 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1773 AV *av = CopFILEAVx(PL_curcop);
1776 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1778 sv = *av_fetch(av, 0, 1);
1779 SvUPGRADE(sv, SVt_PVMG);
1781 if (!SvPOK(sv)) sv_setpvs(sv,"");
1783 sv_catsv(sv, orig_sv);
1785 sv_catpvn(sv, buf, len);
1790 if (PL_parser->preambling == NOLINE)
1791 av_store(av, CopLINE(PL_curcop), sv);
1797 * Called to gobble the appropriate amount and type of whitespace.
1798 * Skips comments as well.
1802 S_skipspace_flags(pTHX_ char *s, U32 flags)
1804 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1805 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1806 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1809 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1811 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1812 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1813 LEX_NO_NEXT_CHUNK : 0));
1815 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1816 if (PL_linestart > PL_bufptr)
1817 PL_bufptr = PL_linestart;
1825 * Check the unary operators to ensure there's no ambiguity in how they're
1826 * used. An ambiguous piece of code would be:
1828 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1829 * the +5 is its argument.
1838 if (PL_oldoldbufptr != PL_last_uni)
1840 while (isSPACE(*PL_last_uni))
1843 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1845 if ((t = strchr(s, '(')) && t < PL_bufptr)
1848 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1849 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1850 (int)(s - PL_last_uni), PL_last_uni);
1854 * LOP : macro to build a list operator. Its behaviour has been replaced
1855 * with a subroutine, S_lop() for which LOP is just another name.
1858 #define LOP(f,x) return lop(f,x,s)
1862 * Build a list operator (or something that might be one). The rules:
1863 * - if we have a next token, then it's a list operator (no parens) for
1864 * which the next token has already been parsed; e.g.,
1867 * - if the next thing is an opening paren, then it's a function
1868 * - else it's a list operator
1872 S_lop(pTHX_ I32 f, int x, char *s)
1874 PERL_ARGS_ASSERT_LOP;
1879 PL_last_lop = PL_oldbufptr;
1880 PL_last_lop_op = (OPCODE)f;
1885 return REPORT(FUNC);
1888 return REPORT(FUNC);
1891 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1892 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1893 return REPORT(LSTOP);
1899 * When the lexer realizes it knows the next token (for instance,
1900 * it is reordering tokens for the parser) then it can call S_force_next
1901 * to know what token to return the next time the lexer is called. Caller
1902 * will need to set PL_nextval[] and possibly PL_expect to ensure
1903 * the lexer handles the token correctly.
1907 S_force_next(pTHX_ I32 type)
1911 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1912 tokereport(type, &NEXTVAL_NEXTTOKE);
1915 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1916 PL_nexttype[PL_nexttoke] = type;
1918 if (PL_lex_state != LEX_KNOWNEXT) {
1919 PL_lex_defer = PL_lex_state;
1920 PL_lex_state = LEX_KNOWNEXT;
1927 * This subroutine handles postfix deref syntax after the arrow has already
1928 * been emitted. @* $* etc. are emitted as two separate token right here.
1929 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1930 * only the first, leaving yylex to find the next.
1934 S_postderef(pTHX_ int const funny, char const next)
1936 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1937 assert(strchr("*[{", next));
1939 PL_expect = XOPERATOR;
1940 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1941 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1942 PL_lex_state = LEX_INTERPEND;
1943 force_next(POSTJOIN);
1949 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1950 && !PL_lex_brackets)
1952 PL_expect = XOPERATOR;
1961 int yyc = PL_parser->yychar;
1962 if (yyc != YYEMPTY) {
1964 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1965 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1966 PL_lex_allbrackets--;
1968 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1969 } else if (yyc == '('/*)*/) {
1970 PL_lex_allbrackets--;
1975 PL_parser->yychar = YYEMPTY;
1980 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1982 SV * const sv = newSVpvn_utf8(start, len,
1985 && !is_invariant_string((const U8*)start, len)
1986 && is_utf8_string((const U8*)start, len));
1992 * When the lexer knows the next thing is a word (for instance, it has
1993 * just seen -> and it knows that the next char is a word char, then
1994 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1998 * char *start : buffer position (must be within PL_linestr)
1999 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2000 * int check_keyword : if true, Perl checks to make sure the word isn't
2001 * a keyword (do this if the word is a label, e.g. goto FOO)
2002 * int allow_pack : if true, : characters will also be allowed (require,
2003 * use, etc. do this)
2007 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2012 PERL_ARGS_ASSERT_FORCE_WORD;
2014 start = skipspace(start);
2016 if (isIDFIRST_lazy_if(s,UTF) ||
2017 (allow_pack && *s == ':') )
2019 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2020 if (check_keyword) {
2021 char *s2 = PL_tokenbuf;
2023 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2025 if (keyword(s2, len2, 0))
2028 if (token == METHOD) {
2033 PL_expect = XOPERATOR;
2036 NEXTVAL_NEXTTOKE.opval
2037 = (OP*)newSVOP(OP_CONST,0,
2038 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2039 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2047 * Called when the lexer wants $foo *foo &foo etc, but the program
2048 * text only contains the "foo" portion. The first argument is a pointer
2049 * to the "foo", and the second argument is the type symbol to prefix.
2050 * Forces the next token to be a "WORD".
2051 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2055 S_force_ident(pTHX_ const char *s, int kind)
2057 PERL_ARGS_ASSERT_FORCE_IDENT;
2060 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2061 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2062 UTF ? SVf_UTF8 : 0));
2063 NEXTVAL_NEXTTOKE.opval = o;
2066 o->op_private = OPpCONST_ENTERED;
2067 /* XXX see note in pp_entereval() for why we forgo typo
2068 warnings if the symbol must be introduced in an eval.
2070 gv_fetchpvn_flags(s, len,
2071 (PL_in_eval ? GV_ADDMULTI
2072 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2073 kind == '$' ? SVt_PV :
2074 kind == '@' ? SVt_PVAV :
2075 kind == '%' ? SVt_PVHV :
2083 S_force_ident_maybe_lex(pTHX_ char pit)
2085 NEXTVAL_NEXTTOKE.ival = pit;
2090 Perl_str_to_version(pTHX_ SV *sv)
2095 const char *start = SvPV_const(sv,len);
2096 const char * const end = start + len;
2097 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2099 PERL_ARGS_ASSERT_STR_TO_VERSION;
2101 while (start < end) {
2105 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2110 retval += ((NV)n)/nshift;
2119 * Forces the next token to be a version number.
2120 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2121 * and if "guessing" is TRUE, then no new token is created (and the caller
2122 * must use an alternative parsing method).
2126 S_force_version(pTHX_ char *s, int guessing)
2131 PERL_ARGS_ASSERT_FORCE_VERSION;
2139 while (isDIGIT(*d) || *d == '_' || *d == '.')
2141 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2143 s = scan_num(s, &pl_yylval);
2144 version = pl_yylval.opval;
2145 ver = cSVOPx(version)->op_sv;
2146 if (SvPOK(ver) && !SvNIOK(ver)) {
2147 SvUPGRADE(ver, SVt_PVNV);
2148 SvNV_set(ver, str_to_version(ver));
2149 SvNOK_on(ver); /* hint that it is a version */
2152 else if (guessing) {
2157 /* NOTE: The parser sees the package name and the VERSION swapped */
2158 NEXTVAL_NEXTTOKE.opval = version;
2165 * S_force_strict_version
2166 * Forces the next token to be a version number using strict syntax rules.
2170 S_force_strict_version(pTHX_ char *s)
2173 const char *errstr = NULL;
2175 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2177 while (isSPACE(*s)) /* leading whitespace */
2180 if (is_STRICT_VERSION(s,&errstr)) {
2182 s = (char *)scan_version(s, ver, 0);
2183 version = newSVOP(OP_CONST, 0, ver);
2185 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2186 (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2190 yyerror(errstr); /* version required */
2194 /* NOTE: The parser sees the package name and the VERSION swapped */
2195 NEXTVAL_NEXTTOKE.opval = version;
2203 * Tokenize a quoted string passed in as an SV. It finds the next
2204 * chunk, up to end of string or a backslash. It may make a new
2205 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2210 S_tokeq(pTHX_ SV *sv)
2217 PERL_ARGS_ASSERT_TOKEQ;
2221 assert (!SvIsCOW(sv));
2222 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2226 /* This is relying on the SV being "well formed" with a trailing '\0' */
2227 while (s < send && !(*s == '\\' && s[1] == '\\'))
2232 if ( PL_hints & HINT_NEW_STRING ) {
2233 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2234 SVs_TEMP | SvUTF8(sv));
2238 if (s + 1 < send && (s[1] == '\\'))
2239 s++; /* all that, just for this */
2244 SvCUR_set(sv, d - SvPVX_const(sv));
2246 if ( PL_hints & HINT_NEW_STRING )
2247 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2252 * Now come three functions related to double-quote context,
2253 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2254 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2255 * interact with PL_lex_state, and create fake ( ... ) argument lists
2256 * to handle functions and concatenation.
2260 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2265 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2267 * Pattern matching will set PL_lex_op to the pattern-matching op to
2268 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2270 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2272 * Everything else becomes a FUNC.
2274 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2275 * had an OP_CONST or OP_READLINE). This just sets us up for a
2276 * call to S_sublex_push().
2280 S_sublex_start(pTHX)
2282 const I32 op_type = pl_yylval.ival;
2284 if (op_type == OP_NULL) {
2285 pl_yylval.opval = PL_lex_op;
2289 if (op_type == OP_CONST) {
2290 SV *sv = PL_lex_stuff;
2291 PL_lex_stuff = NULL;
2294 if (SvTYPE(sv) == SVt_PVIV) {
2295 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2297 const char * const p = SvPV_const(sv, len);
2298 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2302 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2306 PL_sublex_info.super_state = PL_lex_state;
2307 PL_sublex_info.sub_inwhat = (U16)op_type;
2308 PL_sublex_info.sub_op = PL_lex_op;
2309 PL_lex_state = LEX_INTERPPUSH;
2313 pl_yylval.opval = PL_lex_op;
2323 * Create a new scope to save the lexing state. The scope will be
2324 * ended in S_sublex_done. Returns a '(', starting the function arguments
2325 * to the uc, lc, etc. found before.
2326 * Sets PL_lex_state to LEX_INTERPCONCAT.
2333 const bool is_heredoc = PL_multi_close == '<';
2336 PL_lex_state = PL_sublex_info.super_state;
2337 SAVEI8(PL_lex_dojoin);
2338 SAVEI32(PL_lex_brackets);
2339 SAVEI32(PL_lex_allbrackets);
2340 SAVEI32(PL_lex_formbrack);
2341 SAVEI8(PL_lex_fakeeof);
2342 SAVEI32(PL_lex_casemods);
2343 SAVEI32(PL_lex_starts);
2344 SAVEI8(PL_lex_state);
2345 SAVESPTR(PL_lex_repl);
2346 SAVEVPTR(PL_lex_inpat);
2347 SAVEI16(PL_lex_inwhat);
2350 SAVECOPLINE(PL_curcop);
2351 SAVEI32(PL_multi_end);
2352 SAVEI32(PL_parser->herelines);
2353 PL_parser->herelines = 0;
2355 SAVEI8(PL_multi_close);
2356 SAVEPPTR(PL_bufptr);
2357 SAVEPPTR(PL_bufend);
2358 SAVEPPTR(PL_oldbufptr);
2359 SAVEPPTR(PL_oldoldbufptr);
2360 SAVEPPTR(PL_last_lop);
2361 SAVEPPTR(PL_last_uni);
2362 SAVEPPTR(PL_linestart);
2363 SAVESPTR(PL_linestr);
2364 SAVEGENERICPV(PL_lex_brackstack);
2365 SAVEGENERICPV(PL_lex_casestack);
2366 SAVEGENERICPV(PL_parser->lex_shared);
2367 SAVEBOOL(PL_parser->lex_re_reparsing);
2368 SAVEI32(PL_copline);
2370 /* The here-doc parser needs to be able to peek into outer lexing
2371 scopes to find the body of the here-doc. So we put PL_linestr and
2372 PL_bufptr into lex_shared, to ‘share’ those values.
2374 PL_parser->lex_shared->ls_linestr = PL_linestr;
2375 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2377 PL_linestr = PL_lex_stuff;
2378 PL_lex_repl = PL_sublex_info.repl;
2379 PL_lex_stuff = NULL;
2380 PL_sublex_info.repl = NULL;
2382 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2383 set for an inner quote-like operator and then an error causes scope-
2384 popping. We must not have a PL_lex_stuff value left dangling, as
2385 that breaks assumptions elsewhere. See bug #123617. */
2386 SAVEGENERICSV(PL_lex_stuff);
2387 SAVEGENERICSV(PL_sublex_info.repl);
2389 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2390 = SvPVX(PL_linestr);
2391 PL_bufend += SvCUR(PL_linestr);
2392 PL_last_lop = PL_last_uni = NULL;
2393 SAVEFREESV(PL_linestr);
2394 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2396 PL_lex_dojoin = FALSE;
2397 PL_lex_brackets = PL_lex_formbrack = 0;
2398 PL_lex_allbrackets = 0;
2399 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2400 Newx(PL_lex_brackstack, 120, char);
2401 Newx(PL_lex_casestack, 12, char);
2402 PL_lex_casemods = 0;
2403 *PL_lex_casestack = '\0';
2405 PL_lex_state = LEX_INTERPCONCAT;
2407 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2408 PL_copline = NOLINE;
2410 Newxz(shared, 1, LEXSHARED);
2411 shared->ls_prev = PL_parser->lex_shared;
2412 PL_parser->lex_shared = shared;
2414 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2415 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2416 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2417 PL_lex_inpat = PL_sublex_info.sub_op;
2419 PL_lex_inpat = NULL;
2421 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2422 PL_in_eval &= ~EVAL_RE_REPARSING;
2429 * Restores lexer state after a S_sublex_push.
2435 if (!PL_lex_starts++) {
2436 SV * const sv = newSVpvs("");
2437 if (SvUTF8(PL_linestr))
2439 PL_expect = XOPERATOR;
2440 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2444 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2445 PL_lex_state = LEX_INTERPCASEMOD;
2449 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2450 assert(PL_lex_inwhat != OP_TRANSR);
2452 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2453 PL_linestr = PL_lex_repl;
2455 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2456 PL_bufend += SvCUR(PL_linestr);
2457 PL_last_lop = PL_last_uni = NULL;
2458 PL_lex_dojoin = FALSE;
2459 PL_lex_brackets = 0;
2460 PL_lex_allbrackets = 0;
2461 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2462 PL_lex_casemods = 0;
2463 *PL_lex_casestack = '\0';
2465 if (SvEVALED(PL_lex_repl)) {
2466 PL_lex_state = LEX_INTERPNORMAL;
2468 /* we don't clear PL_lex_repl here, so that we can check later
2469 whether this is an evalled subst; that means we rely on the
2470 logic to ensure sublex_done() is called again only via the
2471 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2474 PL_lex_state = LEX_INTERPCONCAT;
2477 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2478 CopLINE(PL_curcop) +=
2479 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2480 + PL_parser->herelines;
2481 PL_parser->herelines = 0;
2486 const line_t l = CopLINE(PL_curcop);
2488 if (PL_multi_close == '<')
2489 PL_parser->herelines += l - PL_multi_end;
2490 PL_bufend = SvPVX(PL_linestr);
2491 PL_bufend += SvCUR(PL_linestr);
2492 PL_expect = XOPERATOR;
2497 PERL_STATIC_INLINE SV*
2498 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2500 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2501 * interior, hence to the "}". Finds what the name resolves to, returning
2502 * an SV* containing it; NULL if no valid one found */
2504 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2511 const U8* first_bad_char_loc;
2512 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2514 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2519 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2521 &first_bad_char_loc))
2523 /* If warnings are on, this will print a more detailed analysis of what
2524 * is wrong than the error message below */
2525 utf8n_to_uvchr(first_bad_char_loc,
2526 e - ((char *) first_bad_char_loc),
2529 /* We deliberately don't try to print the malformed character, which
2530 * might not print very well; it also may be just the first of many
2531 * malformations, so don't print what comes after it */
2532 yyerror(Perl_form(aTHX_
2533 "Malformed UTF-8 character immediately after '%.*s'",
2534 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2538 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2539 /* include the <}> */
2540 e - backslash_ptr + 1);
2542 SvREFCNT_dec_NN(res);
2546 /* See if the charnames handler is the Perl core's, and if so, we can skip
2547 * the validation needed for a user-supplied one, as Perl's does its own
2549 table = GvHV(PL_hintgv); /* ^H */
2550 cvp = hv_fetchs(table, "charnames", FALSE);
2551 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2552 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2554 const char * const name = HvNAME(stash);
2555 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2556 && strEQ(name, "_charnames")) {
2561 /* Here, it isn't Perl's charname handler. We can't rely on a
2562 * user-supplied handler to validate the input name. For non-ut8 input,
2563 * look to see that the first character is legal. Then loop through the
2564 * rest checking that each is a continuation */
2566 /* This code makes the reasonable assumption that the only Latin1-range
2567 * characters that begin a character name alias are alphabetic, otherwise
2568 * would have to create a isCHARNAME_BEGIN macro */
2571 if (! isALPHAU(*s)) {
2576 if (! isCHARNAME_CONT(*s)) {
2579 if (*s == ' ' && *(s-1) == ' ') {
2582 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2583 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2584 "NO-BREAK SPACE in a charnames "
2585 "alias definition is deprecated");
2591 /* Similarly for utf8. For invariants can check directly; for other
2592 * Latin1, can calculate their code point and check; otherwise use a
2594 if (UTF8_IS_INVARIANT(*s)) {
2595 if (! isALPHAU(*s)) {
2599 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2600 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2606 if (! PL_utf8_charname_begin) {
2607 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2608 PL_utf8_charname_begin = _core_swash_init("utf8",
2609 "_Perl_Charname_Begin",
2611 1, 0, NULL, &flags);
2613 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2620 if (UTF8_IS_INVARIANT(*s)) {
2621 if (! isCHARNAME_CONT(*s)) {
2624 if (*s == ' ' && *(s-1) == ' ') {
2629 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2630 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2634 if (*s == *NBSP_UTF8
2635 && *(s+1) == *(NBSP_UTF8+1)
2636 && ckWARN_d(WARN_DEPRECATED))
2638 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2639 "NO-BREAK SPACE in a charnames "
2640 "alias definition is deprecated");
2645 if (! PL_utf8_charname_continue) {
2646 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2647 PL_utf8_charname_continue = _core_swash_init("utf8",
2648 "_Perl_Charname_Continue",
2650 1, 0, NULL, &flags);
2652 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2659 if (*(s-1) == ' ') {
2662 "charnames alias definitions may not contain trailing "
2663 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2664 (int)(s - backslash_ptr + 1), backslash_ptr,
2665 (int)(e - s + 1), s + 1
2667 UTF ? SVf_UTF8 : 0);
2671 if (SvUTF8(res)) { /* Don't accept malformed input */
2672 const U8* first_bad_char_loc;
2674 const char* const str = SvPV_const(res, len);
2675 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2676 /* If warnings are on, this will print a more detailed analysis of
2677 * what is wrong than the error message below */
2678 utf8n_to_uvchr(first_bad_char_loc,
2679 (char *) first_bad_char_loc - str,
2682 /* We deliberately don't try to print the malformed character,
2683 * which might not print very well; it also may be just the first
2684 * of many malformations, so don't print what comes after it */
2687 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2688 (int) (e - backslash_ptr + 1), backslash_ptr,
2689 (int) ((char *) first_bad_char_loc - str), str
2700 /* The final %.*s makes sure that should the trailing NUL be missing
2701 * that this print won't run off the end of the string */
2704 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2705 (int)(s - backslash_ptr + 1), backslash_ptr,
2706 (int)(e - s + 1), s + 1
2708 UTF ? SVf_UTF8 : 0);
2715 "charnames alias definitions may not contain a sequence of "
2716 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2717 (int)(s - backslash_ptr + 1), backslash_ptr,
2718 (int)(e - s + 1), s + 1
2720 UTF ? SVf_UTF8 : 0);
2727 Extracts the next constant part of a pattern, double-quoted string,
2728 or transliteration. This is terrifying code.
2730 For example, in parsing the double-quoted string "ab\x63$d", it would
2731 stop at the '$' and return an OP_CONST containing 'abc'.
2733 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2734 processing a pattern (PL_lex_inpat is true), a transliteration
2735 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2737 Returns a pointer to the character scanned up to. If this is
2738 advanced from the start pointer supplied (i.e. if anything was
2739 successfully parsed), will leave an OP_CONST for the substring scanned
2740 in pl_yylval. Caller must intuit reason for not parsing further
2741 by looking at the next characters herself.
2745 \N{FOO} => \N{U+hex_for_character_FOO}
2746 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2749 all other \-char, including \N and \N{ apart from \N{ABC}
2752 @ and $ where it appears to be a var, but not for $ as tail anchor
2757 In transliterations:
2758 characters are VERY literal, except for - not at the start or end
2759 of the string, which indicates a range. If the range is in bytes,
2760 scan_const expands the range to the full set of intermediate
2761 characters. If the range is in utf8, the hyphen is replaced with
2762 a certain range mark which will be handled by pmtrans() in op.c.
2764 In double-quoted strings:
2766 double-quoted style: \r and \n
2767 constants: \x31, etc.
2768 deprecated backrefs: \1 (in substitution replacements)
2769 case and quoting: \U \Q \E
2772 scan_const does *not* construct ops to handle interpolated strings.
2773 It stops processing as soon as it finds an embedded $ or @ variable
2774 and leaves it to the caller to work out what's going on.
2776 embedded arrays (whether in pattern or not) could be:
2777 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2779 $ in double-quoted strings must be the symbol of an embedded scalar.
2781 $ in pattern could be $foo or could be tail anchor. Assumption:
2782 it's a tail anchor if $ is the last thing in the string, or if it's
2783 followed by one of "()| \r\n\t"
2785 \1 (backreferences) are turned into $1 in substitutions
2787 The structure of the code is
2788 while (there's a character to process) {
2789 handle transliteration ranges
2790 skip regexp comments /(?#comment)/ and codes /(?{code})/
2791 skip #-initiated comments in //x patterns
2792 check for embedded arrays
2793 check for embedded scalars
2795 deprecate \1 in substitution replacements
2796 handle string-changing backslashes \l \U \Q \E, etc.
2797 switch (what was escaped) {
2798 handle \- in a transliteration (becomes a literal -)
2799 if a pattern and not \N{, go treat as regular character
2800 handle \132 (octal characters)
2801 handle \x15 and \x{1234} (hex characters)
2802 handle \N{name} (named characters, also \N{3,5} in a pattern)
2803 handle \cV (control characters)
2804 handle printf-style backslashes (\f, \r, \n, etc)
2807 } (end if backslash)
2808 handle regular character
2809 } (end while character to read)
2814 S_scan_const(pTHX_ char *start)
2816 char *send = PL_bufend; /* end of the constant */
2817 SV *sv = newSV(send - start); /* sv for the constant. See note below
2819 char *s = start; /* start of the constant */
2820 char *d = SvPVX(sv); /* destination for copies */
2821 bool dorange = FALSE; /* are we in a translit range? */
2822 bool didrange = FALSE; /* did we just finish a range? */
2823 bool in_charclass = FALSE; /* within /[...]/ */
2824 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2825 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2826 UTF8? But, this can show as true
2827 when the source isn't utf8, as for
2828 example when it is entirely composed
2830 SV *res; /* result from charnames */
2832 /* Note on sizing: The scanned constant is placed into sv, which is
2833 * initialized by newSV() assuming one byte of output for every byte of
2834 * input. This routine expects newSV() to allocate an extra byte for a
2835 * trailing NUL, which this routine will append if it gets to the end of
2836 * the input. There may be more bytes of input than output (eg., \N{LATIN
2837 * CAPITAL LETTER A}), or more output than input if the constant ends up
2838 * recoded to utf8, but each time a construct is found that might increase
2839 * the needed size, SvGROW() is called. Its size parameter each time is
2840 * based on the best guess estimate at the time, namely the length used so
2841 * far, plus the length the current construct will occupy, plus room for
2842 * the trailing NUL, plus one byte for every input byte still unscanned */
2844 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2847 UV literal_endpoint = 0;
2848 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2851 PERL_ARGS_ASSERT_SCAN_CONST;
2853 assert(PL_lex_inwhat != OP_TRANSR);
2854 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2855 /* If we are doing a trans and we know we want UTF8 set expectation */
2856 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2857 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2860 /* Protect sv from errors and fatal warnings. */
2861 ENTER_with_name("scan_const");
2864 while (s < send || dorange) {
2866 /* get transliterations out of the way (they're most literal) */
2867 if (PL_lex_inwhat == OP_TRANS) {
2868 /* expand a range A-Z to the full set of characters. AIE! */
2870 I32 i; /* current expanded character */
2871 I32 min; /* first character in range */
2872 I32 max; /* last character in range */
2883 char * const c = (char*)utf8_hop((U8*)d, -1);
2887 *c = (char) ILLEGAL_UTF8_BYTE;
2888 /* mark the range as done, and continue */
2894 i = d - SvPVX_const(sv); /* remember current offset */
2897 SvLEN(sv) + ((has_utf8)
2898 ? (512 - UTF_CONTINUATION_MARK
2901 /* How many two-byte within 0..255: 128 in UTF-8,
2902 * 96 in UTF-8-mod. */
2904 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2906 d = SvPVX(sv) + i; /* refresh d after realloc */
2910 for (j = 0; j <= 1; j++) {
2911 char * const c = (char*)utf8_hop((U8*)d, -1);
2912 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2918 max = (U8)0xff; /* only to \xff */
2919 uvmax = uv; /* \x{100} to uvmax */
2921 d = c; /* eat endpoint chars */
2926 d -= 2; /* eat the first char and the - */
2927 min = (U8)*d; /* first char in range */
2928 max = (U8)d[1]; /* last char in range */
2935 "Invalid range \"%c-%c\" in transliteration operator",
2936 (char)min, (char)max);
2940 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2941 * any subsets of these ranges into individual characters */
2942 if (literal_endpoint == 2 &&
2943 ((isLOWER_A(min) && isLOWER_A(max)) ||
2944 (isUPPER_A(min) && isUPPER_A(max))))
2946 for (i = min; i <= max; i++) {
2953 for (i = min; i <= max; i++)
2956 append_utf8_from_native_byte(i, &d);
2964 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2966 *d++ = (char) ILLEGAL_UTF8_BYTE;
2968 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2972 /* mark the range as done, and continue */
2976 literal_endpoint = 0;
2981 /* range begins (ignore - as first or last char) */
2982 else if (*s == '-' && s+1 < send && s != start) {
2984 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2991 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
3001 literal_endpoint = 0;
3002 native_range = TRUE;
3007 /* if we get here, we're not doing a transliteration */
3009 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3012 while (s1 >= start && *s1-- == '\\')
3015 in_charclass = TRUE;
3018 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3021 while (s1 >= start && *s1-- == '\\')
3024 in_charclass = FALSE;
3027 /* skip for regexp comments /(?#comment)/, except for the last
3028 * char, which will be done separately.
3029 * Stop on (?{..}) and friends */
3031 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3033 while (s+1 < send && *s != ')')
3036 else if (!PL_lex_casemods &&
3037 ( s[2] == '{' /* This should match regcomp.c */
3038 || (s[2] == '?' && s[3] == '{')))
3044 /* likewise skip #-initiated comments in //x patterns */
3045 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3046 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3047 while (s+1 < send && *s != '\n')
3051 /* no further processing of single-quoted regex */
3052 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3053 goto default_action;
3055 /* check for embedded arrays
3056 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3058 else if (*s == '@' && s[1]) {
3059 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3061 if (strchr(":'{$", s[1]))
3063 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3064 break; /* in regexp, neither @+ nor @- are interpolated */
3067 /* check for embedded scalars. only stop if we're sure it's a
3070 else if (*s == '$') {
3071 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3073 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3075 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3076 "Possible unintended interpolation of $\\ in regex");
3078 break; /* in regexp, $ might be tail anchor */
3082 /* End of else if chain - OP_TRANS rejoin rest */
3085 if (*s == '\\' && s+1 < send) {
3086 char* e; /* Can be used for ending '}', etc. */
3090 /* warn on \1 - \9 in substitution replacements, but note that \11
3091 * is an octal; and \19 is \1 followed by '9' */
3092 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3093 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3095 /* diag_listed_as: \%d better written as $%d */
3096 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3101 /* string-change backslash escapes */
3102 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3106 /* In a pattern, process \N, but skip any other backslash escapes.
3107 * This is because we don't want to translate an escape sequence
3108 * into a meta symbol and have the regex compiler use the meta
3109 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3110 * in spite of this, we do have to process \N here while the proper
3111 * charnames handler is in scope. See bugs #56444 and #62056.
3113 * There is a complication because \N in a pattern may also stand
3114 * for 'match a non-nl', and not mean a charname, in which case its
3115 * processing should be deferred to the regex compiler. To be a
3116 * charname it must be followed immediately by a '{', and not look
3117 * like \N followed by a curly quantifier, i.e., not something like
3118 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3120 else if (PL_lex_inpat
3123 || regcurly(s + 1)))
3126 goto default_action;
3131 /* quoted - in transliterations */
3133 if (PL_lex_inwhat == OP_TRANS) {
3140 if ((isALPHANUMERIC(*s)))
3141 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3142 "Unrecognized escape \\%c passed through",
3144 /* default action is to copy the quoted character */
3145 goto default_action;
3148 /* eg. \132 indicates the octal constant 0132 */
3149 case '0': case '1': case '2': case '3':
3150 case '4': case '5': case '6': case '7':
3152 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3154 uv = grok_oct(s, &len, &flags, NULL);
3156 if (len < 3 && s < send && isDIGIT(*s)
3157 && ckWARN(WARN_MISC))
3159 Perl_warner(aTHX_ packWARN(WARN_MISC),
3160 "%s", form_short_octal_warning(s, len));
3163 goto NUM_ESCAPE_INSERT;
3165 /* eg. \o{24} indicates the octal constant \024 */
3170 bool valid = grok_bslash_o(&s, &uv, &error,
3171 TRUE, /* Output warning */
3172 FALSE, /* Not strict */
3173 TRUE, /* Output warnings for
3180 goto NUM_ESCAPE_INSERT;
3183 /* eg. \x24 indicates the hex constant 0x24 */
3188 bool valid = grok_bslash_x(&s, &uv, &error,
3189 TRUE, /* Output warning */
3190 FALSE, /* Not strict */
3191 TRUE, /* Output warnings for
3201 /* Insert oct or hex escaped character. There will always be
3202 * enough room in sv since such escapes will be longer than any
3203 * UTF-8 sequence they can end up as, except if they force us
3204 * to recode the rest of the string into utf8 */
3206 /* Here uv is the ordinal of the next character being added */
3207 if (!UVCHR_IS_INVARIANT(uv)) {
3208 if (!has_utf8 && uv > 255) {
3209 /* Might need to recode whatever we have accumulated so
3210 * far if it contains any chars variant in utf8 or
3213 SvCUR_set(sv, d - SvPVX_const(sv));
3216 /* See Note on sizing above. */
3217 sv_utf8_upgrade_flags_grow(
3219 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3220 /* Above-latin1 in string
3221 * implies no encoding */
3222 |SV_UTF8_NO_ENCODING,
3223 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3224 d = SvPVX(sv) + SvCUR(sv);
3229 d = (char*)uvchr_to_utf8((U8*)d, uv);
3230 if (PL_lex_inwhat == OP_TRANS &&
3231 PL_sublex_info.sub_op) {
3232 PL_sublex_info.sub_op->op_private |=
3233 (PL_lex_repl ? OPpTRANS_FROM_UTF
3237 if (uv > 255 && !dorange)
3238 native_range = FALSE;
3251 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3252 * named character, like \N{LATIN SMALL LETTER A}, or a named
3253 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3254 * GRAVE}. For convenience all three forms are referred to as
3255 * "named characters" below.
3257 * For patterns, \N also can mean to match a non-newline. Code
3258 * before this 'switch' statement should already have handled
3259 * this situation, and hence this code only has to deal with
3260 * the named character cases.
3262 * For non-patterns, the named characters are converted to
3263 * their string equivalents. In patterns, named characters are
3264 * not converted to their ultimate forms for the same reasons
3265 * that other escapes aren't. Instead, they are converted to
3266 * the \N{U+...} form to get the value from the charnames that
3267 * is in effect right now, while preserving the fact that it
3268 * was a named character, so that the regex compiler knows
3271 * The structure of this section of code (besides checking for
3272 * errors and upgrading to utf8) is:
3273 * If the named character is of the form \N{U+...}, pass it
3274 * through if a pattern; otherwise convert the code point
3276 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3277 * if a pattern; otherwise convert to utf8
3279 * Here, 's' points to the 'N'; the test below is guaranteed to
3280 * succeed if we are being called on a pattern, as we already
3281 * know from a test above that the next character is a '{'. A
3282 * non-pattern \N must mean 'named character', which requires
3286 yyerror("Missing braces on \\N{}");
3291 /* If there is no matching '}', it is an error. */
3292 if (! (e = strchr(s, '}'))) {
3293 if (! PL_lex_inpat) {
3294 yyerror("Missing right brace on \\N{}");
3296 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3301 /* Here it looks like a named character */
3303 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3304 s += 2; /* Skip to next char after the 'U+' */
3307 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3308 /* Check the syntax. */
3311 if (!isXDIGIT(*s)) {
3314 "Invalid hexadecimal number in \\N{U+...}"
3322 else if ((*s == '.' || *s == '_')
3328 /* Pass everything through unchanged.
3329 * +1 is for the '}' */
3330 Copy(orig_s, d, e - orig_s + 1, char);
3331 d += e - orig_s + 1;
3333 else { /* Not a pattern: convert the hex to string */
3334 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3335 | PERL_SCAN_SILENT_ILLDIGIT
3336 | PERL_SCAN_DISALLOW_PREFIX;
3338 uv = grok_hex(s, &len, &flags, NULL);
3339 if (len == 0 || (len != (STRLEN)(e - s)))
3342 /* If the destination is not in utf8, unconditionally
3343 * recode it to be so. This is because \N{} implies
3344 * Unicode semantics, and scalars have to be in utf8
3345 * to guarantee those semantics */
3347 SvCUR_set(sv, d - SvPVX_const(sv));
3350 /* See Note on sizing above. */
3351 sv_utf8_upgrade_flags_grow(
3353 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3354 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3355 d = SvPVX(sv) + SvCUR(sv);
3359 /* Add the (Unicode) code point to the output. */
3360 if (UNI_IS_INVARIANT(uv)) {
3361 *d++ = (char) LATIN1_TO_NATIVE(uv);
3364 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3368 else /* Here is \N{NAME} but not \N{U+...}. */
3369 if ((res = get_and_check_backslash_N_name(s, e)))
3372 const char *str = SvPV_const(res, len);
3375 if (! len) { /* The name resolved to an empty string */
3376 Copy("\\N{}", d, 4, char);
3380 /* In order to not lose information for the regex
3381 * compiler, pass the result in the specially made
3382 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3383 * the code points in hex of each character
3384 * returned by charnames */
3386 const char *str_end = str + len;
3387 const STRLEN off = d - SvPVX_const(sv);
3389 if (! SvUTF8(res)) {
3390 /* For the non-UTF-8 case, we can determine the
3391 * exact length needed without having to parse
3392 * through the string. Each character takes up
3393 * 2 hex digits plus either a trailing dot or
3395 const char initial_text[] = "\\N{U+";
3396 const STRLEN initial_len = sizeof(initial_text)
3398 d = off + SvGROW(sv, off
3401 /* +1 for trailing NUL */
3404 + (STRLEN)(send - e));
3405 Copy(initial_text, d, initial_len, char);
3407 while (str < str_end) {
3410 my_snprintf(hex_string,
3414 /* The regex compiler is
3415 * expecting Unicode, not
3417 (U8) NATIVE_TO_LATIN1(*str));
3418 PERL_MY_SNPRINTF_POST_GUARD(len,
3419 sizeof(hex_string));
3420 Copy(hex_string, d, 3, char);
3424 d--; /* Below, we will overwrite the final
3425 dot with a right brace */
3428 STRLEN char_length; /* cur char's byte length */
3430 /* and the number of bytes after this is
3431 * translated into hex digits */
3432 STRLEN output_length;
3434 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3435 * for max('U+', '.'); and 1 for NUL */
3436 char hex_string[2 * UTF8_MAXBYTES + 5];
3438 /* Get the first character of the result. */
3439 U32 uv = utf8n_to_uvchr((U8 *) str,
3443 /* Convert first code point to Unicode hex,
3444 * including the boiler plate before it. */
3446 my_snprintf(hex_string, sizeof(hex_string),
3448 (unsigned int) NATIVE_TO_UNI(uv));
3450 /* Make sure there is enough space to hold it */
3451 d = off + SvGROW(sv, off
3453 + (STRLEN)(send - e)
3454 + 2); /* '}' + NUL */
3456 Copy(hex_string, d, output_length, char);
3459 /* For each subsequent character, append dot and
3460 * its Unicode code point in hex */
3461 while ((str += char_length) < str_end) {
3462 const STRLEN off = d - SvPVX_const(sv);
3463 U32 uv = utf8n_to_uvchr((U8 *) str,
3468 my_snprintf(hex_string,
3471 (unsigned int) NATIVE_TO_UNI(uv));
3473 d = off + SvGROW(sv, off
3475 + (STRLEN)(send - e)
3476 + 2); /* '}' + NUL */
3477 Copy(hex_string, d, output_length, char);
3482 *d++ = '}'; /* Done. Add the trailing brace */
3485 else { /* Here, not in a pattern. Convert the name to a
3488 /* If destination is not in utf8, unconditionally
3489 * recode it to be so. This is because \N{} implies
3490 * Unicode semantics, and scalars have to be in utf8
3491 * to guarantee those semantics */
3493 SvCUR_set(sv, d - SvPVX_const(sv));
3496 /* See Note on sizing above. */
3497 sv_utf8_upgrade_flags_grow(sv,
3498 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3499 len + (STRLEN)(send - s) + 1);
3500 d = SvPVX(sv) + SvCUR(sv);
3502 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3504 /* See Note on sizing above. (NOTE: SvCUR() is not
3505 * set correctly here). */
3506 const STRLEN off = d - SvPVX_const(sv);
3507 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3509 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3510 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3511 str = SvPV_const(res, len);
3513 Copy(str, d, len, char);
3519 } /* End \N{NAME} */
3522 native_range = FALSE; /* \N{} is defined to be Unicode */
3524 s = e + 1; /* Point to just after the '}' */
3527 /* \c is a control character */
3531 *d++ = grok_bslash_c(*s++, 1);
3534 yyerror("Missing control char name in \\c");
3538 /* printf-style backslashes, formfeeds, newlines, etc */
3564 } /* end if (backslash) */
3571 /* If we started with encoded form, or already know we want it,
3572 then encode the next character */
3573 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3577 /* One might think that it is wasted effort in the case of the
3578 * source being utf8 (this_utf8 == TRUE) to take the next character
3579 * in the source, convert it to an unsigned value, and then convert
3580 * it back again. But the source has not been validated here. The
3581 * routine that does the conversion checks for errors like
3584 const UV nextuv = (this_utf8)
3585 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3587 const STRLEN need = UNISKIP(nextuv);
3589 SvCUR_set(sv, d - SvPVX_const(sv));
3592 /* See Note on sizing above. */
3593 sv_utf8_upgrade_flags_grow(sv,
3594 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3595 need + (STRLEN)(send - s) + 1);
3596 d = SvPVX(sv) + SvCUR(sv);
3598 } else if (need > len) {
3599 /* encoded value larger than old, may need extra space (NOTE:
3600 * SvCUR() is not set correctly here). See Note on sizing
3602 const STRLEN off = d - SvPVX_const(sv);
3603 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3607 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3609 if (uv > 255 && !dorange)
3610 native_range = FALSE;
3616 } /* while loop to process each character */
3618 /* terminate the string and set up the sv */
3620 SvCUR_set(sv, d - SvPVX_const(sv));
3621 if (SvCUR(sv) >= SvLEN(sv))
3622 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3623 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3626 if (IN_ENCODING && !has_utf8) {
3627 sv_recode_to_utf8(sv, _get_encoding());
3633 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3634 PL_sublex_info.sub_op->op_private |=
3635 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3639 /* shrink the sv if we allocated more than we used */
3640 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3641 SvPV_shrink_to_cur(sv);
3644 /* return the substring (via pl_yylval) only if we parsed anything */
3647 for (; s2 < s; s2++) {
3649 COPLINE_INC_WITH_HERELINES;
3651 SvREFCNT_inc_simple_void_NN(sv);
3652 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3653 && ! PL_parser->lex_re_reparsing)
3655 const char *const key = PL_lex_inpat ? "qr" : "q";
3656 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3660 if (PL_lex_inwhat == OP_TRANS) {
3663 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3666 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3674 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3677 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3679 LEAVE_with_name("scan_const");
3684 * Returns TRUE if there's more to the expression (e.g., a subscript),
3687 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3689 * ->[ and ->{ return TRUE
3690 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3691 * { and [ outside a pattern are always subscripts, so return TRUE
3692 * if we're outside a pattern and it's not { or [, then return FALSE
3693 * if we're in a pattern and the first char is a {
3694 * {4,5} (any digits around the comma) returns FALSE
3695 * if we're in a pattern and the first char is a [
3697 * [SOMETHING] has a funky algorithm to decide whether it's a
3698 * character class or not. It has to deal with things like
3699 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3700 * anything else returns TRUE
3703 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3706 S_intuit_more(pTHX_ char *s)
3708 PERL_ARGS_ASSERT_INTUIT_MORE;
3710 if (PL_lex_brackets)
3712 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3714 if (*s == '-' && s[1] == '>'
3715 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3716 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3717 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3719 if (*s != '{' && *s != '[')
3724 /* In a pattern, so maybe we have {n,m}. */
3732 /* On the other hand, maybe we have a character class */
3735 if (*s == ']' || *s == '^')
3738 /* this is terrifying, and it works */
3741 const char * const send = strchr(s,']');
3742 unsigned char un_char, last_un_char;
3743 char tmpbuf[sizeof PL_tokenbuf * 4];
3745 if (!send) /* has to be an expression */
3747 weight = 2; /* let's weigh the evidence */
3751 else if (isDIGIT(*s)) {
3753 if (isDIGIT(s[1]) && s[2] == ']')
3759 Zero(seen,256,char);
3761 for (; s < send; s++) {
3762 last_un_char = un_char;
3763 un_char = (unsigned char)*s;
3768 weight -= seen[un_char] * 10;
3769 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3771 char *tmp = PL_bufend;
3772 PL_bufend = (char*)send;
3773 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3775 len = (int)strlen(tmpbuf);
3776 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3777 UTF ? SVf_UTF8 : 0, SVt_PV))
3782 else if (*s == '$' && s[1] &&
3783 strchr("[#!%*<>()-=",s[1])) {
3784 if (/*{*/ strchr("])} =",s[2]))
3793 if (strchr("wds]",s[1]))
3795 else if (seen[(U8)'\''] || seen[(U8)'"'])
3797 else if (strchr("rnftbxcav",s[1]))
3799 else if (isDIGIT(s[1])) {
3801 while (s[1] && isDIGIT(s[1]))
3811 if (strchr("aA01! ",last_un_char))
3813 if (strchr("zZ79~",s[1]))
3815 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3816 weight -= 5; /* cope with negative subscript */
3819 if (!isWORDCHAR(last_un_char)
3820 && !(last_un_char == '$' || last_un_char == '@'
3821 || last_un_char == '&')
3822 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3826 if (keyword(d, s - d, 0))
3829 if (un_char == last_un_char + 1)
3831 weight -= seen[un_char];
3836 if (weight >= 0) /* probably a character class */
3846 * Does all the checking to disambiguate
3848 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3849 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3851 * First argument is the stuff after the first token, e.g. "bar".
3853 * Not a method if foo is a filehandle.
3854 * Not a method if foo is a subroutine prototyped to take a filehandle.
3855 * Not a method if it's really "Foo $bar"
3856 * Method if it's "foo $bar"
3857 * Not a method if it's really "print foo $bar"
3858 * Method if it's really "foo package::" (interpreted as package->foo)
3859 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3860 * Not a method if bar is a filehandle or package, but is quoted with
3865 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3867 char *s = start + (*start == '$');
3868 char tmpbuf[sizeof PL_tokenbuf];
3871 /* Mustn't actually add anything to a symbol table.
3872 But also don't want to "initialise" any placeholder
3873 constants that might already be there into full
3874 blown PVGVs with attached PVCV. */
3876 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3878 PERL_ARGS_ASSERT_INTUIT_METHOD;
3880 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3882 if (cv && SvPOK(cv)) {
3883 const char *proto = CvPROTO(cv);
3885 while (*proto && (isSPACE(*proto) || *proto == ';'))
3892 if (*start == '$') {
3893 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3894 isUPPER(*PL_tokenbuf))
3899 return *s == '(' ? FUNCMETH : METHOD;
3902 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3903 /* start is the beginning of the possible filehandle/object,
3904 * and s is the end of it
3905 * tmpbuf is a copy of it (but with single quotes as double colons)
3908 if (!keyword(tmpbuf, len, 0)) {
3909 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3914 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3915 if (indirgv && GvCVu(indirgv))
3917 /* filehandle or package name makes it a method */
3918 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3920 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3921 return 0; /* no assumptions -- "=>" quotes bareword */
3923 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3924 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3925 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3929 return *s == '(' ? FUNCMETH : METHOD;
3935 /* Encoded script support. filter_add() effectively inserts a
3936 * 'pre-processing' function into the current source input stream.
3937 * Note that the filter function only applies to the current source file
3938 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3940 * The datasv parameter (which may be NULL) can be used to pass
3941 * private data to this instance of the filter. The filter function
3942 * can recover the SV using the FILTER_DATA macro and use it to
3943 * store private buffers and state information.
3945 * The supplied datasv parameter is upgraded to a PVIO type
3946 * and the IoDIRP/IoANY field is used to store the function pointer,
3947 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3948 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3949 * private use must be set using malloc'd pointers.
3953 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3961 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3962 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3964 if (!PL_rsfp_filters)
3965 PL_rsfp_filters = newAV();
3968 SvUPGRADE(datasv, SVt_PVIO);
3969 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3970 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3971 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3972 FPTR2DPTR(void *, IoANY(datasv)),
3973 SvPV_nolen(datasv)));
3974 av_unshift(PL_rsfp_filters, 1);
3975 av_store(PL_rsfp_filters, 0, datasv) ;
3977 !PL_parser->filtered
3978 && PL_parser->lex_flags & LEX_EVALBYTES
3979 && PL_bufptr < PL_bufend
3981 const char *s = PL_bufptr;
3982 while (s < PL_bufend) {
3984 SV *linestr = PL_parser->linestr;
3985 char *buf = SvPVX(linestr);
3986 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3987 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3988 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3989 STRLEN const linestart_pos = PL_parser->linestart - buf;
3990 STRLEN const last_uni_pos =
3991 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3992 STRLEN const last_lop_pos =
3993 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3994 av_push(PL_rsfp_filters, linestr);
3995 PL_parser->linestr =
3996 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3997 buf = SvPVX(PL_parser->linestr);
3998 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3999 PL_parser->bufptr = buf + bufptr_pos;
4000 PL_parser->oldbufptr = buf + oldbufptr_pos;
4001 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4002 PL_parser->linestart = buf + linestart_pos;
4003 if (PL_parser->last_uni)
4004 PL_parser->last_uni = buf + last_uni_pos;
4005 if (PL_parser->last_lop)
4006 PL_parser->last_lop = buf + last_lop_pos;
4007 SvLEN(linestr) = SvCUR(linestr);
4008 SvCUR(linestr) = s-SvPVX(linestr);
4009 PL_parser->filtered = 1;
4019 /* Delete most recently added instance of this filter function. */
4021 Perl_filter_del(pTHX_ filter_t funcp)
4025 PERL_ARGS_ASSERT_FILTER_DEL;
4028 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4029 FPTR2DPTR(void*, funcp)));
4031 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4033 /* if filter is on top of stack (usual case) just pop it off */
4034 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4035 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4036 sv_free(av_pop(PL_rsfp_filters));
4040 /* we need to search for the correct entry and clear it */
4041 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4045 /* Invoke the idxth filter function for the current rsfp. */
4046 /* maxlen 0 = read one text line */
4048 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4052 /* This API is bad. It should have been using unsigned int for maxlen.
4053 Not sure if we want to change the API, but if not we should sanity
4054 check the value here. */
4055 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4057 PERL_ARGS_ASSERT_FILTER_READ;
4059 if (!PL_parser || !PL_rsfp_filters)
4061 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4062 /* Provide a default input filter to make life easy. */
4063 /* Note that we append to the line. This is handy. */
4064 DEBUG_P(PerlIO_printf(Perl_debug_log,
4065 "filter_read %d: from rsfp\n", idx));
4066 if (correct_length) {
4069 const int old_len = SvCUR(buf_sv);
4071 /* ensure buf_sv is large enough */
4072 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4073 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4074 correct_length)) <= 0) {
4075 if (PerlIO_error(PL_rsfp))
4076 return -1; /* error */
4078 return 0 ; /* end of file */
4080 SvCUR_set(buf_sv, old_len + len) ;
4081 SvPVX(buf_sv)[old_len + len] = '\0';
4084 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4085 if (PerlIO_error(PL_rsfp))
4086 return -1; /* error */
4088 return 0 ; /* end of file */
4091 return SvCUR(buf_sv);
4093 /* Skip this filter slot if filter has been deleted */
4094 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4095 DEBUG_P(PerlIO_printf(Perl_debug_log,
4096 "filter_read %d: skipped (filter deleted)\n",
4098 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4100 if (SvTYPE(datasv) != SVt_PVIO) {
4101 if (correct_length) {
4103 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4104 if (!remainder) return 0; /* eof */
4105 if (correct_length > remainder) correct_length = remainder;
4106 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4107 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4110 const char *s = SvEND(datasv);
4111 const char *send = SvPVX(datasv) + SvLEN(datasv);
4119 if (s == send) return 0; /* eof */
4120 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4121 SvCUR_set(datasv, s-SvPVX(datasv));
4123 return SvCUR(buf_sv);
4125 /* Get function pointer hidden within datasv */
4126 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4127 DEBUG_P(PerlIO_printf(Perl_debug_log,
4128 "filter_read %d: via function %p (%s)\n",
4129 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4130 /* Call function. The function is expected to */
4131 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4132 /* Return: <0:error, =0:eof, >0:not eof */
4133 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4137 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4139 PERL_ARGS_ASSERT_FILTER_GETS;
4141 #ifdef PERL_CR_FILTER
4142 if (!PL_rsfp_filters) {
4143 filter_add(S_cr_textfilter,NULL);
4146 if (PL_rsfp_filters) {
4148 SvCUR_set(sv, 0); /* start with empty line */
4149 if (FILTER_READ(0, sv, 0) > 0)
4150 return ( SvPVX(sv) ) ;
4155 return (sv_gets(sv, PL_rsfp, append));
4159 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4163 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4165 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4169 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4170 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4172 return GvHV(gv); /* Foo:: */
4175 /* use constant CLASS => 'MyClass' */
4176 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4177 if (gv && GvCV(gv)) {
4178 SV * const sv = cv_const_sv(GvCV(gv));
4180 return gv_stashsv(sv, 0);
4183 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4188 S_tokenize_use(pTHX_ int is_use, char *s) {
4189 PERL_ARGS_ASSERT_TOKENIZE_USE;
4191 if (PL_expect != XSTATE)
4192 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4193 is_use ? "use" : "no"));
4196 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4197 s = force_version(s, TRUE);
4198 if (*s == ';' || *s == '}'
4199 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4200 NEXTVAL_NEXTTOKE.opval = NULL;
4203 else if (*s == 'v') {
4204 s = force_word(s,WORD,FALSE,TRUE);
4205 s = force_version(s, FALSE);
4209 s = force_word(s,WORD,FALSE,TRUE);
4210 s = force_version(s, FALSE);
4212 pl_yylval.ival = is_use;
4216 static const char* const exp_name[] =
4217 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4218 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4223 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4225 S_word_takes_any_delimeter(char *p, STRLEN len)
4227 return (len == 1 && strchr("msyq", p[0])) ||
4229 (p[0] == 't' && p[1] == 'r') ||
4230 (p[0] == 'q' && strchr("qwxr", p[1]))));
4234 S_check_scalar_slice(pTHX_ char *s)
4237 while (*s == ' ' || *s == '\t') s++;
4238 if (*s == 'q' && s[1] == 'w'
4239 && !isWORDCHAR_lazy_if(s+2,UTF))
4241 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4242 s += UTF ? UTF8SKIP(s) : 1;
4243 if (*s == '}' || *s == ']')
4244 pl_yylval.ival = OPpSLICEWARNING;
4250 Works out what to call the token just pulled out of the input
4251 stream. The yacc parser takes care of taking the ops we return and
4252 stitching them into a tree.
4255 The type of the next token
4258 Switch based on the current state:
4259 - if we already built the token before, use it
4260 - if we have a case modifier in a string, deal with that
4261 - handle other cases of interpolation inside a string
4262 - scan the next line if we are inside a format
4263 In the normal state switch on the next character:
4265 if alphabetic, go to key lookup
4266 unrecoginized character - croak
4267 - 0/4/26: handle end-of-line or EOF
4268 - cases for whitespace
4269 - \n and #: handle comments and line numbers
4270 - various operators, brackets and sigils
4273 - 'v': vstrings (or go to key lookup)
4274 - 'x' repetition operator (or go to key lookup)
4275 - other ASCII alphanumerics (key lookup begins here):
4278 scan built-in keyword (but do nothing with it yet)
4279 check for statement label
4280 check for lexical subs
4281 goto just_a_word if there is one
4282 see whether built-in keyword is overridden
4283 switch on keyword number:
4284 - default: just_a_word:
4285 not a built-in keyword; handle bareword lookup
4286 disambiguate between method and sub call
4287 fall back to bareword
4288 - cases for built-in keywords
4296 char *s = PL_bufptr;
4300 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4304 /* orig_keyword, gvp, and gv are initialized here because
4305 * jump to the label just_a_word_zero can bypass their
4306 * initialization later. */
4307 I32 orig_keyword = 0;
4312 SV* tmp = newSVpvs("");
4313 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4314 (IV)CopLINE(PL_curcop),
4315 lex_state_names[PL_lex_state],
4316 exp_name[PL_expect],
4317 pv_display(tmp, s, strlen(s), 0, 60));
4321 /* when we've already built the next token, just pull it out of the queue */
4324 pl_yylval = PL_nextval[PL_nexttoke];
4326 PL_lex_state = PL_lex_defer;
4327 PL_lex_defer = LEX_NORMAL;
4331 next_type = PL_nexttype[PL_nexttoke];
4332 if (next_type & (7<<24)) {
4333 if (next_type & (1<<24)) {
4334 if (PL_lex_brackets > 100)
4335 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4336 PL_lex_brackstack[PL_lex_brackets++] =
4337 (char) ((next_type >> 16) & 0xff);
4339 if (next_type & (2<<24))
4340 PL_lex_allbrackets++;
4341 if (next_type & (4<<24))
4342 PL_lex_allbrackets--;
4343 next_type &= 0xffff;
4345 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4349 switch (PL_lex_state) {
4351 case LEX_INTERPNORMAL:
4354 /* interpolated case modifiers like \L \U, including \Q and \E.
4355 when we get here, PL_bufptr is at the \
4357 case LEX_INTERPCASEMOD:
4359 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4361 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4362 PL_bufptr, PL_bufend, *PL_bufptr);
4364 /* handle \E or end of string */
4365 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4367 if (PL_lex_casemods) {
4368 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4369 PL_lex_casestack[PL_lex_casemods] = '\0';
4371 if (PL_bufptr != PL_bufend
4372 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4373 || oldmod == 'F')) {
4375 PL_lex_state = LEX_INTERPCONCAT;
4377 PL_lex_allbrackets--;
4380 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4381 /* Got an unpaired \E */
4382 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4383 "Useless use of \\E");
4385 if (PL_bufptr != PL_bufend)
4387 PL_lex_state = LEX_INTERPCONCAT;
4391 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4392 "### Saw case modifier\n"); });
4394 if (s[1] == '\\' && s[2] == 'E') {
4396 PL_lex_state = LEX_INTERPCONCAT;
4401 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4402 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4403 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4404 (strchr(PL_lex_casestack, 'L')
4405 || strchr(PL_lex_casestack, 'U')
4406 || strchr(PL_lex_casestack, 'F'))) {
4407 PL_lex_casestack[--PL_lex_casemods] = '\0';
4408 PL_lex_allbrackets--;
4411 if (PL_lex_casemods > 10)
4412 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4413 PL_lex_casestack[PL_lex_casemods++] = *s;
4414 PL_lex_casestack[PL_lex_casemods] = '\0';
4415 PL_lex_state = LEX_INTERPCONCAT;
4416 NEXTVAL_NEXTTOKE.ival = 0;
4417 force_next((2<<24)|'(');
4419 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4421 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4423 NEXTVAL_NEXTTOKE.ival = OP_LC;
4425 NEXTVAL_NEXTTOKE.ival = OP_UC;
4427 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4429 NEXTVAL_NEXTTOKE.ival = OP_FC;
4431 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4435 if (PL_lex_starts) {
4438 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4439 if (PL_lex_casemods == 1 && PL_lex_inpat)
4442 AopNOASSIGN(OP_CONCAT);
4448 case LEX_INTERPPUSH:
4449 return REPORT(sublex_push());
4451 case LEX_INTERPSTART:
4452 if (PL_bufptr == PL_bufend)
4453 return REPORT(sublex_done());
4454 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4455 "### Interpolated variable\n"); });
4457 /* for /@a/, we leave the joining for the regex engine to do
4458 * (unless we're within \Q etc) */
4459 PL_lex_dojoin = (*PL_bufptr == '@'
4460 && (!PL_lex_inpat || PL_lex_casemods));
4461 PL_lex_state = LEX_INTERPNORMAL;
4462 if (PL_lex_dojoin) {
4463 NEXTVAL_NEXTTOKE.ival = 0;
4465 force_ident("\"", '$');
4466 NEXTVAL_NEXTTOKE.ival = 0;
4468 NEXTVAL_NEXTTOKE.ival = 0;
4469 force_next((2<<24)|'(');
4470 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4473 /* Convert (?{...}) and friends to 'do {...}' */
4474 if (PL_lex_inpat && *PL_bufptr == '(') {
4475 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4477 if (*PL_bufptr != '{')
4479 PL_expect = XTERMBLOCK;
4483 if (PL_lex_starts++) {
4485 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4486 if (!PL_lex_casemods && PL_lex_inpat)
4489 AopNOASSIGN(OP_CONCAT);
4493 case LEX_INTERPENDMAYBE:
4494 if (intuit_more(PL_bufptr)) {
4495 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4501 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4502 XXX This hack can be removed if we stop setting PL_lex_state to
4503 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4504 if (UNLIKELY(!PL_lex_inwhat)) {
4505 PL_lex_state = LEX_NORMAL;
4509 if (PL_lex_dojoin) {
4510 const U8 dojoin_was = PL_lex_dojoin;
4511 PL_lex_dojoin = FALSE;
4512 PL_lex_state = LEX_INTERPCONCAT;
4513 PL_lex_allbrackets--;
4514 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4516 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4517 && SvEVALED(PL_lex_repl))
4519 if (PL_bufptr != PL_bufend)
4520 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4523 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4524 re_eval_str. If the here-doc body’s length equals the previous
4525 value of re_eval_start, re_eval_start will now be null. So
4526 check re_eval_str as well. */
4527 if (PL_parser->lex_shared->re_eval_start
4528 || PL_parser->lex_shared->re_eval_str) {
4530 if (*PL_bufptr != ')')
4531 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4533 /* having compiled a (?{..}) expression, return the original
4534 * text too, as a const */
4535 if (PL_parser->lex_shared->re_eval_str) {
4536 sv = PL_parser->lex_shared->re_eval_str;
4537 PL_parser->lex_shared->re_eval_str = NULL;
4539 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4540 SvPV_shrink_to_cur(sv);
4542 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4543 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4544 NEXTVAL_NEXTTOKE.opval =
4545 (OP*)newSVOP(OP_CONST, 0,
4548 PL_parser->lex_shared->re_eval_start = NULL;
4554 case LEX_INTERPCONCAT:
4556 if (PL_lex_brackets)
4557 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4558 (long) PL_lex_brackets);
4560 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4561 XXX This hack can be removed if we stop setting PL_lex_state to
4563 if (UNLIKELY(!PL_lex_inwhat)) {
4564 PL_lex_state = LEX_NORMAL;
4568 if (PL_bufptr == PL_bufend)
4569 return REPORT(sublex_done());
4571 /* m'foo' still needs to be parsed for possible (?{...}) */
4572 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4573 SV *sv = newSVsv(PL_linestr);
4575 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4579 s = scan_const(PL_bufptr);
4581 PL_lex_state = LEX_INTERPCASEMOD;
4583 PL_lex_state = LEX_INTERPSTART;
4586 if (s != PL_bufptr) {
4587 NEXTVAL_NEXTTOKE = pl_yylval;
4590 if (PL_lex_starts++) {
4591 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4592 if (!PL_lex_casemods && PL_lex_inpat)
4595 AopNOASSIGN(OP_CONCAT);
4605 s = scan_formline(PL_bufptr);
4606 if (!PL_lex_formbrack)
4615 /* We really do *not* want PL_linestr ever becoming a COW. */
4616 assert (!SvIsCOW(PL_linestr));
4618 PL_oldoldbufptr = PL_oldbufptr;
4620 PL_parser->saw_infix_sigil = 0;
4625 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4628 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4629 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4631 SVs_TEMP | SVf_UTF8),
4632 10, UNI_DISPLAY_ISPRINT)
4633 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4634 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4635 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4636 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4640 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4641 UTF8fARG(UTF, (s - d), d),
4646 goto fake_eof; /* emulate EOF on ^D or ^Z */
4648 if ((!PL_rsfp || PL_lex_inwhat)
4649 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4652 if (PL_lex_brackets &&
4653 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4654 yyerror((const char *)
4656 ? "Format not terminated"
4657 : "Missing right curly or square bracket"));
4659 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4660 "### Tokener got EOF\n");
4664 if (s++ < PL_bufend)
4665 goto retry; /* ignore stray nulls */
4668 if (!PL_in_eval && !PL_preambled) {
4669 PL_preambled = TRUE;
4671 /* Generate a string of Perl code to load the debugger.
4672 * If PERL5DB is set, it will return the contents of that,
4673 * otherwise a compile-time require of perl5db.pl. */
4675 const char * const pdb = PerlEnv_getenv("PERL5DB");
4678 sv_setpv(PL_linestr, pdb);
4679 sv_catpvs(PL_linestr,";");
4681 SETERRNO(0,SS_NORMAL);
4682 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4684 PL_parser->preambling = CopLINE(PL_curcop);
4686 sv_setpvs(PL_linestr,"");
4687 if (PL_preambleav) {
4688 SV **svp = AvARRAY(PL_preambleav);
4689 SV **const end = svp + AvFILLp(PL_preambleav);
4691 sv_catsv(PL_linestr, *svp);
4693 sv_catpvs(PL_linestr, ";");
4695 sv_free(MUTABLE_SV(PL_preambleav));
4696 PL_preambleav = NULL;
4699 sv_catpvs(PL_linestr,
4700 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4701 if (PL_minus_n || PL_minus_p) {
4702 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4704 sv_catpvs(PL_linestr,"chomp;");
4707 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4708 || *PL_splitstr == '"')
4709 && strchr(PL_splitstr + 1, *PL_splitstr))
4710 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4712 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4713 bytes can be used as quoting characters. :-) */
4714 const char *splits = PL_splitstr;
4715 sv_catpvs(PL_linestr, "our @F=split(q\0");
4718 if (*splits == '\\')
4719 sv_catpvn(PL_linestr, splits, 1);
4720 sv_catpvn(PL_linestr, splits, 1);
4721 } while (*splits++);
4722 /* This loop will embed the trailing NUL of
4723 PL_linestr as the last thing it does before
4725 sv_catpvs(PL_linestr, ");");
4729 sv_catpvs(PL_linestr,"our @F=split(' ');");
4732 sv_catpvs(PL_linestr, "\n");
4733 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4734 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4735 PL_last_lop = PL_last_uni = NULL;
4736 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4737 update_debugger_info(PL_linestr, NULL, 0);
4742 bof = PL_rsfp ? TRUE : FALSE;
4745 fake_eof = LEX_FAKE_EOF;
4747 PL_bufptr = PL_bufend;
4748 COPLINE_INC_WITH_HERELINES;
4749 if (!lex_next_chunk(fake_eof)) {
4750 CopLINE_dec(PL_curcop);
4752 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4754 CopLINE_dec(PL_curcop);
4756 /* If it looks like the start of a BOM or raw UTF-16,
4757 * check if it in fact is. */
4758 if (bof && PL_rsfp &&
4760 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4763 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4764 bof = (offset == (Off_t)SvCUR(PL_linestr));
4765 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4766 /* offset may include swallowed CR */
4768 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4771 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4772 s = swallow_bom((U8*)s);
4775 if (PL_parser->in_pod) {
4776 /* Incest with pod. */
4777 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4778 sv_setpvs(PL_linestr, "");
4779 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4780 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4781 PL_last_lop = PL_last_uni = NULL;
4782 PL_parser->in_pod = 0;
4785 if (PL_rsfp || PL_parser->filtered)
4787 } while (PL_parser->in_pod);
4788 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4789 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4790 PL_last_lop = PL_last_uni = NULL;
4791 if (CopLINE(PL_curcop) == 1) {
4792 while (s < PL_bufend && isSPACE(*s))
4794 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4798 if (*s == '#' && *(s+1) == '!')
4800 #ifdef ALTERNATE_SHEBANG
4802 static char const as[] = ALTERNATE_SHEBANG;
4803 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4804 d = s + (sizeof(as) - 1);
4806 #endif /* ALTERNATE_SHEBANG */
4815 while (*d && !isSPACE(*d))
4819 #ifdef ARG_ZERO_IS_SCRIPT
4820 if (ipathend > ipath) {
4822 * HP-UX (at least) sets argv[0] to the script name,
4823 * which makes $^X incorrect. And Digital UNIX and Linux,
4824 * at least, set argv[0] to the basename of the Perl
4825 * interpreter. So, having found "#!", we'll set it right.
4827 SV* copfilesv = CopFILESV(PL_curcop);
4830 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4832 assert(SvPOK(x) || SvGMAGICAL(x));
4833 if (sv_eq(x, copfilesv)) {
4834 sv_setpvn(x, ipath, ipathend - ipath);
4840 const char *bstart = SvPV_const(copfilesv, blen);
4841 const char * const lstart = SvPV_const(x, llen);
4843 bstart += blen - llen;
4844 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4845 sv_setpvn(x, ipath, ipathend - ipath);
4852 /* Anything to do if no copfilesv? */
4854 TAINT_NOT; /* $^X is always tainted, but that's OK */
4856 #endif /* ARG_ZERO_IS_SCRIPT */
4861 d = instr(s,"perl -");
4863 d = instr(s,"perl");
4865 /* avoid getting into infinite loops when shebang
4866 * line contains "Perl" rather than "perl" */
4868 for (d = ipathend-4; d >= ipath; --d) {
4869 if (isALPHA_FOLD_EQ(*d, 'p')
4870 && !ibcmp(d, "perl", 4))
4880 #ifdef ALTERNATE_SHEBANG
4882 * If the ALTERNATE_SHEBANG on this system starts with a
4883 * character that can be part of a Perl expression, then if
4884 * we see it but not "perl", we're probably looking at the
4885 * start of Perl code, not a request to hand off to some
4886 * other interpreter. Similarly, if "perl" is there, but
4887 * not in the first 'word' of the line, we assume the line
4888 * contains the start of the Perl program.
4890 if (d && *s != '#') {
4891 const char *c = ipath;
4892 while (*c && !strchr("; \t\r\n\f\v#", *c))
4895 d = NULL; /* "perl" not in first word; ignore */
4897 *s = '#'; /* Don't try to parse shebang line */
4899 #endif /* ALTERNATE_SHEBANG */
4904 !instr(s,"indir") &&
4905 instr(PL_origargv[0],"perl"))
4912 while (s < PL_bufend && isSPACE(*s))
4914 if (s < PL_bufend) {
4915 Newx(newargv,PL_origargc+3,char*);
4917 while (s < PL_bufend && !isSPACE(*s))
4920 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4923 newargv = PL_origargv;
4926 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4928 Perl_croak(aTHX_ "Can't exec %s", ipath);
4931 while (*d && !isSPACE(*d))
4933 while (SPACE_OR_TAB(*d))
4937 const bool switches_done = PL_doswitches;
4938 const U32 oldpdb = PL_perldb;
4939 const bool oldn = PL_minus_n;
4940 const bool oldp = PL_minus_p;
4944 bool baduni = FALSE;
4946 const char *d2 = d1 + 1;
4947 if (parse_unicode_opts((const char **)&d2)
4951 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4952 const char * const m = d1;
4953 while (*d1 && !isSPACE(*d1))
4955 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4958 d1 = moreswitches(d1);
4960 if (PL_doswitches && !switches_done) {
4961 int argc = PL_origargc;
4962 char **argv = PL_origargv;
4965 } while (argc && argv[0][0] == '-' && argv[0][1]);
4966 init_argv_symbols(argc,argv);
4968 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4969 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4970 /* if we have already added "LINE: while (<>) {",
4971 we must not do it again */
4973 sv_setpvs(PL_linestr, "");
4974 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4975 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4976 PL_last_lop = PL_last_uni = NULL;
4977 PL_preambled = FALSE;
4978 if (PERLDB_LINE || PERLDB_SAVESRC)
4979 (void)gv_fetchfile(PL_origfilename);
4986 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4987 PL_lex_state = LEX_FORMLINE;
4988 force_next(FORMRBRACK);
4993 #ifdef PERL_STRICT_CR
4994 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4996 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4998 case ' ': case '\t': case '\f': case '\v':
5003 if (PL_lex_state != LEX_NORMAL ||
5004 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5005 const bool in_comment = *s == '#';
5006 if (*s == '#' && s == PL_linestart && PL_in_eval
5007 && !PL_rsfp && !PL_parser->filtered) {
5008 /* handle eval qq[#line 1 "foo"\n ...] */
5009 CopLINE_dec(PL_curcop);
5013 while (d < PL_bufend && *d != '\n')
5017 else if (d > PL_bufend)
5018 /* Found by Ilya: feed random input to Perl. */
5019 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5022 if (in_comment && d == PL_bufend
5023 && PL_lex_state == LEX_INTERPNORMAL
5024 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5025 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5028 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5029 PL_lex_state = LEX_FORMLINE;
5030 force_next(FORMRBRACK);
5035 while (s < PL_bufend && *s != '\n')
5043 else if (s > PL_bufend)
5044 /* Found by Ilya: feed random input to Perl. */
5045 Perl_croak(aTHX_ "panic: input overflow");
5049 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5057 while (s < PL_bufend && SPACE_OR_TAB(*s))
5060 if (strnEQ(s,"=>",2)) {
5061 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5062 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5063 OPERATOR('-'); /* unary minus */
5066 case 'r': ftst = OP_FTEREAD; break;
5067 case 'w': ftst = OP_FTEWRITE; break;
5068 case 'x': ftst = OP_FTEEXEC; break;
5069 case 'o': ftst = OP_FTEOWNED; break;
5070 case 'R': ftst = OP_FTRREAD; break;
5071 case 'W': ftst = OP_FTRWRITE; break;
5072 case 'X': ftst = OP_FTREXEC; break;
5073 case 'O': ftst = OP_FTROWNED; break;
5074 case 'e': ftst = OP_FTIS; break;
5075 case 'z': ftst = OP_FTZERO; break;
5076 case 's': ftst = OP_FTSIZE; break;
5077 case 'f': ftst = OP_FTFILE; break;
5078 case 'd': ftst = OP_FTDIR; break;
5079 case 'l': ftst = OP_FTLINK; break;
5080 case 'p': ftst = OP_FTPIPE; break;
5081 case 'S': ftst = OP_FTSOCK; break;
5082 case 'u': ftst = OP_FTSUID; break;
5083 case 'g': ftst = OP_FTSGID; break;
5084 case 'k': ftst = OP_FTSVTX; break;
5085 case 'b': ftst = OP_FTBLK; break;
5086 case 'c': ftst = OP_FTCHR; break;
5087 case 't': ftst = OP_FTTTY; break;
5088 case 'T': ftst = OP_FTTEXT; break;
5089 case 'B': ftst = OP_FTBINARY; break;
5090 case 'M': case 'A': case 'C':
5091 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5093 case 'M': ftst = OP_FTMTIME; break;
5094 case 'A': ftst = OP_FTATIME; break;
5095 case 'C': ftst = OP_FTCTIME; break;
5103 PL_last_uni = PL_oldbufptr;
5104 PL_last_lop_op = (OPCODE)ftst;
5105 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5106 "### Saw file test %c\n", (int)tmp);
5111 /* Assume it was a minus followed by a one-letter named
5112 * subroutine call (or a -bareword), then. */
5113 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5114 "### '-%c' looked like a file test but was not\n",
5121 const char tmp = *s++;
5124 if (PL_expect == XOPERATOR)
5129 else if (*s == '>') {
5132 if (FEATURE_POSTDEREF_IS_ENABLED && (
5133 ((*s == '$' || *s == '&') && s[1] == '*')
5134 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5135 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5136 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5139 Perl_ck_warner_d(aTHX_
5140 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5141 "Postfix dereference is experimental"
5143 PL_expect = XPOSTDEREF;
5146 if (isIDFIRST_lazy_if(s,UTF)) {
5147 s = force_word(s,METHOD,FALSE,TRUE);
5155 if (PL_expect == XOPERATOR) {
5156 if (*s == '=' && !PL_lex_allbrackets &&
5157 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5164 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5166 OPERATOR('-'); /* unary minus */
5172 const char tmp = *s++;
5175 if (PL_expect == XOPERATOR)
5180 if (PL_expect == XOPERATOR) {
5181 if (*s == '=' && !PL_lex_allbrackets &&
5182 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5189 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5196 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5197 if (PL_expect != XOPERATOR) {
5198 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5199 PL_expect = XOPERATOR;
5200 force_ident(PL_tokenbuf, '*');
5208 if (*s == '=' && !PL_lex_allbrackets &&
5209 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5215 if (*s == '=' && !PL_lex_allbrackets &&
5216 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5220 PL_parser->saw_infix_sigil = 1;
5225 if (PL_expect == XOPERATOR) {
5226 if (s[1] == '=' && !PL_lex_allbrackets &&
5227 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5230 PL_parser->saw_infix_sigil = 1;
5233 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5234 PL_tokenbuf[0] = '%';
5235 s = scan_ident(s, PL_tokenbuf + 1,
5236 sizeof PL_tokenbuf - 1, FALSE);
5238 if (!PL_tokenbuf[1]) {
5241 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5243 PL_tokenbuf[0] = '@';
5245 PL_expect = XOPERATOR;
5246 force_ident_maybe_lex('%');
5251 bof = FEATURE_BITWISE_IS_ENABLED;
5252 if (bof && s[1] == '.')
5254 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5255 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5261 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5263 if (PL_lex_brackets > 100)
5264 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5265 PL_lex_brackstack[PL_lex_brackets++] = 0;
5266 PL_lex_allbrackets++;
5268 const char tmp = *s++;
5273 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5275 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5278 Perl_ck_warner_d(aTHX_
5279 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5280 "Smartmatch is experimental");
5284 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5286 BCop(OP_SCOMPLEMENT);
5288 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5290 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5297 goto just_a_word_zero_gv;
5303 switch (PL_expect) {
5305 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5307 PL_bufptr = s; /* update in case we back off */
5310 "Use of := for an empty attribute list is not allowed");
5317 PL_expect = XTERMBLOCK;
5321 while (isIDFIRST_lazy_if(s,UTF)) {
5324 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5325 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5326 if (tmp < 0) tmp = -tmp;
5341 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5343 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5344 COPLINE_SET_FROM_MULTI_END;
5346 /* MUST advance bufptr here to avoid bogus
5347 "at end of line" context messages from yyerror().
5349 PL_bufptr = s + len;
5350 yyerror("Unterminated attribute parameter in attribute list");
5354 return REPORT(0); /* EOF indicator */
5358 sv_catsv(sv, PL_lex_stuff);
5359 attrs = op_append_elem(OP_LIST, attrs,
5360 newSVOP(OP_CONST, 0, sv));
5361 SvREFCNT_dec_NN(PL_lex_stuff);
5362 PL_lex_stuff = NULL;
5365 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5367 if (PL_in_my == KEY_our) {
5368 deprecate(":unique");
5371 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5374 /* NOTE: any CV attrs applied here need to be part of
5375 the CVf_BUILTIN_ATTRS define in cv.h! */
5376 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5378 CvLVALUE_on(PL_compcv);
5380 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5382 deprecate(":locked");
5384 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5386 CvMETHOD_on(PL_compcv);
5388 else if (!PL_in_my && len == 5
5389 && strnEQ(SvPVX(sv), "const", len))
5392 Perl_ck_warner_d(aTHX_
5393 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5394 ":const is experimental"
5396 CvANONCONST_on(PL_compcv);
5397 if (!CvANON(PL_compcv))
5398 yyerror(":const is not permitted on named "
5401 /* After we've set the flags, it could be argued that
5402 we don't need to do the attributes.pm-based setting
5403 process, and shouldn't bother appending recognized
5404 flags. To experiment with that, uncomment the
5405 following "else". (Note that's already been
5406 uncommented. That keeps the above-applied built-in
5407 attributes from being intercepted (and possibly
5408 rejected) by a package's attribute routines, but is
5409 justified by the performance win for the common case
5410 of applying only built-in attributes.) */
5412 attrs = op_append_elem(OP_LIST, attrs,
5413 newSVOP(OP_CONST, 0,
5417 if (*s == ':' && s[1] != ':')
5420 break; /* require real whitespace or :'s */
5421 /* XXX losing whitespace on sequential attributes here */
5424 if (*s != ';' && *s != '}' &&
5425 !(PL_expect == XOPERATOR
5426 ? (*s == '=' || *s == ')')
5427 : (*s == '{' || *s == '('))) {
5428 const char q = ((*s == '\'') ? '"' : '\'');
5429 /* If here for an expression, and parsed no attrs, back
5431 if (PL_expect == XOPERATOR && !attrs) {
5435 /* MUST advance bufptr here to avoid bogus "at end of line"
5436 context messages from yyerror().
5439 yyerror( (const char *)
5441 ? Perl_form(aTHX_ "Invalid separator character "
5442 "%c%c%c in attribute list", q, *s, q)
5443 : "Unterminated attribute list" ) );
5451 NEXTVAL_NEXTTOKE.opval = attrs;
5457 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5461 PL_lex_allbrackets--;
5465 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5466 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5470 PL_lex_allbrackets++;
5473 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5480 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5483 PL_lex_allbrackets--;
5489 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5492 if (PL_lex_brackets <= 0)
5493 /* diag_listed_as: Unmatched right %s bracket */
5494 yyerror("Unmatched right square bracket");
5497 PL_lex_allbrackets--;
5498 if (PL_lex_state == LEX_INTERPNORMAL) {
5499 if (PL_lex_brackets == 0) {
5500 if (*s == '-' && s[1] == '>')
5501 PL_lex_state = LEX_INTERPENDMAYBE;
5502 else if (*s != '[' && *s != '{')
5503 PL_lex_state = LEX_INTERPEND;
5510 if (PL_lex_brackets > 100) {
5511 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5513 switch (PL_expect) {
5516 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5517 PL_lex_allbrackets++;
5518 OPERATOR(HASHBRACK);
5520 while (s < PL_bufend && SPACE_OR_TAB(*s))
5523 PL_tokenbuf[0] = '\0';
5524 if (d < PL_bufend && *d == '-') {
5525 PL_tokenbuf[0] = '-';
5527 while (d < PL_bufend && SPACE_OR_TAB(*d))
5530 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5531 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5533 while (d < PL_bufend && SPACE_OR_TAB(*d))
5536 const char minus = (PL_tokenbuf[0] == '-');
5537 s = force_word(s + minus, WORD, FALSE, TRUE);
5545 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5546 PL_lex_allbrackets++;
5551 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5552 PL_lex_allbrackets++;
5556 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5557 PL_lex_allbrackets++;
5562 if (PL_oldoldbufptr == PL_last_lop)
5563 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5565 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5566 PL_lex_allbrackets++;
5569 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5571 /* This hack is to get the ${} in the message. */
5573 yyerror("syntax error");
5576 OPERATOR(HASHBRACK);
5578 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5579 /* ${...} or @{...} etc., but not print {...}
5580 * Skip the disambiguation and treat this as a block.
5582 goto block_expectation;
5584 /* This hack serves to disambiguate a pair of curlies
5585 * as being a block or an anon hash. Normally, expectation
5586 * determines that, but in cases where we're not in a
5587 * position to expect anything in particular (like inside
5588 * eval"") we have to resolve the ambiguity. This code
5589 * covers the case where the first term in the curlies is a
5590 * quoted string. Most other cases need to be explicitly
5591 * disambiguated by prepending a "+" before the opening
5592 * curly in order to force resolution as an anon hash.
5594 * XXX should probably propagate the outer expectation
5595 * into eval"" to rely less on this hack, but that could
5596 * potentially break current behavior of eval"".
5600 if (*s == '\'' || *s == '"' || *s == '`') {
5601 /* common case: get past first string, handling escapes */
5602 for (t++; t < PL_bufend && *t != *s;)
5607 else if (*s == 'q') {
5610 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5611 && !isWORDCHAR(*t))))
5613 /* skip q//-like construct */
5615 char open, close, term;
5618 while (t < PL_bufend && isSPACE(*t))
5620 /* check for q => */
5621 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5622 OPERATOR(HASHBRACK);
5626 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5630 for (t++; t < PL_bufend; t++) {
5631 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5633 else if (*t == open)
5637 for (t++; t < PL_bufend; t++) {
5638 if (*t == '\\' && t+1 < PL_bufend)
5640 else if (*t == close && --brackets <= 0)
5642 else if (*t == open)
5649 /* skip plain q word */
5650 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5653 else if (isWORDCHAR_lazy_if(t,UTF)) {
5655 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5658 while (t < PL_bufend && isSPACE(*t))
5660 /* if comma follows first term, call it an anon hash */
5661 /* XXX it could be a comma expression with loop modifiers */
5662 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5663 || (*t == '=' && t[1] == '>')))
5664 OPERATOR(HASHBRACK);
5665 if (PL_expect == XREF)
5668 /* If there is an opening brace or 'sub:', treat it
5669 as a term to make ${{...}}{k} and &{sub:attr...}
5670 dwim. Otherwise, treat it as a statement, so
5671 map {no strict; ...} works.
5678 if (strnEQ(s, "sub", 3)) {
5689 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5695 pl_yylval.ival = CopLINE(PL_curcop);
5696 PL_copline = NOLINE; /* invalidate current command line number */
5697 TOKEN(formbrack ? '=' : '{');
5699 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5703 if (PL_lex_brackets <= 0)
5704 /* diag_listed_as: Unmatched right %s bracket */
5705 yyerror("Unmatched right curly bracket");
5707 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5708 PL_lex_allbrackets--;
5709 if (PL_lex_state == LEX_INTERPNORMAL) {
5710 if (PL_lex_brackets == 0) {
5711 if (PL_expect & XFAKEBRACK) {
5712 PL_expect &= XENUMMASK;
5713 PL_lex_state = LEX_INTERPEND;
5715 return yylex(); /* ignore fake brackets */
5717 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5718 && SvEVALED(PL_lex_repl))
5719 PL_lex_state = LEX_INTERPEND;
5720 else if (*s == '-' && s[1] == '>')
5721 PL_lex_state = LEX_INTERPENDMAYBE;
5722 else if (*s != '[' && *s != '{')
5723 PL_lex_state = LEX_INTERPEND;
5726 if (PL_expect & XFAKEBRACK) {
5727 PL_expect &= XENUMMASK;
5729 return yylex(); /* ignore fake brackets */
5731 force_next(formbrack ? '.' : '}');
5732 if (formbrack) LEAVE;
5733 if (formbrack == 2) { /* means . where arguments were expected */
5739 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5742 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5743 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5750 if (PL_expect == XOPERATOR) {
5751 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5752 && isIDFIRST_lazy_if(s,UTF))
5754 CopLINE_dec(PL_curcop);
5755 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5756 CopLINE_inc(PL_curcop);
5759 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5761 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5762 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5768 PL_parser->saw_infix_sigil = 1;
5769 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5775 PL_tokenbuf[0] = '&';
5776 s = scan_ident(s - 1, PL_tokenbuf + 1,
5777 sizeof PL_tokenbuf - 1, TRUE);
5778 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5779 if (PL_tokenbuf[1]) {
5780 force_ident_maybe_lex('&');
5789 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5790 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5798 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5800 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5801 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5805 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
5809 const char tmp = *s++;
5811 if (!PL_lex_allbrackets &&
5812 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5819 if (!PL_lex_allbrackets &&
5820 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5828 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5829 && strchr("+-*/%.^&|<",tmp))
5830 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5831 "Reversed %c= operator",(int)tmp);
5833 if (PL_expect == XSTATE && isALPHA(tmp) &&
5834 (s == PL_linestart+1 || s[-2] == '\n') )
5836 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5837 || PL_lex_state != LEX_NORMAL) {
5842 if (strnEQ(s,"=cut",4)) {
5856 PL_parser->in_pod = 1;
5860 if (PL_expect == XBLOCK) {
5862 #ifdef PERL_STRICT_CR
5863 while (SPACE_OR_TAB(*t))
5865 while (SPACE_OR_TAB(*t) || *t == '\r')
5868 if (*t == '\n' || *t == '#') {
5871 SAVEI8(PL_parser->form_lex_state);
5872 SAVEI32(PL_lex_formbrack);
5873 PL_parser->form_lex_state = PL_lex_state;
5874 PL_lex_formbrack = PL_lex_brackets + 1;
5878 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5887 const char tmp = *s++;
5889 /* was this !=~ where !~ was meant?
5890 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5892 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5893 const char *t = s+1;
5895 while (t < PL_bufend && isSPACE(*t))
5898 if (*t == '/' || *t == '?' ||
5899 ((*t == 'm' || *t == 's' || *t == 'y')
5900 && !isWORDCHAR(t[1])) ||
5901 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5902 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5903 "!=~ should be !~");
5905 if (!PL_lex_allbrackets &&
5906 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5918 if (PL_expect != XOPERATOR) {
5919 if (s[1] != '<' && !strchr(s,'>'))
5921 if (s[1] == '<' && s[2] != '>')
5922 s = scan_heredoc(s);
5924 s = scan_inputsymbol(s);
5925 PL_expect = XOPERATOR;
5926 TOKEN(sublex_start());
5932 if (*s == '=' && !PL_lex_allbrackets &&
5933 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5937 SHop(OP_LEFT_SHIFT);
5942 if (!PL_lex_allbrackets &&
5943 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5950 if (!PL_lex_allbrackets &&
5951 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5959 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5967 const char tmp = *s++;
5969 if (*s == '=' && !PL_lex_allbrackets &&
5970 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5974 SHop(OP_RIGHT_SHIFT);
5976 else if (tmp == '=') {
5977 if (!PL_lex_allbrackets &&
5978 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5986 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5995 if (PL_expect == XOPERATOR) {
5996 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5997 return deprecate_commaless_var_list();
6000 else if (PL_expect == XPOSTDEREF) {
6003 POSTDEREF(DOLSHARP);
6008 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6009 PL_tokenbuf[0] = '@';
6010 s = scan_ident(s + 1, PL_tokenbuf + 1,
6011 sizeof PL_tokenbuf - 1, FALSE);
6012 if (PL_expect == XOPERATOR)
6013 no_op("Array length", s);
6014 if (!PL_tokenbuf[1])
6016 PL_expect = XOPERATOR;
6017 force_ident_maybe_lex('#');
6021 PL_tokenbuf[0] = '$';
6022 s = scan_ident(s, PL_tokenbuf + 1,
6023 sizeof PL_tokenbuf - 1, FALSE);
6024 if (PL_expect == XOPERATOR) {
6026 if (PL_bufptr > s) {
6028 PL_bufptr = PL_oldbufptr;
6032 if (!PL_tokenbuf[1]) {
6034 yyerror("Final $ should be \\$ or $name");
6040 const char tmp = *s;
6041 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6044 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6045 && intuit_more(s)) {
6047 PL_tokenbuf[0] = '@';
6048 if (ckWARN(WARN_SYNTAX)) {
6051 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6052 t += UTF ? UTF8SKIP(t) : 1;
6054 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6055 while (t < PL_bufend && *t != ']')
6057 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6058 "Multidimensional syntax %.*s not supported",
6059 (int)((t - PL_bufptr) + 1), PL_bufptr);
6063 else if (*s == '{') {
6065 PL_tokenbuf[0] = '%';
6066 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6067 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6069 char tmpbuf[sizeof PL_tokenbuf];
6072 } while (isSPACE(*t));
6073 if (isIDFIRST_lazy_if(t,UTF)) {
6075 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6080 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6082 "You need to quote \"%"UTF8f"\"",
6083 UTF8fARG(UTF, len, tmpbuf));
6089 PL_expect = XOPERATOR;
6090 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6091 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6092 if (!islop || PL_last_lop_op == OP_GREPSTART)
6093 PL_expect = XOPERATOR;
6094 else if (strchr("$@\"'`q", *s))
6095 PL_expect = XTERM; /* e.g. print $fh "foo" */
6096 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6097 PL_expect = XTERM; /* e.g. print $fh &sub */
6098 else if (isIDFIRST_lazy_if(s,UTF)) {
6099 char tmpbuf[sizeof PL_tokenbuf];
6101 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6102 if ((t2 = keyword(tmpbuf, len, 0))) {
6103 /* binary operators exclude handle interpretations */
6115 PL_expect = XTERM; /* e.g. print $fh length() */
6120 PL_expect = XTERM; /* e.g. print $fh subr() */
6123 else if (isDIGIT(*s))
6124 PL_expect = XTERM; /* e.g. print $fh 3 */
6125 else if (*s == '.' && isDIGIT(s[1]))
6126 PL_expect = XTERM; /* e.g. print $fh .3 */
6127 else if ((*s == '?' || *s == '-' || *s == '+')
6128 && !isSPACE(s[1]) && s[1] != '=')
6129 PL_expect = XTERM; /* e.g. print $fh -1 */
6130 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6132 PL_expect = XTERM; /* e.g. print $fh /.../
6133 XXX except DORDOR operator
6135 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6137 PL_expect = XTERM; /* print $fh <<"EOF" */
6140 force_ident_maybe_lex('$');
6144 if (PL_expect == XOPERATOR)
6146 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6147 PL_tokenbuf[0] = '@';
6148 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6150 if (!PL_tokenbuf[1]) {
6153 if (PL_lex_state == LEX_NORMAL)
6155 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6157 PL_tokenbuf[0] = '%';
6159 /* Warn about @ where they meant $. */
6160 if (*s == '[' || *s == '{') {
6161 if (ckWARN(WARN_SYNTAX)) {
6162 S_check_scalar_slice(aTHX_ s);
6166 PL_expect = XOPERATOR;
6167 force_ident_maybe_lex('@');
6170 case '/': /* may be division, defined-or, or pattern */
6171 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6172 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6173 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6178 else if (PL_expect == XOPERATOR) {
6180 if (*s == '=' && !PL_lex_allbrackets &&
6181 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6188 /* Disable warning on "study /blah/" */
6189 if (PL_oldoldbufptr == PL_last_uni
6190 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6191 || memNE(PL_last_uni, "study", 5)
6192 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6195 s = scan_pat(s,OP_MATCH);
6196 TERM(sublex_start());
6199 case '?': /* conditional */
6201 if (!PL_lex_allbrackets &&
6202 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6206 PL_lex_allbrackets++;
6210 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6211 #ifdef PERL_STRICT_CR
6214 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6216 && (s == PL_linestart || s[-1] == '\n') )
6219 formbrack = 2; /* dot seen where arguments expected */
6222 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6226 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6229 if (!PL_lex_allbrackets &&
6230 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6237 pl_yylval.ival = OPf_SPECIAL;
6243 if (*s == '=' && !PL_lex_allbrackets &&
6244 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6251 case '0': case '1': case '2': case '3': case '4':
6252 case '5': case '6': case '7': case '8': case '9':
6253 s = scan_num(s, &pl_yylval);
6254 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6255 if (PL_expect == XOPERATOR)
6260 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6263 COPLINE_SET_FROM_MULTI_END;
6264 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6265 if (PL_expect == XOPERATOR) {
6266 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6267 return deprecate_commaless_var_list();
6272 pl_yylval.ival = OP_CONST;
6273 TERM(sublex_start());
6276 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6279 printbuf("### Saw string before %s\n", s);
6281 PerlIO_printf(Perl_debug_log,
6282 "### Saw unterminated string\n");
6284 if (PL_expect == XOPERATOR) {
6285 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6286 return deprecate_commaless_var_list();
6293 pl_yylval.ival = OP_CONST;
6294 /* FIXME. I think that this can be const if char *d is replaced by
6295 more localised variables. */
6296 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6297 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6298 pl_yylval.ival = OP_STRINGIFY;
6302 if (pl_yylval.ival == OP_CONST)
6303 COPLINE_SET_FROM_MULTI_END;
6304 TERM(sublex_start());
6307 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6308 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6309 if (PL_expect == XOPERATOR)
6310 no_op("Backticks",s);
6313 pl_yylval.ival = OP_BACKTICK;
6314 TERM(sublex_start());
6318 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6320 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6322 if (PL_expect == XOPERATOR)
6323 no_op("Backslash",s);
6327 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6328 char *start = s + 2;
6329 while (isDIGIT(*start) || *start == '_')
6331 if (*start == '.' && isDIGIT(start[1])) {
6332 s = scan_num(s, &pl_yylval);
6335 else if ((*start == ':' && start[1] == ':')
6336 || (PL_expect == XSTATE && *start == ':'))
6338 else if (PL_expect == XSTATE) {
6340 while (d < PL_bufend && isSPACE(*d)) d++;
6341 if (*d == ':') goto keylookup;
6343 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6344 if (!isALPHA(*start) && (PL_expect == XTERM
6345 || PL_expect == XREF || PL_expect == XSTATE
6346 || PL_expect == XTERMORDORDOR)) {
6347 GV *const gv = gv_fetchpvn_flags(s, start - s,
6348 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6350 s = scan_num(s, &pl_yylval);
6357 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6410 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6412 /* Some keywords can be followed by any delimiter, including ':' */
6413 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6415 /* x::* is just a word, unless x is "CORE" */
6416 if (!anydelim && *s == ':' && s[1] == ':') {
6417 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6422 while (d < PL_bufend && isSPACE(*d))
6423 d++; /* no comments skipped here, or s### is misparsed */
6425 /* Is this a word before a => operator? */
6426 if (*d == '=' && d[1] == '>') {
6430 = (OP*)newSVOP(OP_CONST, 0,
6431 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6432 pl_yylval.opval->op_private = OPpCONST_BARE;
6436 /* Check for plugged-in keyword */
6440 char *saved_bufptr = PL_bufptr;
6442 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6444 if (result == KEYWORD_PLUGIN_DECLINE) {
6445 /* not a plugged-in keyword */
6446 PL_bufptr = saved_bufptr;
6447 } else if (result == KEYWORD_PLUGIN_STMT) {
6448 pl_yylval.opval = o;
6450 if (!PL_nexttoke) PL_expect = XSTATE;
6451 return REPORT(PLUGSTMT);
6452 } else if (result == KEYWORD_PLUGIN_EXPR) {
6453 pl_yylval.opval = o;
6455 if (!PL_nexttoke) PL_expect = XOPERATOR;
6456 return REPORT(PLUGEXPR);
6458 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6463 /* Check for built-in keyword */
6464 tmp = keyword(PL_tokenbuf, len, 0);
6466 /* Is this a label? */
6467 if (!anydelim && PL_expect == XSTATE
6468 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6470 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6471 pl_yylval.pval[len] = '\0';
6472 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6477 /* Check for lexical sub */
6478 if (PL_expect != XOPERATOR) {
6479 char tmpbuf[sizeof PL_tokenbuf + 1];
6481 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6482 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6483 if (off != NOT_IN_PAD) {
6484 assert(off); /* we assume this is boolean-true below */
6485 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6486 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6487 HEK * const stashname = HvNAME_HEK(stash);
6488 sv = newSVhek(stashname);
6489 sv_catpvs(sv, "::");
6490 sv_catpvn_flags(sv, PL_tokenbuf, len,
6491 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6492 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6502 rv2cv_op = newOP(OP_PADANY, 0);
6503 rv2cv_op->op_targ = off;
6504 cv = find_lexical_cv(off);
6512 if (tmp < 0) { /* second-class keyword? */
6513 GV *ogv = NULL; /* override (winner) */
6514 GV *hgv = NULL; /* hidden (loser) */
6515 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6517 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6518 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6522 if (GvIMPORTED_CV(gv))
6524 else if (! CvMETHOD(cv))
6528 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6532 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6533 : SvPCS_IMPORTED(gv)
6534 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6543 tmp = 0; /* overridden by import or by GLOBAL */
6546 && -tmp==KEY_lock /* XXX generalizable kludge */
6549 tmp = 0; /* any sub overrides "weak" keyword */
6551 else { /* no override */
6553 if (tmp == KEY_dump) {
6554 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6555 "dump() better written as CORE::dump()");
6559 if (hgv && tmp != KEY_x) /* never ambiguous */
6560 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6561 "Ambiguous call resolved as CORE::%s(), "
6562 "qualify as such or use &",
6567 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6568 && (!anydelim || *s != '#')) {
6569 /* no override, and not s### either; skipspace is safe here
6570 * check for => on following line */
6572 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6573 STRLEN soff = s - SvPVX(PL_linestr);
6574 s = skipspace_flags(s, LEX_NO_INCLINE);
6575 arrow = *s == '=' && s[1] == '>';
6576 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6577 s = SvPVX(PL_linestr) + soff;
6585 default: /* not a keyword */
6586 /* Trade off - by using this evil construction we can pull the
6587 variable gv into the block labelled keylookup. If not, then
6588 we have to give it function scope so that the goto from the
6589 earlier ':' case doesn't bypass the initialisation. */
6591 just_a_word_zero_gv:
6603 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6607 /* Get the rest if it looks like a package qualifier */
6609 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6611 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6614 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6615 UTF8fARG(UTF, len, PL_tokenbuf),
6616 *s == '\'' ? "'" : "::");
6621 if (PL_expect == XOPERATOR) {
6622 if (PL_bufptr == PL_linestart) {
6623 CopLINE_dec(PL_curcop);
6624 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6625 CopLINE_inc(PL_curcop);
6628 no_op("Bareword",s);
6631 /* See if the name is "Foo::",
6632 in which case Foo is a bareword
6633 (and a package name). */
6636 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6638 if (ckWARN(WARN_BAREWORD)
6639 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6640 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6641 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6642 UTF8fARG(UTF, len, PL_tokenbuf));
6644 PL_tokenbuf[len] = '\0';
6653 /* if we saw a global override before, get the right name */
6656 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6659 SV * const tmp_sv = sv;
6660 sv = newSVpvs("CORE::GLOBAL::");
6661 sv_catsv(sv, tmp_sv);
6662 SvREFCNT_dec(tmp_sv);
6666 /* Presume this is going to be a bareword of some sort. */
6668 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6669 pl_yylval.opval->op_private = OPpCONST_BARE;
6671 /* And if "Foo::", then that's what it certainly is. */
6677 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6678 const_op->op_private = OPpCONST_BARE;
6680 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6684 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6687 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6690 /* Use this var to track whether intuit_method has been
6691 called. intuit_method returns 0 or > 255. */
6694 /* See if it's the indirect object for a list operator. */
6696 if (PL_oldoldbufptr &&
6697 PL_oldoldbufptr < PL_bufptr &&
6698 (PL_oldoldbufptr == PL_last_lop
6699 || PL_oldoldbufptr == PL_last_uni) &&
6700 /* NO SKIPSPACE BEFORE HERE! */
6701 (PL_expect == XREF ||
6702 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6704 bool immediate_paren = *s == '(';
6706 /* (Now we can afford to cross potential line boundary.) */
6709 /* Two barewords in a row may indicate method call. */
6711 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6712 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6716 /* If not a declared subroutine, it's an indirect object. */
6717 /* (But it's an indir obj regardless for sort.) */
6718 /* Also, if "_" follows a filetest operator, it's a bareword */
6721 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6723 (PL_last_lop_op != OP_MAPSTART &&
6724 PL_last_lop_op != OP_GREPSTART))))
6725 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6726 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6729 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6734 PL_expect = XOPERATOR;
6737 /* Is this a word before a => operator? */
6738 if (*s == '=' && s[1] == '>' && !pkgname) {
6741 if (gvp || (lex && !off)) {
6742 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6743 /* This is our own scalar, created a few lines
6744 above, so this is safe. */
6746 sv_setpv(sv, PL_tokenbuf);
6747 if (UTF && !IN_BYTES
6748 && is_utf8_string((U8*)PL_tokenbuf, len))
6755 /* If followed by a paren, it's certainly a subroutine. */
6760 while (SPACE_OR_TAB(*d))
6762 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6767 NEXTVAL_NEXTTOKE.opval =
6768 off ? rv2cv_op : pl_yylval.opval;
6770 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6771 else op_free(rv2cv_op), force_next(WORD);
6776 /* If followed by var or block, call it a method (unless sub) */
6778 if ((*s == '$' || *s == '{') && !cv) {
6780 PL_last_lop = PL_oldbufptr;
6781 PL_last_lop_op = OP_METHOD;
6782 if (!PL_lex_allbrackets &&
6783 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6784 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6785 PL_expect = XBLOCKTERM;
6787 return REPORT(METHOD);
6790 /* If followed by a bareword, see if it looks like indir obj. */
6792 if (tmp == 1 && !orig_keyword
6793 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6794 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6797 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6799 sv_setpvn(sv, PL_tokenbuf, len);
6800 if (UTF && !IN_BYTES
6801 && is_utf8_string((U8*)PL_tokenbuf, len))
6803 else SvUTF8_off(sv);
6806 if (tmp == METHOD && !PL_lex_allbrackets &&
6807 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6808 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6812 /* Not a method, so call it a subroutine (if defined) */
6815 /* Check for a constant sub */
6816 if ((sv = cv_const_sv_or_av(cv))) {
6819 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6820 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6821 if (SvTYPE(sv) == SVt_PVAV)
6822 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6825 pl_yylval.opval->op_private = 0;
6826 pl_yylval.opval->op_folded = 1;
6827 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6832 op_free(pl_yylval.opval);
6834 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6835 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6836 PL_last_lop = PL_oldbufptr;
6837 PL_last_lop_op = OP_ENTERSUB;
6838 /* Is there a prototype? */
6842 STRLEN protolen = CvPROTOLEN(cv);
6843 const char *proto = CvPROTO(cv);
6845 proto = S_strip_spaces(aTHX_ proto, &protolen);
6848 if ((optional = *proto == ';'))
6851 while (*proto == ';');
6855 *proto == '$' || *proto == '_'
6856 || *proto == '*' || *proto == '+'
6861 *proto == '\\' && proto[1] && proto[2] == '\0'
6864 UNIPROTO(UNIOPSUB,optional);
6865 if (*proto == '\\' && proto[1] == '[') {
6866 const char *p = proto + 2;
6867 while(*p && *p != ']')
6869 if(*p == ']' && !p[1])
6870 UNIPROTO(UNIOPSUB,optional);
6872 if (*proto == '&' && *s == '{') {
6874 sv_setpvs(PL_subname, "__ANON__");
6876 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6877 if (!PL_lex_allbrackets &&
6878 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6879 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6883 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6885 force_next(off ? PRIVATEREF : WORD);
6886 if (!PL_lex_allbrackets &&
6887 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6888 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6892 /* Call it a bare word */
6894 if (PL_hints & HINT_STRICT_SUBS)
6895 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6898 /* after "print" and similar functions (corresponding to
6899 * "F? L" in opcode.pl), whatever wasn't already parsed as
6900 * a filehandle should be subject to "strict subs".
6901 * Likewise for the optional indirect-object argument to system
6902 * or exec, which can't be a bareword */
6903 if ((PL_last_lop_op == OP_PRINT
6904 || PL_last_lop_op == OP_PRTF
6905 || PL_last_lop_op == OP_SAY
6906 || PL_last_lop_op == OP_SYSTEM
6907 || PL_last_lop_op == OP_EXEC)
6908 && (PL_hints & HINT_STRICT_SUBS))
6909 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6910 if (lastchar != '-') {
6911 if (ckWARN(WARN_RESERVED)) {
6915 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6917 /* PL_warn_reserved is constant */
6918 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6919 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6929 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6930 && saw_infix_sigil) {
6931 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6932 "Operator or semicolon missing before %c%"UTF8f,
6934 UTF8fARG(UTF, strlen(PL_tokenbuf),
6936 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6937 "Ambiguous use of %c resolved as operator %c",
6938 lastchar, lastchar);
6945 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6950 (OP*)newSVOP(OP_CONST, 0,
6951 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6954 case KEY___PACKAGE__:
6956 (OP*)newSVOP(OP_CONST, 0,
6958 ? newSVhek(HvNAME_HEK(PL_curstash))
6965 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6966 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6969 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6971 gv_init(gv,stash,"DATA",4,0);
6974 GvIOp(gv) = newIO();
6975 IoIFP(GvIOp(gv)) = PL_rsfp;
6976 #if defined(HAS_FCNTL) && defined(F_SETFD)
6978 const int fd = PerlIO_fileno(PL_rsfp);
6979 fcntl(fd,F_SETFD,fd >= 3);
6982 /* Mark this internal pseudo-handle as clean */
6983 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6984 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6985 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6987 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6988 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6989 /* if the script was opened in binmode, we need to revert
6990 * it to text mode for compatibility; but only iff it has CRs
6991 * XXX this is a questionable hack at best. */
6992 if (PL_bufend-PL_bufptr > 2
6993 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6996 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6997 loc = PerlIO_tell(PL_rsfp);
6998 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7001 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7003 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7004 #endif /* NETWARE */
7006 PerlIO_seek(PL_rsfp, loc, 0);
7010 #ifdef PERLIO_LAYERS
7013 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7014 else if (IN_ENCODING) {
7020 XPUSHs(_get_encoding());
7022 call_method("name", G_SCALAR);
7026 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7027 Perl_form(aTHX_ ":encoding(%"SVf")",
7040 FUN0OP(CvCLONE(PL_compcv)
7041 ? newOP(OP_RUNCV, 0)
7042 : newPVOP(OP_RUNCV,0,NULL));
7051 if (PL_expect == XSTATE) {
7062 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7063 if ((*s == ':' && s[1] == ':')
7064 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7068 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7072 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7073 UTF8fARG(UTF, len, PL_tokenbuf));
7076 else if (tmp == KEY_require || tmp == KEY_do
7078 /* that's a way to remember we saw "CORE::" */
7090 LOP(OP_ACCEPT,XTERM);
7093 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7098 LOP(OP_ATAN2,XTERM);
7104 LOP(OP_BINMODE,XTERM);
7107 LOP(OP_BLESS,XTERM);
7116 /* We have to disambiguate the two senses of
7117 "continue". If the next token is a '{' then
7118 treat it as the start of a continue block;
7119 otherwise treat it as a control operator.
7129 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7139 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7148 if (!PL_cryptseen) {
7149 PL_cryptseen = TRUE;
7153 LOP(OP_CRYPT,XTERM);
7156 LOP(OP_CHMOD,XTERM);
7159 LOP(OP_CHOWN,XTERM);
7162 LOP(OP_CONNECT,XTERM);
7182 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7184 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7185 && !keyword(PL_tokenbuf + 1, len, 0)) {
7188 force_ident_maybe_lex('&');
7193 if (orig_keyword == KEY_do) {
7202 PL_hints |= HINT_BLOCK_SCOPE;
7212 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7213 STR_WITH_LEN("NDBM_File::"),
7214 STR_WITH_LEN("DB_File::"),
7215 STR_WITH_LEN("GDBM_File::"),
7216 STR_WITH_LEN("SDBM_File::"),
7217 STR_WITH_LEN("ODBM_File::"),
7219 LOP(OP_DBMOPEN,XTERM);
7231 pl_yylval.ival = CopLINE(PL_curcop);
7235 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7247 if (*s == '{') { /* block eval */
7248 PL_expect = XTERMBLOCK;
7249 UNIBRACK(OP_ENTERTRY);
7251 else { /* string eval */
7253 UNIBRACK(OP_ENTEREVAL);
7258 UNIBRACK(-OP_ENTEREVAL);
7272 case KEY_endhostent:
7278 case KEY_endservent:
7281 case KEY_endprotoent:
7292 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7294 pl_yylval.ival = CopLINE(PL_curcop);
7296 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7299 if ((PL_bufend - p) >= 3 &&
7300 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7302 else if ((PL_bufend - p) >= 4 &&
7303 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7306 /* skip optional package name, as in "for my abc $x (..)" */
7307 if (isIDFIRST_lazy_if(p,UTF)) {
7308 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7312 Perl_croak(aTHX_ "Missing $ on loop variable");
7317 LOP(OP_FORMLINE,XTERM);
7326 LOP(OP_FCNTL,XTERM);
7332 LOP(OP_FLOCK,XTERM);
7335 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7340 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7345 LOP(OP_GREPSTART, XREF);
7362 case KEY_getpriority:
7363 LOP(OP_GETPRIORITY,XTERM);
7365 case KEY_getprotobyname:
7368 case KEY_getprotobynumber:
7369 LOP(OP_GPBYNUMBER,XTERM);
7371 case KEY_getprotoent:
7383 case KEY_getpeername:
7384 UNI(OP_GETPEERNAME);
7386 case KEY_gethostbyname:
7389 case KEY_gethostbyaddr:
7390 LOP(OP_GHBYADDR,XTERM);
7392 case KEY_gethostent:
7395 case KEY_getnetbyname:
7398 case KEY_getnetbyaddr:
7399 LOP(OP_GNBYADDR,XTERM);
7404 case KEY_getservbyname:
7405 LOP(OP_GSBYNAME,XTERM);
7407 case KEY_getservbyport:
7408 LOP(OP_GSBYPORT,XTERM);
7410 case KEY_getservent:
7413 case KEY_getsockname:
7414 UNI(OP_GETSOCKNAME);
7416 case KEY_getsockopt:
7417 LOP(OP_GSOCKOPT,XTERM);
7432 pl_yylval.ival = CopLINE(PL_curcop);
7433 Perl_ck_warner_d(aTHX_
7434 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7435 "given is experimental");
7440 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7448 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7450 pl_yylval.ival = CopLINE(PL_curcop);
7454 LOP(OP_INDEX,XTERM);
7460 LOP(OP_IOCTL,XTERM);
7488 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7493 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7507 LOP(OP_LISTEN,XTERM);
7516 s = scan_pat(s,OP_MATCH);
7517 TERM(sublex_start());
7520 LOP(OP_MAPSTART, XREF);
7523 LOP(OP_MKDIR,XTERM);
7526 LOP(OP_MSGCTL,XTERM);
7529 LOP(OP_MSGGET,XTERM);
7532 LOP(OP_MSGRCV,XTERM);
7535 LOP(OP_MSGSND,XTERM);
7540 PL_in_my = (U16)tmp;
7542 if (isIDFIRST_lazy_if(s,UTF)) {
7543 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7544 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7546 if (!FEATURE_LEXSUBS_IS_ENABLED)
7548 "Experimental \"%s\" subs not enabled",
7549 tmp == KEY_my ? "my" :
7550 tmp == KEY_state ? "state" : "our");
7551 Perl_ck_warner_d(aTHX_
7552 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7553 "The lexical_subs feature is experimental");
7556 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7557 if (!PL_in_my_stash) {
7561 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7562 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7563 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7573 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7578 s = tokenize_use(0, s);
7582 if (*s == '(' || (s = skipspace(s), *s == '('))
7585 if (!PL_lex_allbrackets &&
7586 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7587 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7593 if (isIDFIRST_lazy_if(s,UTF)) {
7595 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7597 for (t=d; isSPACE(*t);)
7599 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7601 && !(t[0] == '=' && t[1] == '>')
7602 && !(t[0] == ':' && t[1] == ':')
7603 && !keyword(s, d-s, 0)
7605 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7606 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7607 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7613 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7615 pl_yylval.ival = OP_OR;
7625 LOP(OP_OPEN_DIR,XTERM);
7628 checkcomma(s,PL_tokenbuf,"filehandle");
7632 checkcomma(s,PL_tokenbuf,"filehandle");
7651 s = force_word(s,WORD,FALSE,TRUE);
7653 s = force_strict_version(s);
7657 LOP(OP_PIPE_OP,XTERM);
7660 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7663 COPLINE_SET_FROM_MULTI_END;
7664 pl_yylval.ival = OP_CONST;
7665 TERM(sublex_start());
7672 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7675 COPLINE_SET_FROM_MULTI_END;
7676 PL_expect = XOPERATOR;
7677 if (SvCUR(PL_lex_stuff)) {
7678 int warned_comma = !ckWARN(WARN_QW);
7679 int warned_comment = warned_comma;
7680 d = SvPV_force(PL_lex_stuff, len);
7682 for (; isSPACE(*d) && len; --len, ++d)
7687 if (!warned_comma || !warned_comment) {
7688 for (; !isSPACE(*d) && len; --len, ++d) {
7689 if (!warned_comma && *d == ',') {
7690 Perl_warner(aTHX_ packWARN(WARN_QW),
7691 "Possible attempt to separate words with commas");
7694 else if (!warned_comment && *d == '#') {
7695 Perl_warner(aTHX_ packWARN(WARN_QW),
7696 "Possible attempt to put comments in qw() list");
7702 for (; !isSPACE(*d) && len; --len, ++d)
7705 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7706 words = op_append_elem(OP_LIST, words,
7707 newSVOP(OP_CONST, 0, tokeq(sv)));
7712 words = newNULLLIST();
7713 SvREFCNT_dec_NN(PL_lex_stuff);
7714 PL_lex_stuff = NULL;
7715 PL_expect = XOPERATOR;
7716 pl_yylval.opval = sawparens(words);
7721 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7724 pl_yylval.ival = OP_STRINGIFY;
7725 if (SvIVX(PL_lex_stuff) == '\'')
7726 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7727 TERM(sublex_start());
7730 s = scan_pat(s,OP_QR);
7731 TERM(sublex_start());
7734 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7737 pl_yylval.ival = OP_BACKTICK;
7738 TERM(sublex_start());
7746 s = force_version(s, FALSE);
7748 else if (*s != 'v' || !isDIGIT(s[1])
7749 || (s = force_version(s, TRUE), *s == 'v'))
7751 *PL_tokenbuf = '\0';
7752 s = force_word(s,WORD,TRUE,TRUE);
7753 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7754 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7755 GV_ADD | (UTF ? SVf_UTF8 : 0));
7757 yyerror("<> at require-statement should be quotes");
7759 if (orig_keyword == KEY_require) {
7765 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7767 PL_last_uni = PL_oldbufptr;
7768 PL_last_lop_op = OP_REQUIRE;
7770 return REPORT( (int)REQUIRE );
7779 LOP(OP_RENAME,XTERM);
7788 LOP(OP_RINDEX,XTERM);
7797 UNIDOR(OP_READLINE);
7800 UNIDOR(OP_BACKTICK);
7809 LOP(OP_REVERSE,XTERM);
7812 UNIDOR(OP_READLINK);
7819 if (pl_yylval.opval)
7820 TERM(sublex_start());
7822 TOKEN(1); /* force error */
7825 checkcomma(s,PL_tokenbuf,"filehandle");
7835 LOP(OP_SELECT,XTERM);
7841 LOP(OP_SEMCTL,XTERM);
7844 LOP(OP_SEMGET,XTERM);
7847 LOP(OP_SEMOP,XTERM);
7853 LOP(OP_SETPGRP,XTERM);
7855 case KEY_setpriority:
7856 LOP(OP_SETPRIORITY,XTERM);
7858 case KEY_sethostent:
7864 case KEY_setservent:
7867 case KEY_setprotoent:
7877 LOP(OP_SEEKDIR,XTERM);
7879 case KEY_setsockopt:
7880 LOP(OP_SSOCKOPT,XTERM);
7886 LOP(OP_SHMCTL,XTERM);
7889 LOP(OP_SHMGET,XTERM);
7892 LOP(OP_SHMREAD,XTERM);
7895 LOP(OP_SHMWRITE,XTERM);
7898 LOP(OP_SHUTDOWN,XTERM);
7907 LOP(OP_SOCKET,XTERM);
7909 case KEY_socketpair:
7910 LOP(OP_SOCKPAIR,XTERM);
7913 checkcomma(s,PL_tokenbuf,"subroutine name");
7916 s = force_word(s,WORD,TRUE,TRUE);
7920 LOP(OP_SPLIT,XTERM);
7923 LOP(OP_SPRINTF,XTERM);
7926 LOP(OP_SPLICE,XTERM);
7941 LOP(OP_SUBSTR,XTERM);
7947 char * const tmpbuf = PL_tokenbuf + 1;
7948 expectation attrful;
7949 bool have_name, have_proto;
7950 const int key = tmp;
7951 SV *format_name = NULL;
7956 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7957 (*s == ':' && s[1] == ':'))
7961 attrful = XATTRBLOCK;
7962 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7964 if (key == KEY_format)
7965 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7967 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7969 PL_tokenbuf, len + 1, 0
7971 sv_setpvn(PL_subname, tmpbuf, len);
7973 sv_setsv(PL_subname,PL_curstname);
7974 sv_catpvs(PL_subname,"::");
7975 sv_catpvn(PL_subname,tmpbuf,len);
7977 if (SvUTF8(PL_linestr))
7978 SvUTF8_on(PL_subname);
7985 if (key == KEY_my || key == KEY_our || key==KEY_state)
7988 /* diag_listed_as: Missing name in "%s sub" */
7990 "Missing name in \"%s\"", PL_bufptr);
7992 PL_expect = XTERMBLOCK;
7993 attrful = XATTRTERM;
7994 sv_setpvs(PL_subname,"?");
7998 if (key == KEY_format) {
8000 NEXTVAL_NEXTTOKE.opval
8001 = (OP*)newSVOP(OP_CONST,0, format_name);
8002 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8008 /* Look for a prototype */
8009 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8010 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8011 COPLINE_SET_FROM_MULTI_END;
8013 Perl_croak(aTHX_ "Prototype not terminated");
8014 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8022 if (*s == ':' && s[1] != ':')
8023 PL_expect = attrful;
8024 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
8026 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8027 else if (*s != ';' && *s != '}')
8028 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8032 NEXTVAL_NEXTTOKE.opval =
8033 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8034 PL_lex_stuff = NULL;
8039 sv_setpvs(PL_subname, "__ANON__");
8041 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8044 force_ident_maybe_lex('&');
8049 LOP(OP_SYSTEM,XREF);
8052 LOP(OP_SYMLINK,XTERM);
8055 LOP(OP_SYSCALL,XTERM);
8058 LOP(OP_SYSOPEN,XTERM);
8061 LOP(OP_SYSSEEK,XTERM);
8064 LOP(OP_SYSREAD,XTERM);
8067 LOP(OP_SYSWRITE,XTERM);
8072 TERM(sublex_start());
8093 LOP(OP_TRUNCATE,XTERM);
8105 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8107 pl_yylval.ival = CopLINE(PL_curcop);
8111 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8113 pl_yylval.ival = CopLINE(PL_curcop);
8117 LOP(OP_UNLINK,XTERM);
8123 LOP(OP_UNPACK,XTERM);
8126 LOP(OP_UTIME,XTERM);
8132 LOP(OP_UNSHIFT,XTERM);
8135 s = tokenize_use(1, s);
8145 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8147 pl_yylval.ival = CopLINE(PL_curcop);
8148 Perl_ck_warner_d(aTHX_
8149 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8150 "when is experimental");
8154 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8156 pl_yylval.ival = CopLINE(PL_curcop);
8160 PL_hints |= HINT_BLOCK_SCOPE;
8167 LOP(OP_WAITPID,XTERM);
8173 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8174 * we use the same number on EBCDIC */
8175 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8179 if (PL_expect == XOPERATOR) {
8180 if (*s == '=' && !PL_lex_allbrackets &&
8181 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8189 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8191 pl_yylval.ival = OP_XOR;
8200 Looks up an identifier in the pad or in a package
8203 PRIVATEREF if this is a lexical name.
8204 WORD if this belongs to a package.
8207 if we're in a my declaration
8208 croak if they tried to say my($foo::bar)
8209 build the ops for a my() declaration
8210 if it's an access to a my() variable
8211 build ops for access to a my() variable
8212 if in a dq string, and they've said @foo and we can't find @foo
8214 build ops for a bareword
8218 S_pending_ident(pTHX)
8221 const char pit = (char)pl_yylval.ival;
8222 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8223 /* All routes through this function want to know if there is a colon. */
8224 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8226 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8227 "### Pending identifier '%s'\n", PL_tokenbuf); });
8229 /* if we're in a my(), we can't allow dynamics here.
8230 $foo'bar has already been turned into $foo::bar, so
8231 just check for colons.
8233 if it's a legal name, the OP is a PADANY.
8236 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8238 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8239 "variable %s in \"our\"",
8240 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8241 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8245 /* "my" variable %s can't be in a package */
8246 /* PL_no_myglob is constant */
8247 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8248 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8249 PL_in_my == KEY_my ? "my" : "state",
8250 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8252 UTF ? SVf_UTF8 : 0);
8256 pl_yylval.opval = newOP(OP_PADANY, 0);
8257 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8258 UTF ? SVf_UTF8 : 0);
8264 build the ops for accesses to a my() variable.
8269 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8271 if (tmp != NOT_IN_PAD) {
8272 /* might be an "our" variable" */
8273 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8274 /* build ops for a bareword */
8275 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8276 HEK * const stashname = HvNAME_HEK(stash);
8277 SV * const sym = newSVhek(stashname);
8278 sv_catpvs(sym, "::");
8279 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8280 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8281 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8285 ((PL_tokenbuf[0] == '$') ? SVt_PV
8286 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8291 pl_yylval.opval = newOP(OP_PADANY, 0);
8292 pl_yylval.opval->op_targ = tmp;
8298 Whine if they've said @foo in a doublequoted string,
8299 and @foo isn't a variable we can find in the symbol
8302 if (ckWARN(WARN_AMBIGUOUS) &&
8303 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8304 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8305 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8306 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8307 /* DO NOT warn for @- and @+ */
8308 && !( PL_tokenbuf[2] == '\0' &&
8309 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8312 /* Downgraded from fatal to warning 20000522 mjd */
8313 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8314 "Possible unintended interpolation of %"UTF8f
8316 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8320 /* build ops for a bareword */
8321 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8322 newSVpvn_flags(PL_tokenbuf + 1,
8324 UTF ? SVf_UTF8 : 0 ));
8325 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8327 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8328 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8329 | ( UTF ? SVf_UTF8 : 0 ),
8330 ((PL_tokenbuf[0] == '$') ? SVt_PV
8331 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8337 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8339 PERL_ARGS_ASSERT_CHECKCOMMA;
8341 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8342 if (ckWARN(WARN_SYNTAX)) {
8345 for (w = s+2; *w && level; w++) {
8353 /* the list of chars below is for end of statements or
8354 * block / parens, boolean operators (&&, ||, //) and branch
8355 * constructs (or, and, if, until, unless, while, err, for).
8356 * Not a very solid hack... */
8357 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8359 "%s (...) interpreted as function",name);
8362 while (s < PL_bufend && isSPACE(*s))
8366 while (s < PL_bufend && isSPACE(*s))
8368 if (isIDFIRST_lazy_if(s,UTF)) {
8369 const char * const w = s;
8370 s += UTF ? UTF8SKIP(s) : 1;
8371 while (isWORDCHAR_lazy_if(s,UTF))
8372 s += UTF ? UTF8SKIP(s) : 1;
8373 while (s < PL_bufend && isSPACE(*s))
8378 if (keyword(w, s - w, 0))
8381 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8382 if (gv && GvCVu(gv))
8386 Copy(w, tmpbuf+1, s - w, char);
8388 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8389 if (off != NOT_IN_PAD) return;
8391 Perl_croak(aTHX_ "No comma allowed after %s", what);
8396 /* S_new_constant(): do any overload::constant lookup.
8398 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8399 Best used as sv=new_constant(..., sv, ...).
8400 If s, pv are NULL, calls subroutine with one argument,
8401 and <type> is used with error messages only.
8402 <type> is assumed to be well formed UTF-8 */
8405 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8406 SV *sv, SV *pv, const char *type, STRLEN typelen)
8409 HV * table = GvHV(PL_hintgv); /* ^H */
8414 const char *why1 = "", *why2 = "", *why3 = "";
8416 PERL_ARGS_ASSERT_NEW_CONSTANT;
8417 /* We assume that this is true: */
8418 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8421 /* charnames doesn't work well if there have been errors found */
8422 if (PL_error_count > 0 && *key == 'c')
8424 SvREFCNT_dec_NN(sv);
8425 return &PL_sv_undef;
8428 sv_2mortal(sv); /* Parent created it permanently */
8430 || ! (PL_hints & HINT_LOCALIZE_HH)
8431 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8436 /* Here haven't found what we're looking for. If it is charnames,
8437 * perhaps it needs to be loaded. Try doing that before giving up */
8439 Perl_load_module(aTHX_
8441 newSVpvs("_charnames"),
8442 /* version parameter; no need to specify it, as if
8443 * we get too early a version, will fail anyway,
8444 * not being able to find '_charnames' */
8449 assert(sp == PL_stack_sp);
8450 table = GvHV(PL_hintgv);
8452 && (PL_hints & HINT_LOCALIZE_HH)
8453 && (cvp = hv_fetch(table, key, keylen, FALSE))
8459 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8460 msg = Perl_form(aTHX_
8461 "Constant(%.*s) unknown",
8462 (int)(type ? typelen : len),
8468 why3 = "} is not defined";
8471 msg = Perl_form(aTHX_
8472 /* The +3 is for '\N{'; -4 for that, plus '}' */
8473 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8477 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8478 (int)(type ? typelen : len),
8479 (type ? type: s), why1, why2, why3);
8482 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8483 return SvREFCNT_inc_simple_NN(sv);
8488 pv = newSVpvn_flags(s, len, SVs_TEMP);
8490 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8492 typesv = &PL_sv_undef;
8494 PUSHSTACKi(PERLSI_OVERLOAD);
8506 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8510 /* Check the eval first */
8511 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8513 const char * errstr;
8514 sv_catpvs(errsv, "Propagated");
8515 errstr = SvPV_const(errsv, errlen);
8516 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8518 res = SvREFCNT_inc_simple_NN(sv);
8522 SvREFCNT_inc_simple_void_NN(res);
8531 why1 = "Call to &{$^H{";
8533 why3 = "}} did not return a defined value";
8535 (void)sv_2mortal(sv);
8542 PERL_STATIC_INLINE void
8543 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8544 PERL_ARGS_ASSERT_PARSE_IDENT;
8548 Perl_croak(aTHX_ "%s", ident_too_long);
8549 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8550 /* The UTF-8 case must come first, otherwise things
8551 * like c\N{COMBINING TILDE} would start failing, as the
8552 * isWORDCHAR_A case below would gobble the 'c' up.
8555 char *t = *s + UTF8SKIP(*s);
8556 while (isIDCONT_utf8((U8*)t))
8558 if (*d + (t - *s) > e)
8559 Perl_croak(aTHX_ "%s", ident_too_long);
8560 Copy(*s, *d, t - *s, char);
8564 else if ( isWORDCHAR_A(**s) ) {
8567 } while (isWORDCHAR_A(**s) && *d < e);
8569 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8574 else if (allow_package && **s == ':' && (*s)[1] == ':'
8575 /* Disallow things like Foo::$bar. For the curious, this is
8576 * the code path that triggers the "Bad name after" warning
8577 * when looking for barewords.
8579 && (*s)[2] != '$') {
8589 /* Returns a NUL terminated string, with the length of the string written to
8593 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8596 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8597 bool is_utf8 = cBOOL(UTF);
8599 PERL_ARGS_ASSERT_SCAN_WORD;
8601 parse_ident(&s, &d, e, allow_package, is_utf8);
8608 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8610 I32 herelines = PL_parser->herelines;
8611 SSize_t bracket = -1;
8614 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8615 bool is_utf8 = cBOOL(UTF);
8616 I32 orig_copline = 0, tmp_copline = 0;
8618 PERL_ARGS_ASSERT_SCAN_IDENT;
8620 if (isSPACE(*s) || !*s)
8623 while (isDIGIT(*s)) {
8625 Perl_croak(aTHX_ "%s", ident_too_long);
8630 parse_ident(&s, &d, e, 1, is_utf8);
8635 /* Either a digit variable, or parse_ident() found an identifier
8636 (anything valid as a bareword), so job done and return. */
8637 if (PL_lex_state != LEX_NORMAL)
8638 PL_lex_state = LEX_INTERPENDMAYBE;
8641 if (*s == '$' && s[1] &&
8642 (isIDFIRST_lazy_if(s+1,is_utf8)
8643 || isDIGIT_A((U8)s[1])
8646 || strnEQ(s+1,"::",2)) )
8648 /* Dereferencing a value in a scalar variable.
8649 The alternatives are different syntaxes for a scalar variable.
8650 Using ' as a leading package separator isn't allowed. :: is. */
8653 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8655 bracket = s - SvPVX(PL_linestr);
8657 orig_copline = CopLINE(PL_curcop);
8658 if (s < PL_bufend && isSPACE(*s)) {
8663 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8664 * iff Unicode semantics are to be used. The legal ones are any of:
8665 * a) all ASCII characters except:
8666 * 1) space-type ones, like \t and SPACE;
8669 * The final case currently doesn't get this far in the program, so we
8670 * don't test for it. If that were to change, it would be ok to allow it.
8671 * c) When not under Unicode rules, any upper Latin1 character
8672 * d) Otherwise, when unicode rules are used, all XIDS characters.
8674 * Because all ASCII characters have the same representation whether
8675 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8676 * '{' without knowing if is UTF-8 or not.
8677 * EBCDIC already uses the rules that ASCII platforms will use after the
8678 * deprecation cycle; see comment below about the deprecation. */
8680 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8681 (isGRAPH_A(*(s)) || ((is_utf8) \
8682 ? isIDFIRST_utf8((U8*) (s)) \
8684 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8686 # define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s)) \
8687 && LIKELY(*(s) != '\0') \
8689 || isASCII_utf8((U8*) (s)) \
8690 || isIDFIRST_utf8((U8*) (s))))
8692 if ((s <= PL_bufend - (is_utf8)
8695 && VALID_LEN_ONE_IDENT(s, is_utf8))
8697 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8698 * because often it has no graphic representation. (We can't get to
8699 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8702 ? ! isGRAPH_utf8( (U8*) s)
8703 : (! isGRAPH_L1( (U8) *s)
8704 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8706 /* Split messages for back compat */
8707 if (isCNTRL_A( (U8) *s)) {
8708 deprecate("literal control characters in variable names");
8711 deprecate("literal non-graphic characters in variable names");
8716 const STRLEN skip = UTF8SKIP(s);
8719 for ( i = 0; i < skip; i++ )
8727 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8728 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8732 /* Warn about ambiguous code after unary operators if {...} notation isn't
8733 used. There's no difference in ambiguity; it's merely a heuristic
8734 about when not to warn. */
8735 else if (ck_uni && bracket == -1)
8737 if (bracket != -1) {
8738 /* If we were processing {...} notation then... */
8739 if (isIDFIRST_lazy_if(d,is_utf8)) {
8740 /* if it starts as a valid identifier, assume that it is one.
8741 (the later check for } being at the expected point will trap
8742 cases where this doesn't pan out.) */
8743 d += is_utf8 ? UTF8SKIP(d) : 1;
8744 parse_ident(&s, &d, e, 1, is_utf8);
8746 tmp_copline = CopLINE(PL_curcop);
8747 if (s < PL_bufend && isSPACE(*s)) {
8750 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8751 /* ${foo[0]} and ${foo{bar}} notation. */
8752 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8753 const char * const brack =
8755 ((*s == '[') ? "[...]" : "{...}");
8756 orig_copline = CopLINE(PL_curcop);
8757 CopLINE_set(PL_curcop, tmp_copline);
8758 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8759 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8760 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8761 funny, dest, brack, funny, dest, brack);
8762 CopLINE_set(PL_curcop, orig_copline);
8765 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8766 PL_lex_allbrackets++;
8770 /* Handle extended ${^Foo} variables
8771 * 1999-02-27 mjd-perl-patch@plover.com */
8772 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8776 while (isWORDCHAR(*s) && d < e) {
8780 Perl_croak(aTHX_ "%s", ident_too_long);
8785 tmp_copline = CopLINE(PL_curcop);
8786 if (s < PL_bufend && isSPACE(*s)) {
8790 /* Expect to find a closing } after consuming any trailing whitespace.
8794 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8795 PL_lex_state = LEX_INTERPEND;
8798 if (PL_lex_state == LEX_NORMAL) {
8799 if (ckWARN(WARN_AMBIGUOUS) &&
8800 (keyword(dest, d - dest, 0)
8801 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8803 SV *tmp = newSVpvn_flags( dest, d - dest,
8804 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8807 orig_copline = CopLINE(PL_curcop);
8808 CopLINE_set(PL_curcop, tmp_copline);
8809 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8810 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8811 funny, SVfARG(tmp), funny, SVfARG(tmp));
8812 CopLINE_set(PL_curcop, orig_copline);
8817 /* Didn't find the closing } at the point we expected, so restore
8818 state such that the next thing to process is the opening { and */
8819 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8820 CopLINE_set(PL_curcop, orig_copline);
8821 PL_parser->herelines = herelines;
8825 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8826 PL_lex_state = LEX_INTERPEND;
8831 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8833 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8834 * found in the parse starting at 's', based on the subset that are valid
8835 * in this context input to this routine in 'valid_flags'. Advances s.
8836 * Returns TRUE if the input should be treated as a valid flag, so the next
8837 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8838 * upon first call on the current regex. This routine will set it to any
8839 * charset modifier found. The caller shouldn't change it. This way,
8840 * another charset modifier encountered in the parse can be detected as an
8841 * error, as we have decided to allow only one */
8844 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8846 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8847 if (isWORDCHAR_lazy_if(*s, UTF)) {
8848 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8849 UTF ? SVf_UTF8 : 0);
8851 /* Pretend that it worked, so will continue processing before
8860 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8861 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8862 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8863 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8864 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8865 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8866 case LOCALE_PAT_MOD:
8868 goto multiple_charsets;
8870 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8873 case UNICODE_PAT_MOD:
8875 goto multiple_charsets;
8877 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8880 case ASCII_RESTRICT_PAT_MOD:
8882 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8886 /* Error if previous modifier wasn't an 'a', but if it was, see
8887 * if, and accept, a second occurrence (only) */
8889 || get_regex_charset(*pmfl)
8890 != REGEX_ASCII_RESTRICTED_CHARSET)
8892 goto multiple_charsets;
8894 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8898 case DEPENDS_PAT_MOD:
8900 goto multiple_charsets;
8902 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8911 if (*charset != c) {
8912 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8914 else if (c == 'a') {
8915 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8916 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8919 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8922 /* Pretend that it worked, so will continue processing before dieing */
8928 S_scan_pat(pTHX_ char *start, I32 type)
8932 const char * const valid_flags =
8933 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8934 char charset = '\0'; /* character set modifier */
8935 unsigned int x_mod_count = 0;
8937 PERL_ARGS_ASSERT_SCAN_PAT;
8939 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8941 Perl_croak(aTHX_ "Search pattern not terminated");
8943 pm = (PMOP*)newPMOP(type, 0);
8944 if (PL_multi_open == '?') {
8945 /* This is the only point in the code that sets PMf_ONCE: */
8946 pm->op_pmflags |= PMf_ONCE;
8948 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8949 allows us to restrict the list needed by reset to just the ??
8951 assert(type != OP_TRANS);
8953 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8956 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8959 elements = mg->mg_len / sizeof(PMOP**);
8960 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8961 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8962 mg->mg_len = elements * sizeof(PMOP**);
8963 PmopSTASH_set(pm,PL_curstash);
8967 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8968 * anon CV. False positives like qr/[(?{]/ are harmless */
8970 if (type == OP_QR) {
8972 char *e, *p = SvPV(PL_lex_stuff, len);
8974 for (; p < e; p++) {
8975 if (p[0] == '(' && p[1] == '?'
8976 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8978 pm->op_pmflags |= PMf_HAS_CV;
8982 pm->op_pmflags |= PMf_IS_QR;
8985 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
8986 &s, &charset, &x_mod_count))
8988 /* issue a warning if /c is specified,but /g is not */
8989 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8991 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8992 "Use of /c modifier is meaningless without /g" );
8995 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
8997 PL_lex_op = (OP*)pm;
8998 pl_yylval.ival = OP_MATCH;
9003 S_scan_subst(pTHX_ char *start)
9010 char charset = '\0'; /* character set modifier */
9011 unsigned int x_mod_count = 0;
9014 PERL_ARGS_ASSERT_SCAN_SUBST;
9016 pl_yylval.ival = OP_NULL;
9018 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9021 Perl_croak(aTHX_ "Substitution pattern not terminated");
9025 first_start = PL_multi_start;
9026 first_line = CopLINE(PL_curcop);
9027 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9029 SvREFCNT_dec_NN(PL_lex_stuff);
9030 PL_lex_stuff = NULL;
9031 Perl_croak(aTHX_ "Substitution replacement not terminated");
9033 PL_multi_start = first_start; /* so whole substitution is taken together */
9035 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9039 if (*s == EXEC_PAT_MOD) {
9043 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9044 &s, &charset, &x_mod_count))
9050 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9052 if ((pm->op_pmflags & PMf_CONTINUE)) {
9053 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9057 SV * const repl = newSVpvs("");
9060 pm->op_pmflags |= PMf_EVAL;
9063 sv_catpvs(repl, "eval ");
9065 sv_catpvs(repl, "do ");
9067 sv_catpvs(repl, "{");
9068 sv_catsv(repl, PL_sublex_info.repl);
9069 sv_catpvs(repl, "}");
9071 SvREFCNT_dec(PL_sublex_info.repl);
9072 PL_sublex_info.repl = repl;
9074 if (CopLINE(PL_curcop) != first_line) {
9075 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9076 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9077 CopLINE(PL_curcop) - first_line;
9078 CopLINE_set(PL_curcop, first_line);
9081 PL_lex_op = (OP*)pm;
9082 pl_yylval.ival = OP_SUBST;
9087 S_scan_trans(pTHX_ char *start)
9094 bool nondestruct = 0;
9097 PERL_ARGS_ASSERT_SCAN_TRANS;
9099 pl_yylval.ival = OP_NULL;
9101 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9103 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9107 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9109 SvREFCNT_dec_NN(PL_lex_stuff);
9110 PL_lex_stuff = NULL;
9111 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9114 complement = del = squash = 0;
9118 complement = OPpTRANS_COMPLEMENT;
9121 del = OPpTRANS_DELETE;
9124 squash = OPpTRANS_SQUASH;
9136 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9137 o->op_private &= ~OPpTRANS_ALL;
9138 o->op_private |= del|squash|complement|
9139 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9140 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9143 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9150 Takes a pointer to the first < in <<FOO.
9151 Returns a pointer to the byte following <<FOO.
9153 This function scans a heredoc, which involves different methods
9154 depending on whether we are in a string eval, quoted construct, etc.
9155 This is because PL_linestr could containing a single line of input, or
9156 a whole string being evalled, or the contents of the current quote-
9159 The two basic methods are:
9160 - Steal lines from the input stream
9161 - Scan the heredoc in PL_linestr and remove it therefrom
9163 In a file scope or filtered eval, the first method is used; in a
9164 string eval, the second.
9166 In a quote-like operator, we have to choose between the two,
9167 depending on where we can find a newline. We peek into outer lex-
9168 ing scopes until we find one with a newline in it. If we reach the
9169 outermost lexing scope and it is a file, we use the stream method.
9170 Otherwise it is treated as an eval.
9174 S_scan_heredoc(pTHX_ char *s)
9176 I32 op_type = OP_SCALAR;
9183 const bool infile = PL_rsfp || PL_parser->filtered;
9184 const line_t origline = CopLINE(PL_curcop);
9185 LEXSHARED *shared = PL_parser->lex_shared;
9187 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9190 d = PL_tokenbuf + 1;
9191 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9192 *PL_tokenbuf = '\n';
9194 while (SPACE_OR_TAB(*peek))
9196 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9199 s = delimcpy(d, e, s, PL_bufend, term, &len);
9201 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9207 /* <<\FOO is equivalent to <<'FOO' */
9211 if (!isWORDCHAR_lazy_if(s,UTF))
9212 deprecate("bare << to mean <<\"\"");
9213 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9218 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9219 Perl_croak(aTHX_ "Delimiter for here document is too long");
9222 len = d - PL_tokenbuf;
9224 #ifndef PERL_STRICT_CR
9225 d = strchr(s, '\r');
9227 char * const olds = s;
9229 while (s < PL_bufend) {
9235 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9244 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9249 tmpstr = newSV_type(SVt_PVIV);
9253 SvIV_set(tmpstr, -1);
9255 else if (term == '`') {
9256 op_type = OP_BACKTICK;
9257 SvIV_set(tmpstr, '\\');
9260 PL_multi_start = origline + 1 + PL_parser->herelines;
9261 PL_multi_open = PL_multi_close = '<';
9262 /* inside a string eval or quote-like operator */
9263 if (!infile || PL_lex_inwhat) {
9266 char * const olds = s;
9267 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9268 /* These two fields are not set until an inner lexing scope is
9269 entered. But we need them set here. */
9270 shared->ls_bufptr = s;
9271 shared->ls_linestr = PL_linestr;
9273 /* Look for a newline. If the current buffer does not have one,
9274 peek into the line buffer of the parent lexing scope, going
9275 up as many levels as necessary to find one with a newline
9278 while (!(s = (char *)memchr(
9279 (void *)shared->ls_bufptr, '\n',
9280 SvEND(shared->ls_linestr)-shared->ls_bufptr
9282 shared = shared->ls_prev;
9283 /* shared is only null if we have gone beyond the outermost
9284 lexing scope. In a file, we will have broken out of the
9285 loop in the previous iteration. In an eval, the string buf-
9286 fer ends with "\n;", so the while condition above will have
9287 evaluated to false. So shared can never be null. Or so you
9288 might think. Odd syntax errors like s;@{<<; can gobble up
9289 the implicit semicolon at the end of a flie, causing the
9290 file handle to be closed even when we are not in a string
9291 eval. So shared may be null in that case. */
9292 if (UNLIKELY(!shared))
9294 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9295 most lexing scope. In a file, shared->ls_linestr at that
9296 level is just one line, so there is no body to steal. */
9297 if (infile && !shared->ls_prev) {
9303 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9306 linestr = shared->ls_linestr;
9307 bufend = SvEND(linestr);
9309 while (s < bufend - len + 1 &&
9310 memNE(s,PL_tokenbuf,len) ) {
9312 ++PL_parser->herelines;
9314 if (s >= bufend - len + 1) {
9317 sv_setpvn(tmpstr,d+1,s-d);
9319 /* the preceding stmt passes a newline */
9320 PL_parser->herelines++;
9322 /* s now points to the newline after the heredoc terminator.
9323 d points to the newline before the body of the heredoc.
9326 /* We are going to modify linestr in place here, so set
9327 aside copies of the string if necessary for re-evals or
9329 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9330 check shared->re_eval_str. */
9331 if (shared->re_eval_start || shared->re_eval_str) {
9332 /* Set aside the rest of the regexp */
9333 if (!shared->re_eval_str)
9334 shared->re_eval_str =
9335 newSVpvn(shared->re_eval_start,
9336 bufend - shared->re_eval_start);
9337 shared->re_eval_start -= s-d;
9339 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9340 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9341 cx->blk_eval.cur_text == linestr)
9343 cx->blk_eval.cur_text = newSVsv(linestr);
9344 SvSCREAM_on(cx->blk_eval.cur_text);
9346 /* Copy everything from s onwards back to d. */
9347 Move(s,d,bufend-s + 1,char);
9348 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9349 /* Setting PL_bufend only applies when we have not dug deeper
9350 into other scopes, because sublex_done sets PL_bufend to
9351 SvEND(PL_linestr). */
9352 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9359 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9360 term = PL_tokenbuf[1];
9362 linestr_save = PL_linestr; /* must restore this afterwards */
9363 d = s; /* and this */
9364 PL_linestr = newSVpvs("");
9365 PL_bufend = SvPVX(PL_linestr);
9367 PL_bufptr = PL_bufend;
9368 CopLINE_set(PL_curcop,
9369 origline + 1 + PL_parser->herelines);
9370 if (!lex_next_chunk(LEX_NO_TERM)
9371 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9372 /* Simply freeing linestr_save might seem simpler here, as it
9373 does not matter what PL_linestr points to, since we are
9374 about to croak; but in a quote-like op, linestr_save
9375 will have been prospectively freed already, via
9376 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9377 restore PL_linestr. */
9378 SvREFCNT_dec_NN(PL_linestr);
9379 PL_linestr = linestr_save;
9382 CopLINE_set(PL_curcop, origline);
9383 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9384 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9385 /* ^That should be enough to avoid this needing to grow: */
9386 sv_catpvs(PL_linestr, "\n\0");
9387 assert(s == SvPVX(PL_linestr));
9388 PL_bufend = SvEND(PL_linestr);
9391 PL_parser->herelines++;
9392 PL_last_lop = PL_last_uni = NULL;
9393 #ifndef PERL_STRICT_CR
9394 if (PL_bufend - PL_linestart >= 2) {
9395 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9396 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9398 PL_bufend[-2] = '\n';
9400 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9402 else if (PL_bufend[-1] == '\r')
9403 PL_bufend[-1] = '\n';
9405 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9406 PL_bufend[-1] = '\n';
9408 if (*s == term && PL_bufend-s >= len
9409 && memEQ(s,PL_tokenbuf + 1,len)) {
9410 SvREFCNT_dec(PL_linestr);
9411 PL_linestr = linestr_save;
9412 PL_linestart = SvPVX(linestr_save);
9413 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9418 sv_catsv(tmpstr,PL_linestr);
9422 PL_multi_end = origline + PL_parser->herelines;
9423 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9424 SvPV_shrink_to_cur(tmpstr);
9427 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9429 else if (IN_ENCODING)
9430 sv_recode_to_utf8(tmpstr, _get_encoding());
9432 PL_lex_stuff = tmpstr;
9433 pl_yylval.ival = op_type;
9437 SvREFCNT_dec(tmpstr);
9438 CopLINE_set(PL_curcop, origline);
9439 missingterm(PL_tokenbuf + 1);
9443 takes: current position in input buffer
9444 returns: new position in input buffer
9445 side-effects: pl_yylval and lex_op are set.
9450 <<>> read from ARGV without magic open
9451 <FH> read from filehandle
9452 <pkg::FH> read from package qualified filehandle
9453 <pkg'FH> read from package qualified filehandle
9454 <$fh> read from filehandle in $fh
9460 S_scan_inputsymbol(pTHX_ char *start)
9462 char *s = start; /* current position in buffer */
9465 bool nomagicopen = FALSE;
9466 char *d = PL_tokenbuf; /* start of temp holding space */
9467 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9469 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9471 end = strchr(s, '\n');
9474 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9481 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9483 /* die if we didn't have space for the contents of the <>,
9484 or if it didn't end, or if we see a newline
9487 if (len >= (I32)sizeof PL_tokenbuf)
9488 Perl_croak(aTHX_ "Excessively long <> operator");
9490 Perl_croak(aTHX_ "Unterminated <> operator");
9495 Remember, only scalar variables are interpreted as filehandles by
9496 this code. Anything more complex (e.g., <$fh{$num}>) will be
9497 treated as a glob() call.
9498 This code makes use of the fact that except for the $ at the front,
9499 a scalar variable and a filehandle look the same.
9501 if (*d == '$' && d[1]) d++;
9503 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9504 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9505 d += UTF ? UTF8SKIP(d) : 1;
9507 /* If we've tried to read what we allow filehandles to look like, and
9508 there's still text left, then it must be a glob() and not a getline.
9509 Use scan_str to pull out the stuff between the <> and treat it
9510 as nothing more than a string.
9513 if (d - PL_tokenbuf != len) {
9514 pl_yylval.ival = OP_GLOB;
9515 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9517 Perl_croak(aTHX_ "Glob not terminated");
9521 bool readline_overriden = FALSE;
9523 /* we're in a filehandle read situation */
9526 /* turn <> into <ARGV> */
9528 Copy("ARGV",d,5,char);
9530 /* Check whether readline() is overriden */
9531 if ((gv_readline = gv_override("readline",8)))
9532 readline_overriden = TRUE;
9534 /* if <$fh>, create the ops to turn the variable into a
9538 /* try to find it in the pad for this block, otherwise find
9539 add symbol table ops
9541 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9542 if (tmp != NOT_IN_PAD) {
9543 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9544 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9545 HEK * const stashname = HvNAME_HEK(stash);
9546 SV * const sym = sv_2mortal(newSVhek(stashname));
9547 sv_catpvs(sym, "::");
9553 OP * const o = newOP(OP_PADSV, 0);
9555 PL_lex_op = readline_overriden
9556 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9557 op_append_elem(OP_LIST, o,
9558 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9559 : (OP*)newUNOP(OP_READLINE, 0, o);
9567 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9569 PL_lex_op = readline_overriden
9570 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9571 op_append_elem(OP_LIST,
9572 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9573 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9574 : (OP*)newUNOP(OP_READLINE, 0,
9575 newUNOP(OP_RV2SV, 0,
9576 newGVOP(OP_GV, 0, gv)));
9578 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9579 pl_yylval.ival = OP_NULL;
9582 /* If it's none of the above, it must be a literal filehandle
9583 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9585 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9586 PL_lex_op = readline_overriden
9587 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9588 op_append_elem(OP_LIST,
9589 newGVOP(OP_GV, 0, gv),
9590 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9591 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9592 pl_yylval.ival = OP_NULL;
9602 start position in buffer
9603 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9604 only if they are of the open/close form
9605 keep_delims preserve the delimiters around the string
9606 re_reparse compiling a run-time /(?{})/:
9607 collapse // to /, and skip encoding src
9608 delimp if non-null, this is set to the position of
9609 the closing delimiter, or just after it if
9610 the closing and opening delimiters differ
9611 (i.e., the opening delimiter of a substitu-
9613 returns: position to continue reading from buffer
9614 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9615 updates the read buffer.
9617 This subroutine pulls a string out of the input. It is called for:
9618 q single quotes q(literal text)
9619 ' single quotes 'literal text'
9620 qq double quotes qq(interpolate $here please)
9621 " double quotes "interpolate $here please"
9622 qx backticks qx(/bin/ls -l)
9623 ` backticks `/bin/ls -l`
9624 qw quote words @EXPORT_OK = qw( func() $spam )
9625 m// regexp match m/this/
9626 s/// regexp substitute s/this/that/
9627 tr/// string transliterate tr/this/that/
9628 y/// string transliterate y/this/that/
9629 ($*@) sub prototypes sub foo ($)
9630 (stuff) sub attr parameters sub foo : attr(stuff)
9631 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9633 In most of these cases (all but <>, patterns and transliterate)
9634 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9635 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9636 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9639 It skips whitespace before the string starts, and treats the first
9640 character as the delimiter. If the delimiter is one of ([{< then
9641 the corresponding "close" character )]}> is used as the closing
9642 delimiter. It allows quoting of delimiters, and if the string has
9643 balanced delimiters ([{<>}]) it allows nesting.
9645 On success, the SV with the resulting string is put into lex_stuff or,
9646 if that is already non-NULL, into lex_repl. The second case occurs only
9647 when parsing the RHS of the special constructs s/// and tr/// (y///).
9648 For convenience, the terminating delimiter character is stuffed into
9653 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9657 SV *sv; /* scalar value: string */
9658 const char *tmps; /* temp string, used for delimiter matching */
9659 char *s = start; /* current position in the buffer */
9660 char term; /* terminating character */
9661 char *to; /* current position in the sv's data */
9662 I32 brackets = 1; /* bracket nesting level */
9663 bool has_utf8 = FALSE; /* is there any utf8 content? */
9664 I32 termcode; /* terminating char. code */
9665 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9666 STRLEN termlen; /* length of terminating string */
9667 int last_off = 0; /* last position for nesting bracket */
9670 PERL_ARGS_ASSERT_SCAN_STR;
9672 /* skip space before the delimiter */
9677 /* mark where we are, in case we need to report errors */
9680 /* after skipping whitespace, the next character is the terminator */
9683 termcode = termstr[0] = term;
9687 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9688 Copy(s, termstr, termlen, U8);
9689 if (!UTF8_IS_INVARIANT(term))
9693 /* mark where we are */
9694 PL_multi_start = CopLINE(PL_curcop);
9695 PL_multi_open = term;
9696 herelines = PL_parser->herelines;
9698 /* find corresponding closing delimiter */
9699 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9700 termcode = termstr[0] = term = tmps[5];
9702 PL_multi_close = term;
9704 if (PL_multi_open == PL_multi_close) {
9705 keep_bracketed_quoted = FALSE;
9708 /* create a new SV to hold the contents. 79 is the SV's initial length.
9709 What a random number. */
9710 sv = newSV_type(SVt_PVIV);
9712 SvIV_set(sv, termcode);
9713 (void)SvPOK_only(sv); /* validate pointer */
9715 /* move past delimiter and try to read a complete string */
9717 sv_catpvn(sv, s, termlen);
9720 if (IN_ENCODING && !UTF && !re_reparse) {
9724 int offset = s - SvPVX_const(PL_linestr);
9725 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9726 &offset, (char*)termstr, termlen);
9730 if (SvIsCOW(PL_linestr)) {
9731 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9732 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9733 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9734 char *buf = SvPVX(PL_linestr);
9735 bufend_pos = PL_parser->bufend - buf;
9736 bufptr_pos = PL_parser->bufptr - buf;
9737 oldbufptr_pos = PL_parser->oldbufptr - buf;
9738 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9739 linestart_pos = PL_parser->linestart - buf;
9740 last_uni_pos = PL_parser->last_uni
9741 ? PL_parser->last_uni - buf
9743 last_lop_pos = PL_parser->last_lop
9744 ? PL_parser->last_lop - buf
9747 PL_parser->lex_shared->re_eval_start ?
9748 PL_parser->lex_shared->re_eval_start - buf : 0;
9751 sv_force_normal(PL_linestr);
9753 buf = SvPVX(PL_linestr);
9754 PL_parser->bufend = buf + bufend_pos;
9755 PL_parser->bufptr = buf + bufptr_pos;
9756 PL_parser->oldbufptr = buf + oldbufptr_pos;
9757 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9758 PL_parser->linestart = buf + linestart_pos;
9759 if (PL_parser->last_uni)
9760 PL_parser->last_uni = buf + last_uni_pos;
9761 if (PL_parser->last_lop)
9762 PL_parser->last_lop = buf + last_lop_pos;
9763 if (PL_parser->lex_shared->re_eval_start)
9764 PL_parser->lex_shared->re_eval_start =
9765 buf + re_eval_start_pos;
9768 ns = SvPVX_const(PL_linestr) + offset;
9769 svlast = SvEND(sv) - 1;
9771 for (; s < ns; s++) {
9772 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9773 COPLINE_INC_WITH_HERELINES;
9776 goto read_more_line;
9778 /* handle quoted delimiters */
9779 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9781 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9783 if ((svlast-1 - t) % 2) {
9784 if (!keep_bracketed_quoted) {
9787 SvCUR_set(sv, SvCUR(sv) - 1);
9792 if (PL_multi_open == PL_multi_close) {
9798 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9799 /* At here, all closes are "was quoted" one,
9800 so we don't check PL_multi_close. */
9802 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9807 else if (*t == PL_multi_open)
9815 SvCUR_set(sv, w - SvPVX_const(sv));
9817 last_off = w - SvPVX(sv);
9818 if (--brackets <= 0)
9824 SvCUR_set(sv, SvCUR(sv) - 1);
9830 /* extend sv if need be */
9831 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9832 /* set 'to' to the next character in the sv's string */
9833 to = SvPVX(sv)+SvCUR(sv);
9835 /* if open delimiter is the close delimiter read unbridle */
9836 if (PL_multi_open == PL_multi_close) {
9837 for (; s < PL_bufend; s++,to++) {
9838 /* embedded newlines increment the current line number */
9839 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9840 COPLINE_INC_WITH_HERELINES;
9841 /* handle quoted delimiters */
9842 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9843 if (!keep_bracketed_quoted
9845 || (re_reparse && s[1] == '\\'))
9848 else /* any other quotes are simply copied straight through */
9851 /* terminate when run out of buffer (the for() condition), or
9852 have found the terminator */
9853 else if (*s == term) {
9856 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9859 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9865 /* if the terminator isn't the same as the start character (e.g.,
9866 matched brackets), we have to allow more in the quoting, and
9867 be prepared for nested brackets.
9870 /* read until we run out of string, or we find the terminator */
9871 for (; s < PL_bufend; s++,to++) {
9872 /* embedded newlines increment the line count */
9873 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9874 COPLINE_INC_WITH_HERELINES;
9875 /* backslashes can escape the open or closing characters */
9876 if (*s == '\\' && s+1 < PL_bufend) {
9877 if (!keep_bracketed_quoted &&
9878 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9885 /* allow nested opens and closes */
9886 else if (*s == PL_multi_close && --brackets <= 0)
9888 else if (*s == PL_multi_open)
9890 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9895 /* terminate the copied string and update the sv's end-of-string */
9897 SvCUR_set(sv, to - SvPVX_const(sv));
9900 * this next chunk reads more into the buffer if we're not done yet
9904 break; /* handle case where we are done yet :-) */
9906 #ifndef PERL_STRICT_CR
9907 if (to - SvPVX_const(sv) >= 2) {
9908 if ((to[-2] == '\r' && to[-1] == '\n') ||
9909 (to[-2] == '\n' && to[-1] == '\r'))
9913 SvCUR_set(sv, to - SvPVX_const(sv));
9915 else if (to[-1] == '\r')
9918 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9923 /* if we're out of file, or a read fails, bail and reset the current
9924 line marker so we can report where the unterminated string began
9926 COPLINE_INC_WITH_HERELINES;
9927 PL_bufptr = PL_bufend;
9928 if (!lex_next_chunk(0)) {
9930 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9936 /* at this point, we have successfully read the delimited string */
9938 if (!IN_ENCODING || UTF || re_reparse) {
9941 sv_catpvn(sv, s, termlen);
9944 if (has_utf8 || (IN_ENCODING && !re_reparse))
9947 PL_multi_end = CopLINE(PL_curcop);
9948 CopLINE_set(PL_curcop, PL_multi_start);
9949 PL_parser->herelines = herelines;
9951 /* if we allocated too much space, give some back */
9952 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9953 SvLEN_set(sv, SvCUR(sv) + 1);
9954 SvPV_renew(sv, SvLEN(sv));
9957 /* decide whether this is the first or second quoted string we've read
9962 PL_sublex_info.repl = sv;
9965 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9971 takes: pointer to position in buffer
9972 returns: pointer to new position in buffer
9973 side-effects: builds ops for the constant in pl_yylval.op
9975 Read a number in any of the formats that Perl accepts:
9977 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9978 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9979 0b[01](_?[01])* binary integers
9980 0[0-7](_?[0-7])* octal integers
9981 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9982 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9984 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9987 If it reads a number without a decimal point or an exponent, it will
9988 try converting the number to an integer and see if it can do so
9989 without loss of precision.
9993 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9995 const char *s = start; /* current position in buffer */
9996 char *d; /* destination in temp buffer */
9997 char *e; /* end of temp buffer */
9998 NV nv; /* number read, as a double */
9999 SV *sv = NULL; /* place to put the converted number */
10000 bool floatit; /* boolean: int or float? */
10001 const char *lastub = NULL; /* position of last underbar */
10002 static const char* const number_too_long = "Number too long";
10003 /* Hexadecimal floating point.
10005 * In many places (where we have quads and NV is IEEE 754 double)
10006 * we can fit the mantissa bits of a NV into an unsigned quad.
10007 * (Note that UVs might not be quads even when we have quads.)
10008 * This will not work everywhere, though (either no quads, or
10009 * using long doubles), in which case we have to resort to NV,
10010 * which will probably mean horrible loss of precision due to
10011 * multiple fp operations. */
10012 bool hexfp = FALSE;
10013 int total_bits = 0;
10014 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10015 # define HEXFP_UQUAD
10016 Uquad_t hexfp_uquad = 0;
10017 int hexfp_frac_bits = 0;
10022 NV hexfp_mult = 1.0;
10023 UV high_non_zero = 0; /* highest digit */
10025 PERL_ARGS_ASSERT_SCAN_NUM;
10027 /* We use the first character to decide what type of number this is */
10031 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10033 /* if it starts with a 0, it could be an octal number, a decimal in
10034 0.13 disguise, or a hexadecimal number, or a binary number. */
10038 u holds the "number so far"
10039 shift the power of 2 of the base
10040 (hex == 4, octal == 3, binary == 1)
10041 overflowed was the number more than we can hold?
10043 Shift is used when we add a digit. It also serves as an "are
10044 we in octal/hex/binary?" indicator to disallow hex characters
10045 when in octal mode.
10050 bool overflowed = FALSE;
10051 bool just_zero = TRUE; /* just plain 0 or binary number? */
10052 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10053 static const char* const bases[5] =
10054 { "", "binary", "", "octal", "hexadecimal" };
10055 static const char* const Bases[5] =
10056 { "", "Binary", "", "Octal", "Hexadecimal" };
10057 static const char* const maxima[5] =
10059 "0b11111111111111111111111111111111",
10063 const char *base, *Base, *max;
10065 /* check for hex */
10066 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10070 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10075 /* check for a decimal in disguise */
10076 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10078 /* so it must be octal */
10085 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10086 "Misplaced _ in number");
10090 base = bases[shift];
10091 Base = Bases[shift];
10092 max = maxima[shift];
10094 /* read the rest of the number */
10096 /* x is used in the overflow test,
10097 b is the digit we're adding on. */
10102 /* if we don't mention it, we're done */
10106 /* _ are ignored -- but warned about if consecutive */
10108 if (lastub && s == lastub + 1)
10109 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10110 "Misplaced _ in number");
10114 /* 8 and 9 are not octal */
10115 case '8': case '9':
10117 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10121 case '2': case '3': case '4':
10122 case '5': case '6': case '7':
10124 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10127 case '0': case '1':
10128 b = *s++ & 15; /* ASCII digit -> value of digit */
10132 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10133 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10134 /* make sure they said 0x */
10137 b = (*s++ & 7) + 9;
10139 /* Prepare to put the digit we have onto the end
10140 of the number so far. We check for overflows.
10146 x = u << shift; /* make room for the digit */
10148 total_bits += shift;
10150 if ((x >> shift) != u
10151 && !(PL_hints & HINT_NEW_BINARY)) {
10154 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10155 "Integer overflow in %s number",
10158 u = x | b; /* add the digit to the end */
10161 n *= nvshift[shift];
10162 /* If an NV has not enough bits in its
10163 * mantissa to represent an UV this summing of
10164 * small low-order numbers is a waste of time
10165 * (because the NV cannot preserve the
10166 * low-order bits anyway): we could just
10167 * remember when did we overflow and in the
10168 * end just multiply n by the right
10173 if (high_non_zero == 0 && b > 0)
10176 /* this could be hexfp, but peek ahead
10177 * to avoid matching ".." */
10178 if (UNLIKELY(HEXFP_PEEK(s))) {
10186 /* if we get here, we had success: make a scalar value from
10191 /* final misplaced underbar check */
10192 if (s[-1] == '_') {
10193 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10196 if (UNLIKELY(HEXFP_PEEK(s))) {
10197 /* Do sloppy (on the underbars) but quick detection
10198 * (and value construction) for hexfp, the decimal
10199 * detection will shortly be more thorough with the
10200 * underbar checks. */
10204 #else /* HEXFP_NV */
10209 NV mult = 1 / 16.0;
10212 while (isXDIGIT(*h) || *h == '_') {
10213 if (isXDIGIT(*h)) {
10214 U8 b = XDIGIT_VALUE(*h);
10215 total_bits += shift;
10217 hexfp_uquad <<= shift;
10219 hexfp_frac_bits += shift;
10220 #else /* HEXFP_NV */
10221 hexfp_nv += b * mult;
10229 if (total_bits >= 4) {
10230 if (high_non_zero < 0x8)
10232 if (high_non_zero < 0x4)
10234 if (high_non_zero < 0x2)
10238 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10239 bool negexp = FALSE;
10243 else if (*h == '-') {
10249 while (isDIGIT(*h) || *h == '_') {
10252 hexfp_exp += *h - '0';
10255 -hexfp_exp < NV_MIN_EXP - 1) {
10256 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10257 "Hexadecimal float: exponent underflow");
10264 hexfp_exp > NV_MAX_EXP - 1) {
10265 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10266 "Hexadecimal float: exponent overflow");
10275 hexfp_exp = -hexfp_exp;
10277 hexfp_exp -= hexfp_frac_bits;
10279 hexfp_mult = pow(2.0, hexfp_exp);
10287 if (n > 4294967295.0)
10288 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10289 "%s number > %s non-portable",
10295 if (u > 0xffffffff)
10296 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10297 "%s number > %s non-portable",
10302 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10303 sv = new_constant(start, s - start, "integer",
10304 sv, NULL, NULL, 0);
10305 else if (PL_hints & HINT_NEW_BINARY)
10306 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10311 handle decimal numbers.
10312 we're also sent here when we read a 0 as the first digit
10314 case '1': case '2': case '3': case '4': case '5':
10315 case '6': case '7': case '8': case '9': case '.':
10318 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10327 /* read next group of digits and _ and copy into d */
10328 while (isDIGIT(*s) || *s == '_' ||
10329 UNLIKELY(hexfp && isXDIGIT(*s))) {
10330 /* skip underscores, checking for misplaced ones
10334 if (lastub && s == lastub + 1)
10335 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10336 "Misplaced _ in number");
10340 /* check for end of fixed-length buffer */
10342 Perl_croak(aTHX_ "%s", number_too_long);
10343 /* if we're ok, copy the character */
10348 /* final misplaced underbar check */
10349 if (lastub && s == lastub + 1) {
10350 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10353 /* read a decimal portion if there is one. avoid
10354 3..5 being interpreted as the number 3. followed
10357 if (*s == '.' && s[1] != '.') {
10362 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10363 "Misplaced _ in number");
10367 /* copy, ignoring underbars, until we run out of digits.
10369 for (; isDIGIT(*s) || *s == '_' ||
10370 UNLIKELY(hexfp && isXDIGIT(*s));
10372 /* fixed length buffer check */
10374 Perl_croak(aTHX_ "%s", number_too_long);
10376 if (lastub && s == lastub + 1)
10377 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10378 "Misplaced _ in number");
10384 /* fractional part ending in underbar? */
10385 if (s[-1] == '_') {
10386 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10387 "Misplaced _ in number");
10389 if (*s == '.' && isDIGIT(s[1])) {
10390 /* oops, it's really a v-string, but without the "v" */
10396 /* read exponent part, if present */
10397 if ((isALPHA_FOLD_EQ(*s, 'e')
10398 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10399 && strchr("+-0123456789_", s[1]))
10403 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10404 ditto for p (hexfloats) */
10405 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10406 /* At least some Mach atof()s don't grok 'E' */
10409 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10416 /* stray preinitial _ */
10418 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10419 "Misplaced _ in number");
10423 /* allow positive or negative exponent */
10424 if (*s == '+' || *s == '-')
10427 /* stray initial _ */
10429 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10430 "Misplaced _ in number");
10434 /* read digits of exponent */
10435 while (isDIGIT(*s) || *s == '_') {
10438 Perl_croak(aTHX_ "%s", number_too_long);
10442 if (((lastub && s == lastub + 1) ||
10443 (!isDIGIT(s[1]) && s[1] != '_')))
10444 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10445 "Misplaced _ in number");
10453 We try to do an integer conversion first if no characters
10454 indicating "float" have been found.
10459 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10461 if (flags == IS_NUMBER_IN_UV) {
10463 sv = newSViv(uv); /* Prefer IVs over UVs. */
10466 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10467 if (uv <= (UV) IV_MIN)
10468 sv = newSViv(-(IV)uv);
10475 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10476 /* terminate the string */
10478 if (UNLIKELY(hexfp)) {
10479 # ifdef NV_MANT_DIG
10480 if (total_bits > NV_MANT_DIG)
10481 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10482 "Hexadecimal float: mantissa overflow");
10485 nv = hexfp_uquad * hexfp_mult;
10486 #else /* HEXFP_NV */
10487 nv = hexfp_nv * hexfp_mult;
10490 nv = Atof(PL_tokenbuf);
10492 RESTORE_LC_NUMERIC_UNDERLYING();
10497 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10498 const char *const key = floatit ? "float" : "integer";
10499 const STRLEN keylen = floatit ? 5 : 7;
10500 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10501 key, keylen, sv, NULL, NULL, 0);
10505 /* if it starts with a v, it could be a v-string */
10508 sv = newSV(5); /* preallocate storage space */
10509 ENTER_with_name("scan_vstring");
10511 s = scan_vstring(s, PL_bufend, sv);
10512 SvREFCNT_inc_simple_void_NN(sv);
10513 LEAVE_with_name("scan_vstring");
10517 /* make the op for the constant and return */
10520 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10522 lvalp->opval = NULL;
10528 S_scan_formline(pTHX_ char *s)
10532 SV * const stuff = newSVpvs("");
10533 bool needargs = FALSE;
10534 bool eofmt = FALSE;
10536 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10538 while (!needargs) {
10541 #ifdef PERL_STRICT_CR
10542 while (SPACE_OR_TAB(*t))
10545 while (SPACE_OR_TAB(*t) || *t == '\r')
10548 if (*t == '\n' || t == PL_bufend) {
10553 eol = (char *) memchr(s,'\n',PL_bufend-s);
10557 for (t = s; t < eol; t++) {
10558 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10560 goto enough; /* ~~ must be first line in formline */
10562 if (*t == '@' || *t == '^')
10566 sv_catpvn(stuff, s, eol-s);
10567 #ifndef PERL_STRICT_CR
10568 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10569 char *end = SvPVX(stuff) + SvCUR(stuff);
10572 SvCUR_set(stuff, SvCUR(stuff) - 1);
10580 if ((PL_rsfp || PL_parser->filtered)
10581 && PL_parser->form_lex_state == LEX_NORMAL) {
10583 PL_bufptr = PL_bufend;
10584 COPLINE_INC_WITH_HERELINES;
10585 got_some = lex_next_chunk(0);
10586 CopLINE_dec(PL_curcop);
10594 if (!SvCUR(stuff) || needargs)
10595 PL_lex_state = PL_parser->form_lex_state;
10596 if (SvCUR(stuff)) {
10597 PL_expect = XSTATE;
10599 const char *s2 = s;
10600 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10604 PL_expect = XTERMBLOCK;
10605 NEXTVAL_NEXTTOKE.ival = 0;
10608 NEXTVAL_NEXTTOKE.ival = 0;
10609 force_next(FORMLBRACK);
10612 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10614 else if (IN_ENCODING)
10615 sv_recode_to_utf8(stuff, _get_encoding());
10617 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10621 SvREFCNT_dec(stuff);
10623 PL_lex_formbrack = 0;
10629 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10631 const I32 oldsavestack_ix = PL_savestack_ix;
10632 CV* const outsidecv = PL_compcv;
10634 SAVEI32(PL_subline);
10635 save_item(PL_subname);
10636 SAVESPTR(PL_compcv);
10638 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10639 CvFLAGS(PL_compcv) |= flags;
10641 PL_subline = CopLINE(PL_curcop);
10642 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10643 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10644 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10645 if (outsidecv && CvPADLIST(outsidecv))
10646 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10648 return oldsavestack_ix;
10652 S_yywarn(pTHX_ const char *const s, U32 flags)
10654 PERL_ARGS_ASSERT_YYWARN;
10656 PL_in_eval |= EVAL_WARNONLY;
10657 yyerror_pv(s, flags);
10662 Perl_yyerror(pTHX_ const char *const s)
10664 PERL_ARGS_ASSERT_YYERROR;
10665 return yyerror_pvn(s, strlen(s), 0);
10669 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10671 PERL_ARGS_ASSERT_YYERROR_PV;
10672 return yyerror_pvn(s, strlen(s), flags);
10676 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10678 const char *context = NULL;
10681 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10682 int yychar = PL_parser->yychar;
10684 PERL_ARGS_ASSERT_YYERROR_PVN;
10686 if (!yychar || (yychar == ';' && !PL_rsfp))
10687 sv_catpvs(where_sv, "at EOF");
10688 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10689 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10690 PL_oldbufptr != PL_bufptr) {
10693 The code below is removed for NetWare because it abends/crashes on NetWare
10694 when the script has error such as not having the closing quotes like:
10695 if ($var eq "value)
10696 Checking of white spaces is anyway done in NetWare code.
10699 while (isSPACE(*PL_oldoldbufptr))
10702 context = PL_oldoldbufptr;
10703 contlen = PL_bufptr - PL_oldoldbufptr;
10705 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10706 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10709 The code below is removed for NetWare because it abends/crashes on NetWare
10710 when the script has error such as not having the closing quotes like:
10711 if ($var eq "value)
10712 Checking of white spaces is anyway done in NetWare code.
10715 while (isSPACE(*PL_oldbufptr))
10718 context = PL_oldbufptr;
10719 contlen = PL_bufptr - PL_oldbufptr;
10721 else if (yychar > 255)
10722 sv_catpvs(where_sv, "next token ???");
10723 else if (yychar == YYEMPTY) {
10724 if (PL_lex_state == LEX_NORMAL ||
10725 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10726 sv_catpvs(where_sv, "at end of line");
10727 else if (PL_lex_inpat)
10728 sv_catpvs(where_sv, "within pattern");
10730 sv_catpvs(where_sv, "within string");
10733 sv_catpvs(where_sv, "next char ");
10735 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10736 else if (isPRINT_LC(yychar)) {
10737 const char string = yychar;
10738 sv_catpvn(where_sv, &string, 1);
10741 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10743 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10744 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10745 OutCopFILE(PL_curcop),
10746 (IV)(PL_parser->preambling == NOLINE
10747 ? CopLINE(PL_curcop)
10748 : PL_parser->preambling));
10750 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10751 UTF8fARG(UTF, contlen, context));
10753 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10754 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10755 Perl_sv_catpvf(aTHX_ msg,
10756 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10757 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10760 if (PL_in_eval & EVAL_WARNONLY) {
10761 PL_in_eval &= ~EVAL_WARNONLY;
10762 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10766 if (PL_error_count >= 10) {
10768 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10769 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10770 SVfARG(errsv), OutCopFILE(PL_curcop));
10772 Perl_croak(aTHX_ "%s has too many errors.\n",
10773 OutCopFILE(PL_curcop));
10776 PL_in_my_stash = NULL;
10781 S_swallow_bom(pTHX_ U8 *s)
10783 const STRLEN slen = SvCUR(PL_linestr);
10785 PERL_ARGS_ASSERT_SWALLOW_BOM;
10789 if (s[1] == 0xFE) {
10790 /* UTF-16 little-endian? (or UTF-32LE?) */
10791 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10792 /* diag_listed_as: Unsupported script encoding %s */
10793 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10794 #ifndef PERL_NO_UTF16_FILTER
10795 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10797 if (PL_bufend > (char*)s) {
10798 s = add_utf16_textfilter(s, TRUE);
10801 /* diag_listed_as: Unsupported script encoding %s */
10802 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10807 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10808 #ifndef PERL_NO_UTF16_FILTER
10809 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10811 if (PL_bufend > (char *)s) {
10812 s = add_utf16_textfilter(s, FALSE);
10815 /* diag_listed_as: Unsupported script encoding %s */
10816 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10820 case BOM_UTF8_FIRST_BYTE: {
10821 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10822 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10823 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10824 s += len + 1; /* UTF-8 */
10831 if (s[2] == 0xFE && s[3] == 0xFF) {
10832 /* UTF-32 big-endian */
10833 /* diag_listed_as: Unsupported script encoding %s */
10834 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10837 else if (s[2] == 0 && s[3] != 0) {
10840 * are a good indicator of UTF-16BE. */
10841 #ifndef PERL_NO_UTF16_FILTER
10842 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10843 s = add_utf16_textfilter(s, FALSE);
10845 /* diag_listed_as: Unsupported script encoding %s */
10846 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10853 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10856 * are a good indicator of UTF-16LE. */
10857 #ifndef PERL_NO_UTF16_FILTER
10858 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10859 s = add_utf16_textfilter(s, TRUE);
10861 /* diag_listed_as: Unsupported script encoding %s */
10862 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10870 #ifndef PERL_NO_UTF16_FILTER
10872 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10874 SV *const filter = FILTER_DATA(idx);
10875 /* We re-use this each time round, throwing the contents away before we
10877 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10878 SV *const utf8_buffer = filter;
10879 IV status = IoPAGE(filter);
10880 const bool reverse = cBOOL(IoLINES(filter));
10883 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10885 /* As we're automatically added, at the lowest level, and hence only called
10886 from this file, we can be sure that we're not called in block mode. Hence
10887 don't bother writing code to deal with block mode. */
10889 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10892 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10894 DEBUG_P(PerlIO_printf(Perl_debug_log,
10895 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10896 FPTR2DPTR(void *, S_utf16_textfilter),
10897 reverse ? 'l' : 'b', idx, maxlen, status,
10898 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10905 /* First, look in our buffer of existing UTF-8 data: */
10906 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10910 } else if (status == 0) {
10912 IoPAGE(filter) = 0;
10913 nl = SvEND(utf8_buffer);
10916 STRLEN got = nl - SvPVX(utf8_buffer);
10917 /* Did we have anything to append? */
10919 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10920 /* Everything else in this code works just fine if SVp_POK isn't
10921 set. This, however, needs it, and we need it to work, else
10922 we loop infinitely because the buffer is never consumed. */
10923 sv_chop(utf8_buffer, nl);
10927 /* OK, not a complete line there, so need to read some more UTF-16.
10928 Read an extra octect if the buffer currently has an odd number. */
10932 if (SvCUR(utf16_buffer) >= 2) {
10933 /* Location of the high octet of the last complete code point.
10934 Gosh, UTF-16 is a pain. All the benefits of variable length,
10935 *coupled* with all the benefits of partial reads and
10937 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10938 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10940 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10944 /* We have the first half of a surrogate. Read more. */
10945 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10948 status = FILTER_READ(idx + 1, utf16_buffer,
10949 160 + (SvCUR(utf16_buffer) & 1));
10950 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10951 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10954 IoPAGE(filter) = status;
10959 chars = SvCUR(utf16_buffer) >> 1;
10960 have = SvCUR(utf8_buffer);
10961 SvGROW(utf8_buffer, have + chars * 3 + 1);
10964 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10965 (U8*)SvPVX_const(utf8_buffer) + have,
10966 chars * 2, &newlen);
10968 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10969 (U8*)SvPVX_const(utf8_buffer) + have,
10970 chars * 2, &newlen);
10972 SvCUR_set(utf8_buffer, have + newlen);
10975 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10976 it's private to us, and utf16_to_utf8{,reversed} take a
10977 (pointer,length) pair, rather than a NUL-terminated string. */
10978 if(SvCUR(utf16_buffer) & 1) {
10979 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10980 SvCUR_set(utf16_buffer, 1);
10982 SvCUR_set(utf16_buffer, 0);
10985 DEBUG_P(PerlIO_printf(Perl_debug_log,
10986 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10988 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10989 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10994 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10996 SV *filter = filter_add(S_utf16_textfilter, NULL);
10998 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11000 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11001 sv_setpvs(filter, "");
11002 IoLINES(filter) = reversed;
11003 IoPAGE(filter) = 1; /* Not EOF */
11005 /* Sadly, we have to return a valid pointer, come what may, so we have to
11006 ignore any error return from this. */
11007 SvCUR_set(PL_linestr, 0);
11008 if (FILTER_READ(0, PL_linestr, 0)) {
11009 SvUTF8_on(PL_linestr);
11011 SvUTF8_on(PL_linestr);
11013 PL_bufend = SvEND(PL_linestr);
11014 return (U8*)SvPVX(PL_linestr);
11019 Returns a pointer to the next character after the parsed
11020 vstring, as well as updating the passed in sv.
11022 Function must be called like
11024 sv = sv_2mortal(newSV(5));
11025 s = scan_vstring(s,e,sv);
11027 where s and e are the start and end of the string.
11028 The sv should already be large enough to store the vstring
11029 passed in, for performance reasons.
11031 This function may croak if fatal warnings are enabled in the
11032 calling scope, hence the sv_2mortal in the example (to prevent
11033 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11039 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11041 const char *pos = s;
11042 const char *start = s;
11044 PERL_ARGS_ASSERT_SCAN_VSTRING;
11046 if (*pos == 'v') pos++; /* get past 'v' */
11047 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11049 if ( *pos != '.') {
11050 /* this may not be a v-string if followed by => */
11051 const char *next = pos;
11052 while (next < e && isSPACE(*next))
11054 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11055 /* return string not v-string */
11056 sv_setpvn(sv,(char *)s,pos-s);
11057 return (char *)pos;
11061 if (!isALPHA(*pos)) {
11062 U8 tmpbuf[UTF8_MAXBYTES+1];
11065 s++; /* get past 'v' */
11070 /* this is atoi() that tolerates underscores */
11073 const char *end = pos;
11075 while (--end >= s) {
11077 const UV orev = rev;
11078 rev += (*end - '0') * mult;
11081 /* diag_listed_as: Integer overflow in %s number */
11082 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11083 "Integer overflow in decimal number");
11087 if (rev > 0x7FFFFFFF)
11088 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11090 /* Append native character for the rev point */
11091 tmpend = uvchr_to_utf8(tmpbuf, rev);
11092 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11093 if (!UVCHR_IS_INVARIANT(rev))
11095 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11101 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11105 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11112 Perl_keyword_plugin_standard(pTHX_
11113 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11115 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11116 PERL_UNUSED_CONTEXT;
11117 PERL_UNUSED_ARG(keyword_ptr);
11118 PERL_UNUSED_ARG(keyword_len);
11119 PERL_UNUSED_ARG(op_ptr);
11120 return KEYWORD_PLUGIN_DECLINE;
11123 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11125 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11127 SAVEI32(PL_lex_brackets);
11128 if (PL_lex_brackets > 100)
11129 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11130 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11131 SAVEI32(PL_lex_allbrackets);
11132 PL_lex_allbrackets = 0;
11133 SAVEI8(PL_lex_fakeeof);
11134 PL_lex_fakeeof = (U8)fakeeof;
11135 if(yyparse(gramtype) && !PL_parser->error_count)
11136 qerror(Perl_mess(aTHX_ "Parse error"));
11139 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11141 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11145 SAVEVPTR(PL_eval_root);
11146 PL_eval_root = NULL;
11147 parse_recdescent(gramtype, fakeeof);
11153 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11155 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11158 if (flags & ~PARSE_OPTIONAL)
11159 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11160 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11161 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11162 if (!PL_parser->error_count)
11163 qerror(Perl_mess(aTHX_ "Parse error"));
11164 exprop = newOP(OP_NULL, 0);
11170 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11172 Parse a Perl arithmetic expression. This may contain operators of precedence
11173 down to the bit shift operators. The expression must be followed (and thus
11174 terminated) either by a comparison or lower-precedence operator or by
11175 something that would normally terminate an expression such as semicolon.
11176 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11177 otherwise it is mandatory. It is up to the caller to ensure that the
11178 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11179 the source of the code to be parsed and the lexical context for the
11182 The op tree representing the expression is returned. If an optional
11183 expression is absent, a null pointer is returned, otherwise the pointer
11186 If an error occurs in parsing or compilation, in most cases a valid op
11187 tree is returned anyway. The error is reflected in the parser state,
11188 normally resulting in a single exception at the top level of parsing
11189 which covers all the compilation errors that occurred. Some compilation
11190 errors, however, will throw an exception immediately.
11196 Perl_parse_arithexpr(pTHX_ U32 flags)
11198 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11202 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11204 Parse a Perl term expression. This may contain operators of precedence
11205 down to the assignment operators. The expression must be followed (and thus
11206 terminated) either by a comma or lower-precedence operator or by
11207 something that would normally terminate an expression such as semicolon.
11208 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11209 otherwise it is mandatory. It is up to the caller to ensure that the
11210 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11211 the source of the code to be parsed and the lexical context for the
11214 The op tree representing the expression is returned. If an optional
11215 expression is absent, a null pointer is returned, otherwise the pointer
11218 If an error occurs in parsing or compilation, in most cases a valid op
11219 tree is returned anyway. The error is reflected in the parser state,
11220 normally resulting in a single exception at the top level of parsing
11221 which covers all the compilation errors that occurred. Some compilation
11222 errors, however, will throw an exception immediately.
11228 Perl_parse_termexpr(pTHX_ U32 flags)
11230 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11234 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11236 Parse a Perl list expression. This may contain operators of precedence
11237 down to the comma operator. The expression must be followed (and thus
11238 terminated) either by a low-precedence logic operator such as C<or> or by
11239 something that would normally terminate an expression such as semicolon.
11240 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11241 otherwise it is mandatory. It is up to the caller to ensure that the
11242 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11243 the source of the code to be parsed and the lexical context for the
11246 The op tree representing the expression is returned. If an optional
11247 expression is absent, a null pointer is returned, otherwise the pointer
11250 If an error occurs in parsing or compilation, in most cases a valid op
11251 tree is returned anyway. The error is reflected in the parser state,
11252 normally resulting in a single exception at the top level of parsing
11253 which covers all the compilation errors that occurred. Some compilation
11254 errors, however, will throw an exception immediately.
11260 Perl_parse_listexpr(pTHX_ U32 flags)
11262 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11266 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11268 Parse a single complete Perl expression. This allows the full
11269 expression grammar, including the lowest-precedence operators such
11270 as C<or>. The expression must be followed (and thus terminated) by a
11271 token that an expression would normally be terminated by: end-of-file,
11272 closing bracketing punctuation, semicolon, or one of the keywords that
11273 signals a postfix expression-statement modifier. If I<flags> includes
11274 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11275 mandatory. It is up to the caller to ensure that the dynamic parser
11276 state (L</PL_parser> et al) is correctly set to reflect the source of
11277 the code to be parsed and the lexical context for the expression.
11279 The op tree representing the expression is returned. If an optional
11280 expression is absent, a null pointer is returned, otherwise the pointer
11283 If an error occurs in parsing or compilation, in most cases a valid op
11284 tree is returned anyway. The error is reflected in the parser state,
11285 normally resulting in a single exception at the top level of parsing
11286 which covers all the compilation errors that occurred. Some compilation
11287 errors, however, will throw an exception immediately.
11293 Perl_parse_fullexpr(pTHX_ U32 flags)
11295 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11299 =for apidoc Amx|OP *|parse_block|U32 flags
11301 Parse a single complete Perl code block. This consists of an opening
11302 brace, a sequence of statements, and a closing brace. The block
11303 constitutes a lexical scope, so C<my> variables and various compile-time
11304 effects can be contained within it. It is up to the caller to ensure
11305 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11306 reflect the source of the code to be parsed and the lexical context for
11309 The op tree representing the code block is returned. This is always a
11310 real op, never a null pointer. It will normally be a C<lineseq> list,
11311 including C<nextstate> or equivalent ops. No ops to construct any kind
11312 of runtime scope are included by virtue of it being a block.
11314 If an error occurs in parsing or compilation, in most cases a valid op
11315 tree (most likely null) is returned anyway. The error is reflected in
11316 the parser state, normally resulting in a single exception at the top
11317 level of parsing which covers all the compilation errors that occurred.
11318 Some compilation errors, however, will throw an exception immediately.
11320 The I<flags> parameter is reserved for future use, and must always
11327 Perl_parse_block(pTHX_ U32 flags)
11330 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11331 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11335 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11337 Parse a single unadorned Perl statement. This may be a normal imperative
11338 statement or a declaration that has compile-time effect. It does not
11339 include any label or other affixture. It is up to the caller to ensure
11340 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11341 reflect the source of the code to be parsed and the lexical context for
11344 The op tree representing the statement is returned. This may be a
11345 null pointer if the statement is null, for example if it was actually
11346 a subroutine definition (which has compile-time side effects). If not
11347 null, it will be ops directly implementing the statement, suitable to
11348 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11349 equivalent op (except for those embedded in a scope contained entirely
11350 within the statement).
11352 If an error occurs in parsing or compilation, in most cases a valid op
11353 tree (most likely null) is returned anyway. The error is reflected in
11354 the parser state, normally resulting in a single exception at the top
11355 level of parsing which covers all the compilation errors that occurred.
11356 Some compilation errors, however, will throw an exception immediately.
11358 The I<flags> parameter is reserved for future use, and must always
11365 Perl_parse_barestmt(pTHX_ U32 flags)
11368 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11369 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11373 =for apidoc Amx|SV *|parse_label|U32 flags
11375 Parse a single label, possibly optional, of the type that may prefix a
11376 Perl statement. It is up to the caller to ensure that the dynamic parser
11377 state (L</PL_parser> et al) is correctly set to reflect the source of
11378 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11379 label is optional, otherwise it is mandatory.
11381 The name of the label is returned in the form of a fresh scalar. If an
11382 optional label is absent, a null pointer is returned.
11384 If an error occurs in parsing, which can only occur if the label is
11385 mandatory, a valid label is returned anyway. The error is reflected in
11386 the parser state, normally resulting in a single exception at the top
11387 level of parsing which covers all the compilation errors that occurred.
11393 Perl_parse_label(pTHX_ U32 flags)
11395 if (flags & ~PARSE_OPTIONAL)
11396 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11397 if (PL_lex_state == LEX_KNOWNEXT) {
11398 PL_parser->yychar = yylex();
11399 if (PL_parser->yychar == LABEL) {
11400 char * const lpv = pl_yylval.pval;
11401 STRLEN llen = strlen(lpv);
11402 PL_parser->yychar = YYEMPTY;
11403 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11410 STRLEN wlen, bufptr_pos;
11413 if (!isIDFIRST_lazy_if(s, UTF))
11415 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11416 if (word_takes_any_delimeter(s, wlen))
11418 bufptr_pos = s - SvPVX(PL_linestr);
11420 lex_read_space(LEX_KEEP_PREVIOUS);
11422 s = SvPVX(PL_linestr) + bufptr_pos;
11423 if (t[0] == ':' && t[1] != ':') {
11424 PL_oldoldbufptr = PL_oldbufptr;
11427 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11431 if (flags & PARSE_OPTIONAL) {
11434 qerror(Perl_mess(aTHX_ "Parse error"));
11435 return newSVpvs("x");
11442 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11444 Parse a single complete Perl statement. This may be a normal imperative
11445 statement or a declaration that has compile-time effect, and may include
11446 optional labels. It is up to the caller to ensure that the dynamic
11447 parser state (L</PL_parser> et al) is correctly set to reflect the source
11448 of the code to be parsed and the lexical context for the statement.
11450 The op tree representing the statement is returned. This may be a
11451 null pointer if the statement is null, for example if it was actually
11452 a subroutine definition (which has compile-time side effects). If not
11453 null, it will be the result of a L</newSTATEOP> call, normally including
11454 a C<nextstate> or equivalent op.
11456 If an error occurs in parsing or compilation, in most cases a valid op
11457 tree (most likely null) is returned anyway. The error is reflected in
11458 the parser state, normally resulting in a single exception at the top
11459 level of parsing which covers all the compilation errors that occurred.
11460 Some compilation errors, however, will throw an exception immediately.
11462 The I<flags> parameter is reserved for future use, and must always
11469 Perl_parse_fullstmt(pTHX_ U32 flags)
11472 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11473 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11477 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11479 Parse a sequence of zero or more Perl statements. These may be normal
11480 imperative statements, including optional labels, or declarations
11481 that have compile-time effect, or any mixture thereof. The statement
11482 sequence ends when a closing brace or end-of-file is encountered in a
11483 place where a new statement could have validly started. It is up to
11484 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11485 is correctly set to reflect the source of the code to be parsed and the
11486 lexical context for the statements.
11488 The op tree representing the statement sequence is returned. This may
11489 be a null pointer if the statements were all null, for example if there
11490 were no statements or if there were only subroutine definitions (which
11491 have compile-time side effects). If not null, it will be a C<lineseq>
11492 list, normally including C<nextstate> or equivalent ops.
11494 If an error occurs in parsing or compilation, in most cases a valid op
11495 tree is returned anyway. The error is reflected in the parser state,
11496 normally resulting in a single exception at the top level of parsing
11497 which covers all the compilation errors that occurred. Some compilation
11498 errors, however, will throw an exception immediately.
11500 The I<flags> parameter is reserved for future use, and must always
11507 Perl_parse_stmtseq(pTHX_ U32 flags)
11512 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11513 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11514 c = lex_peek_unichar(0);
11515 if (c != -1 && c != /*{*/'}')
11516 qerror(Perl_mess(aTHX_ "Parse error"));
11520 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11522 S_lex_token_boundary(pTHX)
11524 PL_oldoldbufptr = PL_oldbufptr;
11525 PL_oldbufptr = PL_bufptr;
11528 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11530 S_parse_opt_lexvar(pTHX)
11535 lex_token_boundary();
11536 sigil = lex_read_unichar(0);
11537 if (lex_peek_unichar(0) == '#') {
11538 qerror(Perl_mess(aTHX_ "Parse error"));
11542 c = lex_peek_unichar(0);
11543 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11546 d = PL_tokenbuf + 1;
11547 PL_tokenbuf[0] = (char)sigil;
11548 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11550 if (d == PL_tokenbuf+1)
11552 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11553 OPf_MOD | (OPpLVAL_INTRO<<8));
11554 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11559 Perl_parse_subsignature(pTHX)
11562 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11563 OP *initops = NULL;
11565 c = lex_peek_unichar(0);
11566 while (c != /*(*/')') {
11570 if (prev_type == 2)
11571 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11572 var = parse_opt_lexvar();
11574 newBINOP(OP_AELEM, 0,
11575 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11577 newSVOP(OP_CONST, 0, newSViv(pos))) :
11580 c = lex_peek_unichar(0);
11582 lex_token_boundary();
11583 lex_read_unichar(0);
11585 c = lex_peek_unichar(0);
11586 if (c == ',' || c == /*(*/')') {
11588 qerror(Perl_mess(aTHX_ "Optional parameter "
11589 "lacks default expression"));
11591 OP *defexpr = parse_termexpr(0);
11592 if (defexpr->op_type == OP_UNDEF &&
11593 !(defexpr->op_flags & OPf_KIDS)) {
11598 scalar(newUNOP(OP_RV2AV, 0,
11599 newGVOP(OP_GV, 0, PL_defgv))),
11600 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11602 newCONDOP(0, ifop, expr, defexpr) :
11603 newLOGOP(OP_OR, 0, ifop, defexpr);
11608 if (prev_type == 1)
11609 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11610 "follows optional parameter"));
11612 min_arity = pos + 1;
11614 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11616 initops = op_append_list(OP_LINESEQ, initops,
11617 newSTATEOP(0, NULL, expr));
11623 if (prev_type == 2)
11624 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11625 var = parse_opt_lexvar();
11627 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11628 newBINOP(OP_BIT_AND, 0,
11629 scalar(newUNOP(OP_RV2AV, 0,
11630 newGVOP(OP_GV, 0, PL_defgv))),
11631 newSVOP(OP_CONST, 0, newSViv(1))),
11632 op_convert_list(OP_DIE, 0,
11633 op_convert_list(OP_SPRINTF, 0,
11634 op_append_list(OP_LIST,
11635 newSVOP(OP_CONST, 0,
11636 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11638 op_append_list(OP_LIST,
11639 newSVOP(OP_CONST, 0, newSViv(1)),
11640 newSVOP(OP_CONST, 0, newSViv(2))),
11641 newOP(OP_CALLER, 0))))));
11642 if (pos != min_arity)
11643 chkop = newLOGOP(OP_AND, 0,
11645 scalar(newUNOP(OP_RV2AV, 0,
11646 newGVOP(OP_GV, 0, PL_defgv))),
11647 newSVOP(OP_CONST, 0, newSViv(pos))),
11649 initops = op_append_list(OP_LINESEQ,
11650 newSTATEOP(0, NULL, chkop),
11655 op_prepend_elem(OP_ASLICE,
11656 newOP(OP_PUSHMARK, 0),
11657 newLISTOP(OP_ASLICE, 0,
11659 newSVOP(OP_CONST, 0, newSViv(pos)),
11660 newUNOP(OP_AV2ARYLEN, 0,
11661 ref(newUNOP(OP_RV2AV, 0,
11662 newGVOP(OP_GV, 0, PL_defgv)),
11664 ref(newUNOP(OP_RV2AV, 0,
11665 newGVOP(OP_GV, 0, PL_defgv)),
11667 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11668 initops = op_append_list(OP_LINESEQ, initops,
11669 newSTATEOP(0, NULL,
11670 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11677 qerror(Perl_mess(aTHX_ "Parse error"));
11681 c = lex_peek_unichar(0);
11683 case /*(*/')': break;
11686 lex_token_boundary();
11687 lex_read_unichar(0);
11689 c = lex_peek_unichar(0);
11690 } while (c == ',');
11696 if (min_arity != 0) {
11697 initops = op_append_list(OP_LINESEQ,
11698 newSTATEOP(0, NULL,
11701 scalar(newUNOP(OP_RV2AV, 0,
11702 newGVOP(OP_GV, 0, PL_defgv))),
11703 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11704 op_convert_list(OP_DIE, 0,
11705 op_convert_list(OP_SPRINTF, 0,
11706 op_append_list(OP_LIST,
11707 newSVOP(OP_CONST, 0,
11708 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11710 op_append_list(OP_LIST,
11711 newSVOP(OP_CONST, 0, newSViv(1)),
11712 newSVOP(OP_CONST, 0, newSViv(2))),
11713 newOP(OP_CALLER, 0))))))),
11716 if (max_arity != -1) {
11717 initops = op_append_list(OP_LINESEQ,
11718 newSTATEOP(0, NULL,
11721 scalar(newUNOP(OP_RV2AV, 0,
11722 newGVOP(OP_GV, 0, PL_defgv))),
11723 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11724 op_convert_list(OP_DIE, 0,
11725 op_convert_list(OP_SPRINTF, 0,
11726 op_append_list(OP_LIST,
11727 newSVOP(OP_CONST, 0,
11728 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11730 op_append_list(OP_LIST,
11731 newSVOP(OP_CONST, 0, newSViv(1)),
11732 newSVOP(OP_CONST, 0, newSViv(2))),
11733 newOP(OP_CALLER, 0))))))),
11740 * ex: set ts=8 sts=4 sw=4 et: