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 == '-')
1844 s += UTF ? UTF8SKIP(s) : 1;
1845 if ((t = strchr(s, '(')) && t < PL_bufptr)
1848 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1849 "Warning: Use of \"%"UTF8f"\" without parentheses is ambiguous",
1850 UTF8fARG(UTF, (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 SAVEI8(PL_lex_defer);
2346 SAVESPTR(PL_lex_repl);
2347 SAVEVPTR(PL_lex_inpat);
2348 SAVEI16(PL_lex_inwhat);
2351 SAVECOPLINE(PL_curcop);
2352 SAVEI32(PL_multi_end);
2353 SAVEI32(PL_parser->herelines);
2354 PL_parser->herelines = 0;
2356 SAVEI8(PL_multi_close);
2357 SAVEPPTR(PL_bufptr);
2358 SAVEPPTR(PL_bufend);
2359 SAVEPPTR(PL_oldbufptr);
2360 SAVEPPTR(PL_oldoldbufptr);
2361 SAVEPPTR(PL_last_lop);
2362 SAVEPPTR(PL_last_uni);
2363 SAVEPPTR(PL_linestart);
2364 SAVESPTR(PL_linestr);
2365 SAVEGENERICPV(PL_lex_brackstack);
2366 SAVEGENERICPV(PL_lex_casestack);
2367 SAVEGENERICPV(PL_parser->lex_shared);
2368 SAVEBOOL(PL_parser->lex_re_reparsing);
2369 SAVEI32(PL_copline);
2371 /* The here-doc parser needs to be able to peek into outer lexing
2372 scopes to find the body of the here-doc. So we put PL_linestr and
2373 PL_bufptr into lex_shared, to ‘share’ those values.
2375 PL_parser->lex_shared->ls_linestr = PL_linestr;
2376 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2378 PL_linestr = PL_lex_stuff;
2379 PL_lex_repl = PL_sublex_info.repl;
2380 PL_lex_stuff = NULL;
2381 PL_sublex_info.repl = NULL;
2383 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2384 set for an inner quote-like operator and then an error causes scope-
2385 popping. We must not have a PL_lex_stuff value left dangling, as
2386 that breaks assumptions elsewhere. See bug #123617. */
2387 SAVEGENERICSV(PL_lex_stuff);
2388 SAVEGENERICSV(PL_sublex_info.repl);
2390 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2391 = SvPVX(PL_linestr);
2392 PL_bufend += SvCUR(PL_linestr);
2393 PL_last_lop = PL_last_uni = NULL;
2394 SAVEFREESV(PL_linestr);
2395 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2397 PL_lex_dojoin = FALSE;
2398 PL_lex_brackets = PL_lex_formbrack = 0;
2399 PL_lex_allbrackets = 0;
2400 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2401 Newx(PL_lex_brackstack, 120, char);
2402 Newx(PL_lex_casestack, 12, char);
2403 PL_lex_casemods = 0;
2404 *PL_lex_casestack = '\0';
2406 PL_lex_state = LEX_INTERPCONCAT;
2408 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2409 PL_copline = NOLINE;
2411 Newxz(shared, 1, LEXSHARED);
2412 shared->ls_prev = PL_parser->lex_shared;
2413 PL_parser->lex_shared = shared;
2415 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2416 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2417 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2418 PL_lex_inpat = PL_sublex_info.sub_op;
2420 PL_lex_inpat = NULL;
2422 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2423 PL_in_eval &= ~EVAL_RE_REPARSING;
2430 * Restores lexer state after a S_sublex_push.
2436 if (!PL_lex_starts++) {
2437 SV * const sv = newSVpvs("");
2438 if (SvUTF8(PL_linestr))
2440 PL_expect = XOPERATOR;
2441 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2445 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2446 PL_lex_state = LEX_INTERPCASEMOD;
2450 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2451 assert(PL_lex_inwhat != OP_TRANSR);
2453 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2454 PL_linestr = PL_lex_repl;
2456 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2457 PL_bufend += SvCUR(PL_linestr);
2458 PL_last_lop = PL_last_uni = NULL;
2459 PL_lex_dojoin = FALSE;
2460 PL_lex_brackets = 0;
2461 PL_lex_allbrackets = 0;
2462 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2463 PL_lex_casemods = 0;
2464 *PL_lex_casestack = '\0';
2466 if (SvEVALED(PL_lex_repl)) {
2467 PL_lex_state = LEX_INTERPNORMAL;
2469 /* we don't clear PL_lex_repl here, so that we can check later
2470 whether this is an evalled subst; that means we rely on the
2471 logic to ensure sublex_done() is called again only via the
2472 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2475 PL_lex_state = LEX_INTERPCONCAT;
2478 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2479 CopLINE(PL_curcop) +=
2480 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2481 + PL_parser->herelines;
2482 PL_parser->herelines = 0;
2487 const line_t l = CopLINE(PL_curcop);
2489 if (PL_multi_close == '<')
2490 PL_parser->herelines += l - PL_multi_end;
2491 PL_bufend = SvPVX(PL_linestr);
2492 PL_bufend += SvCUR(PL_linestr);
2493 PL_expect = XOPERATOR;
2498 PERL_STATIC_INLINE SV*
2499 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2501 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2502 * interior, hence to the "}". Finds what the name resolves to, returning
2503 * an SV* containing it; NULL if no valid one found */
2505 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2512 const U8* first_bad_char_loc;
2513 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2515 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2520 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2522 &first_bad_char_loc))
2524 /* If warnings are on, this will print a more detailed analysis of what
2525 * is wrong than the error message below */
2526 utf8n_to_uvchr(first_bad_char_loc,
2527 e - ((char *) first_bad_char_loc),
2530 /* We deliberately don't try to print the malformed character, which
2531 * might not print very well; it also may be just the first of many
2532 * malformations, so don't print what comes after it */
2533 yyerror_pv(Perl_form(aTHX_
2534 "Malformed UTF-8 character immediately after '%.*s'",
2535 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2540 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2541 /* include the <}> */
2542 e - backslash_ptr + 1);
2544 SvREFCNT_dec_NN(res);
2548 /* See if the charnames handler is the Perl core's, and if so, we can skip
2549 * the validation needed for a user-supplied one, as Perl's does its own
2551 table = GvHV(PL_hintgv); /* ^H */
2552 cvp = hv_fetchs(table, "charnames", FALSE);
2553 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2554 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2556 const char * const name = HvNAME(stash);
2557 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2558 && strEQ(name, "_charnames")) {
2563 /* Here, it isn't Perl's charname handler. We can't rely on a
2564 * user-supplied handler to validate the input name. For non-ut8 input,
2565 * look to see that the first character is legal. Then loop through the
2566 * rest checking that each is a continuation */
2568 /* This code makes the reasonable assumption that the only Latin1-range
2569 * characters that begin a character name alias are alphabetic, otherwise
2570 * would have to create a isCHARNAME_BEGIN macro */
2573 if (! isALPHAU(*s)) {
2578 if (! isCHARNAME_CONT(*s)) {
2581 if (*s == ' ' && *(s-1) == ' ') {
2584 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2585 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2586 "NO-BREAK SPACE in a charnames "
2587 "alias definition is deprecated");
2593 /* Similarly for utf8. For invariants can check directly; for other
2594 * Latin1, can calculate their code point and check; otherwise use a
2596 if (UTF8_IS_INVARIANT(*s)) {
2597 if (! isALPHAU(*s)) {
2601 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2602 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2608 if (! PL_utf8_charname_begin) {
2609 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2610 PL_utf8_charname_begin = _core_swash_init("utf8",
2611 "_Perl_Charname_Begin",
2613 1, 0, NULL, &flags);
2615 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2622 if (UTF8_IS_INVARIANT(*s)) {
2623 if (! isCHARNAME_CONT(*s)) {
2626 if (*s == ' ' && *(s-1) == ' ') {
2631 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2632 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2636 if (*s == *NBSP_UTF8
2637 && *(s+1) == *(NBSP_UTF8+1)
2638 && ckWARN_d(WARN_DEPRECATED))
2640 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2641 "NO-BREAK SPACE in a charnames "
2642 "alias definition is deprecated");
2647 if (! PL_utf8_charname_continue) {
2648 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2649 PL_utf8_charname_continue = _core_swash_init("utf8",
2650 "_Perl_Charname_Continue",
2652 1, 0, NULL, &flags);
2654 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2661 if (*(s-1) == ' ') {
2664 "charnames alias definitions may not contain trailing "
2665 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2666 (int)(s - backslash_ptr + 1), backslash_ptr,
2667 (int)(e - s + 1), s + 1
2669 UTF ? SVf_UTF8 : 0);
2673 if (SvUTF8(res)) { /* Don't accept malformed input */
2674 const U8* first_bad_char_loc;
2676 const char* const str = SvPV_const(res, len);
2677 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2678 /* If warnings are on, this will print a more detailed analysis of
2679 * what is wrong than the error message below */
2680 utf8n_to_uvchr(first_bad_char_loc,
2681 (char *) first_bad_char_loc - str,
2684 /* We deliberately don't try to print the malformed character,
2685 * which might not print very well; it also may be just the first
2686 * of many malformations, so don't print what comes after it */
2689 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2690 (int) (e - backslash_ptr + 1), backslash_ptr,
2691 (int) ((char *) first_bad_char_loc - str), str
2702 /* The final %.*s makes sure that should the trailing NUL be missing
2703 * that this print won't run off the end of the string */
2706 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2707 (int)(s - backslash_ptr + 1), backslash_ptr,
2708 (int)(e - s + 1), s + 1
2710 UTF ? SVf_UTF8 : 0);
2717 "charnames alias definitions may not contain a sequence of "
2718 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2719 (int)(s - backslash_ptr + 1), backslash_ptr,
2720 (int)(e - s + 1), s + 1
2722 UTF ? SVf_UTF8 : 0);
2729 Extracts the next constant part of a pattern, double-quoted string,
2730 or transliteration. This is terrifying code.
2732 For example, in parsing the double-quoted string "ab\x63$d", it would
2733 stop at the '$' and return an OP_CONST containing 'abc'.
2735 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2736 processing a pattern (PL_lex_inpat is true), a transliteration
2737 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2739 Returns a pointer to the character scanned up to. If this is
2740 advanced from the start pointer supplied (i.e. if anything was
2741 successfully parsed), will leave an OP_CONST for the substring scanned
2742 in pl_yylval. Caller must intuit reason for not parsing further
2743 by looking at the next characters herself.
2747 \N{FOO} => \N{U+hex_for_character_FOO}
2748 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2751 all other \-char, including \N and \N{ apart from \N{ABC}
2754 @ and $ where it appears to be a var, but not for $ as tail anchor
2759 In transliterations:
2760 characters are VERY literal, except for - not at the start or end
2761 of the string, which indicates a range. If the range is in bytes,
2762 scan_const expands the range to the full set of intermediate
2763 characters. If the range is in utf8, the hyphen is replaced with
2764 a certain range mark which will be handled by pmtrans() in op.c.
2766 In double-quoted strings:
2768 double-quoted style: \r and \n
2769 constants: \x31, etc.
2770 deprecated backrefs: \1 (in substitution replacements)
2771 case and quoting: \U \Q \E
2774 scan_const does *not* construct ops to handle interpolated strings.
2775 It stops processing as soon as it finds an embedded $ or @ variable
2776 and leaves it to the caller to work out what's going on.
2778 embedded arrays (whether in pattern or not) could be:
2779 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2781 $ in double-quoted strings must be the symbol of an embedded scalar.
2783 $ in pattern could be $foo or could be tail anchor. Assumption:
2784 it's a tail anchor if $ is the last thing in the string, or if it's
2785 followed by one of "()| \r\n\t"
2787 \1 (backreferences) are turned into $1 in substitutions
2789 The structure of the code is
2790 while (there's a character to process) {
2791 handle transliteration ranges
2792 skip regexp comments /(?#comment)/ and codes /(?{code})/
2793 skip #-initiated comments in //x patterns
2794 check for embedded arrays
2795 check for embedded scalars
2797 deprecate \1 in substitution replacements
2798 handle string-changing backslashes \l \U \Q \E, etc.
2799 switch (what was escaped) {
2800 handle \- in a transliteration (becomes a literal -)
2801 if a pattern and not \N{, go treat as regular character
2802 handle \132 (octal characters)
2803 handle \x15 and \x{1234} (hex characters)
2804 handle \N{name} (named characters, also \N{3,5} in a pattern)
2805 handle \cV (control characters)
2806 handle printf-style backslashes (\f, \r, \n, etc)
2809 } (end if backslash)
2810 handle regular character
2811 } (end while character to read)
2816 S_scan_const(pTHX_ char *start)
2818 char *send = PL_bufend; /* end of the constant */
2819 SV *sv = newSV(send - start); /* sv for the constant. See note below
2821 char *s = start; /* start of the constant */
2822 char *d = SvPVX(sv); /* destination for copies */
2823 bool dorange = FALSE; /* are we in a translit range? */
2824 bool didrange = FALSE; /* did we just finish a range? */
2825 bool in_charclass = FALSE; /* within /[...]/ */
2826 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2827 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2828 UTF8? But, this can show as true
2829 when the source isn't utf8, as for
2830 example when it is entirely composed
2832 SV *res; /* result from charnames */
2834 /* Note on sizing: The scanned constant is placed into sv, which is
2835 * initialized by newSV() assuming one byte of output for every byte of
2836 * input. This routine expects newSV() to allocate an extra byte for a
2837 * trailing NUL, which this routine will append if it gets to the end of
2838 * the input. There may be more bytes of input than output (eg., \N{LATIN
2839 * CAPITAL LETTER A}), or more output than input if the constant ends up
2840 * recoded to utf8, but each time a construct is found that might increase
2841 * the needed size, SvGROW() is called. Its size parameter each time is
2842 * based on the best guess estimate at the time, namely the length used so
2843 * far, plus the length the current construct will occupy, plus room for
2844 * the trailing NUL, plus one byte for every input byte still unscanned */
2846 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2849 UV literal_endpoint = 0;
2850 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2853 PERL_ARGS_ASSERT_SCAN_CONST;
2855 assert(PL_lex_inwhat != OP_TRANSR);
2856 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2857 /* If we are doing a trans and we know we want UTF8 set expectation */
2858 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2859 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2862 /* Protect sv from errors and fatal warnings. */
2863 ENTER_with_name("scan_const");
2866 while (s < send || dorange) {
2868 /* get transliterations out of the way (they're most literal) */
2869 if (PL_lex_inwhat == OP_TRANS) {
2870 /* expand a range A-Z to the full set of characters. AIE! */
2872 I32 i; /* current expanded character */
2873 I32 min; /* first character in range */
2874 I32 max; /* last character in range */
2885 char * const c = (char*)utf8_hop((U8*)d, -1);
2889 *c = (char) ILLEGAL_UTF8_BYTE;
2890 /* mark the range as done, and continue */
2896 i = d - SvPVX_const(sv); /* remember current offset */
2899 SvLEN(sv) + ((has_utf8)
2900 ? (512 - UTF_CONTINUATION_MARK
2903 /* How many two-byte within 0..255: 128 in UTF-8,
2904 * 96 in UTF-8-mod. */
2906 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2908 d = SvPVX(sv) + i; /* refresh d after realloc */
2912 for (j = 0; j <= 1; j++) {
2913 char * const c = (char*)utf8_hop((U8*)d, -1);
2914 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2920 max = (U8)0xff; /* only to \xff */
2921 uvmax = uv; /* \x{100} to uvmax */
2923 d = c; /* eat endpoint chars */
2928 d -= 2; /* eat the first char and the - */
2929 min = (U8)*d; /* first char in range */
2930 max = (U8)d[1]; /* last char in range */
2937 "Invalid range \"%c-%c\" in transliteration operator",
2938 (char)min, (char)max);
2942 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2943 * any subsets of these ranges into individual characters */
2944 if (literal_endpoint == 2 &&
2945 ((isLOWER_A(min) && isLOWER_A(max)) ||
2946 (isUPPER_A(min) && isUPPER_A(max))))
2948 for (i = min; i <= max; i++) {
2955 for (i = min; i <= max; i++)
2958 append_utf8_from_native_byte(i, &d);
2966 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2968 *d++ = (char) ILLEGAL_UTF8_BYTE;
2970 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2974 /* mark the range as done, and continue */
2978 literal_endpoint = 0;
2983 /* range begins (ignore - as first or last char) */
2984 else if (*s == '-' && s+1 < send && s != start) {
2986 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2993 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
3003 literal_endpoint = 0;
3004 native_range = TRUE;
3009 /* if we get here, we're not doing a transliteration */
3011 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3014 while (s1 >= start && *s1-- == '\\')
3017 in_charclass = TRUE;
3020 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3023 while (s1 >= start && *s1-- == '\\')
3026 in_charclass = FALSE;
3029 /* skip for regexp comments /(?#comment)/, except for the last
3030 * char, which will be done separately.
3031 * Stop on (?{..}) and friends */
3033 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3035 while (s+1 < send && *s != ')')
3038 else if (!PL_lex_casemods &&
3039 ( s[2] == '{' /* This should match regcomp.c */
3040 || (s[2] == '?' && s[3] == '{')))
3046 /* likewise skip #-initiated comments in //x patterns */
3047 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3048 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3049 while (s+1 < send && *s != '\n')
3053 /* no further processing of single-quoted regex */
3054 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3055 goto default_action;
3057 /* check for embedded arrays
3058 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3060 else if (*s == '@' && s[1]) {
3061 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3063 if (strchr(":'{$", s[1]))
3065 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3066 break; /* in regexp, neither @+ nor @- are interpolated */
3069 /* check for embedded scalars. only stop if we're sure it's a
3072 else if (*s == '$') {
3073 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3075 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3077 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3078 "Possible unintended interpolation of $\\ in regex");
3080 break; /* in regexp, $ might be tail anchor */
3084 /* End of else if chain - OP_TRANS rejoin rest */
3087 if (*s == '\\' && s+1 < send) {
3088 char* e; /* Can be used for ending '}', etc. */
3092 /* warn on \1 - \9 in substitution replacements, but note that \11
3093 * is an octal; and \19 is \1 followed by '9' */
3094 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3095 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3097 /* diag_listed_as: \%d better written as $%d */
3098 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3103 /* string-change backslash escapes */
3104 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3108 /* In a pattern, process \N, but skip any other backslash escapes.
3109 * This is because we don't want to translate an escape sequence
3110 * into a meta symbol and have the regex compiler use the meta
3111 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3112 * in spite of this, we do have to process \N here while the proper
3113 * charnames handler is in scope. See bugs #56444 and #62056.
3115 * There is a complication because \N in a pattern may also stand
3116 * for 'match a non-nl', and not mean a charname, in which case its
3117 * processing should be deferred to the regex compiler. To be a
3118 * charname it must be followed immediately by a '{', and not look
3119 * like \N followed by a curly quantifier, i.e., not something like
3120 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3122 else if (PL_lex_inpat
3125 || regcurly(s + 1)))
3128 goto default_action;
3133 /* quoted - in transliterations */
3135 if (PL_lex_inwhat == OP_TRANS) {
3142 if ((isALPHANUMERIC(*s)))
3143 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3144 "Unrecognized escape \\%c passed through",
3146 /* default action is to copy the quoted character */
3147 goto default_action;
3150 /* eg. \132 indicates the octal constant 0132 */
3151 case '0': case '1': case '2': case '3':
3152 case '4': case '5': case '6': case '7':
3154 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3156 uv = grok_oct(s, &len, &flags, NULL);
3158 if (len < 3 && s < send && isDIGIT(*s)
3159 && ckWARN(WARN_MISC))
3161 Perl_warner(aTHX_ packWARN(WARN_MISC),
3162 "%s", form_short_octal_warning(s, len));
3165 goto NUM_ESCAPE_INSERT;
3167 /* eg. \o{24} indicates the octal constant \024 */
3172 bool valid = grok_bslash_o(&s, &uv, &error,
3173 TRUE, /* Output warning */
3174 FALSE, /* Not strict */
3175 TRUE, /* Output warnings for
3182 goto NUM_ESCAPE_INSERT;
3185 /* eg. \x24 indicates the hex constant 0x24 */
3190 bool valid = grok_bslash_x(&s, &uv, &error,
3191 TRUE, /* Output warning */
3192 FALSE, /* Not strict */
3193 TRUE, /* Output warnings for
3203 /* Insert oct or hex escaped character. There will always be
3204 * enough room in sv since such escapes will be longer than any
3205 * UTF-8 sequence they can end up as, except if they force us
3206 * to recode the rest of the string into utf8 */
3208 /* Here uv is the ordinal of the next character being added */
3209 if (!UVCHR_IS_INVARIANT(uv)) {
3210 if (!has_utf8 && uv > 255) {
3211 /* Might need to recode whatever we have accumulated so
3212 * far if it contains any chars variant in utf8 or
3215 SvCUR_set(sv, d - SvPVX_const(sv));
3218 /* See Note on sizing above. */
3219 sv_utf8_upgrade_flags_grow(
3221 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3222 /* Above-latin1 in string
3223 * implies no encoding */
3224 |SV_UTF8_NO_ENCODING,
3225 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3226 d = SvPVX(sv) + SvCUR(sv);
3231 d = (char*)uvchr_to_utf8((U8*)d, uv);
3232 if (PL_lex_inwhat == OP_TRANS &&
3233 PL_sublex_info.sub_op) {
3234 PL_sublex_info.sub_op->op_private |=
3235 (PL_lex_repl ? OPpTRANS_FROM_UTF
3239 if (uv > 255 && !dorange)
3240 native_range = FALSE;
3253 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3254 * named character, like \N{LATIN SMALL LETTER A}, or a named
3255 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3256 * GRAVE}. For convenience all three forms are referred to as
3257 * "named characters" below.
3259 * For patterns, \N also can mean to match a non-newline. Code
3260 * before this 'switch' statement should already have handled
3261 * this situation, and hence this code only has to deal with
3262 * the named character cases.
3264 * For non-patterns, the named characters are converted to
3265 * their string equivalents. In patterns, named characters are
3266 * not converted to their ultimate forms for the same reasons
3267 * that other escapes aren't. Instead, they are converted to
3268 * the \N{U+...} form to get the value from the charnames that
3269 * is in effect right now, while preserving the fact that it
3270 * was a named character, so that the regex compiler knows
3273 * The structure of this section of code (besides checking for
3274 * errors and upgrading to utf8) is:
3275 * If the named character is of the form \N{U+...}, pass it
3276 * through if a pattern; otherwise convert the code point
3278 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3279 * if a pattern; otherwise convert to utf8
3281 * Here, 's' points to the 'N'; the test below is guaranteed to
3282 * succeed if we are being called on a pattern, as we already
3283 * know from a test above that the next character is a '{'. A
3284 * non-pattern \N must mean 'named character', which requires
3288 yyerror("Missing braces on \\N{}");
3293 /* If there is no matching '}', it is an error. */
3294 if (! (e = strchr(s, '}'))) {
3295 if (! PL_lex_inpat) {
3296 yyerror("Missing right brace on \\N{}");
3298 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3303 /* Here it looks like a named character */
3305 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3306 s += 2; /* Skip to next char after the 'U+' */
3309 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3310 /* Check the syntax. */
3313 if (!isXDIGIT(*s)) {
3316 "Invalid hexadecimal number in \\N{U+...}"
3324 else if ((*s == '.' || *s == '_')
3330 /* Pass everything through unchanged.
3331 * +1 is for the '}' */
3332 Copy(orig_s, d, e - orig_s + 1, char);
3333 d += e - orig_s + 1;
3335 else { /* Not a pattern: convert the hex to string */
3336 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3337 | PERL_SCAN_SILENT_ILLDIGIT
3338 | PERL_SCAN_DISALLOW_PREFIX;
3340 uv = grok_hex(s, &len, &flags, NULL);
3341 if (len == 0 || (len != (STRLEN)(e - s)))
3344 /* If the destination is not in utf8, unconditionally
3345 * recode it to be so. This is because \N{} implies
3346 * Unicode semantics, and scalars have to be in utf8
3347 * to guarantee those semantics */
3349 SvCUR_set(sv, d - SvPVX_const(sv));
3352 /* See Note on sizing above. */
3353 sv_utf8_upgrade_flags_grow(
3355 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3356 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3357 d = SvPVX(sv) + SvCUR(sv);
3361 /* Add the (Unicode) code point to the output. */
3362 if (UNI_IS_INVARIANT(uv)) {
3363 *d++ = (char) LATIN1_TO_NATIVE(uv);
3366 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3370 else /* Here is \N{NAME} but not \N{U+...}. */
3371 if ((res = get_and_check_backslash_N_name(s, e)))
3374 const char *str = SvPV_const(res, len);
3377 if (! len) { /* The name resolved to an empty string */
3378 Copy("\\N{}", d, 4, char);
3382 /* In order to not lose information for the regex
3383 * compiler, pass the result in the specially made
3384 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3385 * the code points in hex of each character
3386 * returned by charnames */
3388 const char *str_end = str + len;
3389 const STRLEN off = d - SvPVX_const(sv);
3391 if (! SvUTF8(res)) {
3392 /* For the non-UTF-8 case, we can determine the
3393 * exact length needed without having to parse
3394 * through the string. Each character takes up
3395 * 2 hex digits plus either a trailing dot or
3397 const char initial_text[] = "\\N{U+";
3398 const STRLEN initial_len = sizeof(initial_text)
3400 d = off + SvGROW(sv, off
3403 /* +1 for trailing NUL */
3406 + (STRLEN)(send - e));
3407 Copy(initial_text, d, initial_len, char);
3409 while (str < str_end) {
3412 my_snprintf(hex_string,
3416 /* The regex compiler is
3417 * expecting Unicode, not
3419 (U8) NATIVE_TO_LATIN1(*str));
3420 PERL_MY_SNPRINTF_POST_GUARD(len,
3421 sizeof(hex_string));
3422 Copy(hex_string, d, 3, char);
3426 d--; /* Below, we will overwrite the final
3427 dot with a right brace */
3430 STRLEN char_length; /* cur char's byte length */
3432 /* and the number of bytes after this is
3433 * translated into hex digits */
3434 STRLEN output_length;
3436 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3437 * for max('U+', '.'); and 1 for NUL */
3438 char hex_string[2 * UTF8_MAXBYTES + 5];
3440 /* Get the first character of the result. */
3441 U32 uv = utf8n_to_uvchr((U8 *) str,
3445 /* Convert first code point to Unicode hex,
3446 * including the boiler plate before it. */
3448 my_snprintf(hex_string, sizeof(hex_string),
3450 (unsigned int) NATIVE_TO_UNI(uv));
3452 /* Make sure there is enough space to hold it */
3453 d = off + SvGROW(sv, off
3455 + (STRLEN)(send - e)
3456 + 2); /* '}' + NUL */
3458 Copy(hex_string, d, output_length, char);
3461 /* For each subsequent character, append dot and
3462 * its Unicode code point in hex */
3463 while ((str += char_length) < str_end) {
3464 const STRLEN off = d - SvPVX_const(sv);
3465 U32 uv = utf8n_to_uvchr((U8 *) str,
3470 my_snprintf(hex_string,
3473 (unsigned int) NATIVE_TO_UNI(uv));
3475 d = off + SvGROW(sv, off
3477 + (STRLEN)(send - e)
3478 + 2); /* '}' + NUL */
3479 Copy(hex_string, d, output_length, char);
3484 *d++ = '}'; /* Done. Add the trailing brace */
3487 else { /* Here, not in a pattern. Convert the name to a
3490 /* If destination is not in utf8, unconditionally
3491 * recode it to be so. This is because \N{} implies
3492 * Unicode semantics, and scalars have to be in utf8
3493 * to guarantee those semantics */
3495 SvCUR_set(sv, d - SvPVX_const(sv));
3498 /* See Note on sizing above. */
3499 sv_utf8_upgrade_flags_grow(sv,
3500 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3501 len + (STRLEN)(send - s) + 1);
3502 d = SvPVX(sv) + SvCUR(sv);
3504 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3506 /* See Note on sizing above. (NOTE: SvCUR() is not
3507 * set correctly here). */
3508 const STRLEN off = d - SvPVX_const(sv);
3509 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3511 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3512 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3513 str = SvPV_const(res, len);
3515 Copy(str, d, len, char);
3521 } /* End \N{NAME} */
3524 native_range = FALSE; /* \N{} is defined to be Unicode */
3526 s = e + 1; /* Point to just after the '}' */
3529 /* \c is a control character */
3533 *d++ = grok_bslash_c(*s++, 1);
3536 yyerror("Missing control char name in \\c");
3540 /* printf-style backslashes, formfeeds, newlines, etc */
3566 } /* end if (backslash) */
3573 /* If we started with encoded form, or already know we want it,
3574 then encode the next character */
3575 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3579 /* One might think that it is wasted effort in the case of the
3580 * source being utf8 (this_utf8 == TRUE) to take the next character
3581 * in the source, convert it to an unsigned value, and then convert
3582 * it back again. But the source has not been validated here. The
3583 * routine that does the conversion checks for errors like
3586 const UV nextuv = (this_utf8)
3587 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3589 const STRLEN need = UNISKIP(nextuv);
3591 SvCUR_set(sv, d - SvPVX_const(sv));
3594 /* See Note on sizing above. */
3595 sv_utf8_upgrade_flags_grow(sv,
3596 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3597 need + (STRLEN)(send - s) + 1);
3598 d = SvPVX(sv) + SvCUR(sv);
3600 } else if (need > len) {
3601 /* encoded value larger than old, may need extra space (NOTE:
3602 * SvCUR() is not set correctly here). See Note on sizing
3604 const STRLEN off = d - SvPVX_const(sv);
3605 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3609 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3611 if (uv > 255 && !dorange)
3612 native_range = FALSE;
3618 } /* while loop to process each character */
3620 /* terminate the string and set up the sv */
3622 SvCUR_set(sv, d - SvPVX_const(sv));
3623 if (SvCUR(sv) >= SvLEN(sv))
3624 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3625 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3628 if (IN_ENCODING && !has_utf8) {
3629 sv_recode_to_utf8(sv, _get_encoding());
3635 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3636 PL_sublex_info.sub_op->op_private |=
3637 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3641 /* shrink the sv if we allocated more than we used */
3642 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3643 SvPV_shrink_to_cur(sv);
3646 /* return the substring (via pl_yylval) only if we parsed anything */
3649 for (; s2 < s; s2++) {
3651 COPLINE_INC_WITH_HERELINES;
3653 SvREFCNT_inc_simple_void_NN(sv);
3654 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3655 && ! PL_parser->lex_re_reparsing)
3657 const char *const key = PL_lex_inpat ? "qr" : "q";
3658 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3662 if (PL_lex_inwhat == OP_TRANS) {
3665 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3668 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3676 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3679 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3681 LEAVE_with_name("scan_const");
3686 * Returns TRUE if there's more to the expression (e.g., a subscript),
3689 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3691 * ->[ and ->{ return TRUE
3692 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3693 * { and [ outside a pattern are always subscripts, so return TRUE
3694 * if we're outside a pattern and it's not { or [, then return FALSE
3695 * if we're in a pattern and the first char is a {
3696 * {4,5} (any digits around the comma) returns FALSE
3697 * if we're in a pattern and the first char is a [
3699 * [SOMETHING] has a funky algorithm to decide whether it's a
3700 * character class or not. It has to deal with things like
3701 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3702 * anything else returns TRUE
3705 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3708 S_intuit_more(pTHX_ char *s)
3710 PERL_ARGS_ASSERT_INTUIT_MORE;
3712 if (PL_lex_brackets)
3714 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3716 if (*s == '-' && s[1] == '>'
3717 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3718 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3719 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3721 if (*s != '{' && *s != '[')
3726 /* In a pattern, so maybe we have {n,m}. */
3734 /* On the other hand, maybe we have a character class */
3737 if (*s == ']' || *s == '^')
3740 /* this is terrifying, and it works */
3743 const char * const send = strchr(s,']');
3744 unsigned char un_char, last_un_char;
3745 char tmpbuf[sizeof PL_tokenbuf * 4];
3747 if (!send) /* has to be an expression */
3749 weight = 2; /* let's weigh the evidence */
3753 else if (isDIGIT(*s)) {
3755 if (isDIGIT(s[1]) && s[2] == ']')
3761 Zero(seen,256,char);
3763 for (; s < send; s++) {
3764 last_un_char = un_char;
3765 un_char = (unsigned char)*s;
3770 weight -= seen[un_char] * 10;
3771 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3773 char *tmp = PL_bufend;
3774 PL_bufend = (char*)send;
3775 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3777 len = (int)strlen(tmpbuf);
3778 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3779 UTF ? SVf_UTF8 : 0, SVt_PV))
3784 else if (*s == '$' && s[1] &&
3785 strchr("[#!%*<>()-=",s[1])) {
3786 if (/*{*/ strchr("])} =",s[2]))
3795 if (strchr("wds]",s[1]))
3797 else if (seen[(U8)'\''] || seen[(U8)'"'])
3799 else if (strchr("rnftbxcav",s[1]))
3801 else if (isDIGIT(s[1])) {
3803 while (s[1] && isDIGIT(s[1]))
3813 if (strchr("aA01! ",last_un_char))
3815 if (strchr("zZ79~",s[1]))
3817 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3818 weight -= 5; /* cope with negative subscript */
3821 if (!isWORDCHAR(last_un_char)
3822 && !(last_un_char == '$' || last_un_char == '@'
3823 || last_un_char == '&')
3824 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3828 if (keyword(d, s - d, 0))
3831 if (un_char == last_un_char + 1)
3833 weight -= seen[un_char];
3838 if (weight >= 0) /* probably a character class */
3848 * Does all the checking to disambiguate
3850 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3851 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3853 * First argument is the stuff after the first token, e.g. "bar".
3855 * Not a method if foo is a filehandle.
3856 * Not a method if foo is a subroutine prototyped to take a filehandle.
3857 * Not a method if it's really "Foo $bar"
3858 * Method if it's "foo $bar"
3859 * Not a method if it's really "print foo $bar"
3860 * Method if it's really "foo package::" (interpreted as package->foo)
3861 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3862 * Not a method if bar is a filehandle or package, but is quoted with
3867 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3869 char *s = start + (*start == '$');
3870 char tmpbuf[sizeof PL_tokenbuf];
3873 /* Mustn't actually add anything to a symbol table.
3874 But also don't want to "initialise" any placeholder
3875 constants that might already be there into full
3876 blown PVGVs with attached PVCV. */
3878 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3880 PERL_ARGS_ASSERT_INTUIT_METHOD;
3882 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3884 if (cv && SvPOK(cv)) {
3885 const char *proto = CvPROTO(cv);
3887 while (*proto && (isSPACE(*proto) || *proto == ';'))
3894 if (*start == '$') {
3895 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3896 isUPPER(*PL_tokenbuf))
3901 return *s == '(' ? FUNCMETH : METHOD;
3904 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3905 /* start is the beginning of the possible filehandle/object,
3906 * and s is the end of it
3907 * tmpbuf is a copy of it (but with single quotes as double colons)
3910 if (!keyword(tmpbuf, len, 0)) {
3911 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3916 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3917 if (indirgv && GvCVu(indirgv))
3919 /* filehandle or package name makes it a method */
3920 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3922 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3923 return 0; /* no assumptions -- "=>" quotes bareword */
3925 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3926 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3927 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3931 return *s == '(' ? FUNCMETH : METHOD;
3937 /* Encoded script support. filter_add() effectively inserts a
3938 * 'pre-processing' function into the current source input stream.
3939 * Note that the filter function only applies to the current source file
3940 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3942 * The datasv parameter (which may be NULL) can be used to pass
3943 * private data to this instance of the filter. The filter function
3944 * can recover the SV using the FILTER_DATA macro and use it to
3945 * store private buffers and state information.
3947 * The supplied datasv parameter is upgraded to a PVIO type
3948 * and the IoDIRP/IoANY field is used to store the function pointer,
3949 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3950 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3951 * private use must be set using malloc'd pointers.
3955 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3963 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3964 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3966 if (!PL_rsfp_filters)
3967 PL_rsfp_filters = newAV();
3970 SvUPGRADE(datasv, SVt_PVIO);
3971 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3972 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3973 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3974 FPTR2DPTR(void *, IoANY(datasv)),
3975 SvPV_nolen(datasv)));
3976 av_unshift(PL_rsfp_filters, 1);
3977 av_store(PL_rsfp_filters, 0, datasv) ;
3979 !PL_parser->filtered
3980 && PL_parser->lex_flags & LEX_EVALBYTES
3981 && PL_bufptr < PL_bufend
3983 const char *s = PL_bufptr;
3984 while (s < PL_bufend) {
3986 SV *linestr = PL_parser->linestr;
3987 char *buf = SvPVX(linestr);
3988 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3989 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3990 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3991 STRLEN const linestart_pos = PL_parser->linestart - buf;
3992 STRLEN const last_uni_pos =
3993 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3994 STRLEN const last_lop_pos =
3995 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3996 av_push(PL_rsfp_filters, linestr);
3997 PL_parser->linestr =
3998 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3999 buf = SvPVX(PL_parser->linestr);
4000 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4001 PL_parser->bufptr = buf + bufptr_pos;
4002 PL_parser->oldbufptr = buf + oldbufptr_pos;
4003 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4004 PL_parser->linestart = buf + linestart_pos;
4005 if (PL_parser->last_uni)
4006 PL_parser->last_uni = buf + last_uni_pos;
4007 if (PL_parser->last_lop)
4008 PL_parser->last_lop = buf + last_lop_pos;
4009 SvLEN(linestr) = SvCUR(linestr);
4010 SvCUR(linestr) = s-SvPVX(linestr);
4011 PL_parser->filtered = 1;
4021 /* Delete most recently added instance of this filter function. */
4023 Perl_filter_del(pTHX_ filter_t funcp)
4027 PERL_ARGS_ASSERT_FILTER_DEL;
4030 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4031 FPTR2DPTR(void*, funcp)));
4033 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4035 /* if filter is on top of stack (usual case) just pop it off */
4036 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4037 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4038 sv_free(av_pop(PL_rsfp_filters));
4042 /* we need to search for the correct entry and clear it */
4043 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4047 /* Invoke the idxth filter function for the current rsfp. */
4048 /* maxlen 0 = read one text line */
4050 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4054 /* This API is bad. It should have been using unsigned int for maxlen.
4055 Not sure if we want to change the API, but if not we should sanity
4056 check the value here. */
4057 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4059 PERL_ARGS_ASSERT_FILTER_READ;
4061 if (!PL_parser || !PL_rsfp_filters)
4063 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4064 /* Provide a default input filter to make life easy. */
4065 /* Note that we append to the line. This is handy. */
4066 DEBUG_P(PerlIO_printf(Perl_debug_log,
4067 "filter_read %d: from rsfp\n", idx));
4068 if (correct_length) {
4071 const int old_len = SvCUR(buf_sv);
4073 /* ensure buf_sv is large enough */
4074 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4075 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4076 correct_length)) <= 0) {
4077 if (PerlIO_error(PL_rsfp))
4078 return -1; /* error */
4080 return 0 ; /* end of file */
4082 SvCUR_set(buf_sv, old_len + len) ;
4083 SvPVX(buf_sv)[old_len + len] = '\0';
4086 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4087 if (PerlIO_error(PL_rsfp))
4088 return -1; /* error */
4090 return 0 ; /* end of file */
4093 return SvCUR(buf_sv);
4095 /* Skip this filter slot if filter has been deleted */
4096 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4097 DEBUG_P(PerlIO_printf(Perl_debug_log,
4098 "filter_read %d: skipped (filter deleted)\n",
4100 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4102 if (SvTYPE(datasv) != SVt_PVIO) {
4103 if (correct_length) {
4105 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4106 if (!remainder) return 0; /* eof */
4107 if (correct_length > remainder) correct_length = remainder;
4108 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4109 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4112 const char *s = SvEND(datasv);
4113 const char *send = SvPVX(datasv) + SvLEN(datasv);
4121 if (s == send) return 0; /* eof */
4122 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4123 SvCUR_set(datasv, s-SvPVX(datasv));
4125 return SvCUR(buf_sv);
4127 /* Get function pointer hidden within datasv */
4128 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4129 DEBUG_P(PerlIO_printf(Perl_debug_log,
4130 "filter_read %d: via function %p (%s)\n",
4131 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4132 /* Call function. The function is expected to */
4133 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4134 /* Return: <0:error, =0:eof, >0:not eof */
4135 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4139 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4141 PERL_ARGS_ASSERT_FILTER_GETS;
4143 #ifdef PERL_CR_FILTER
4144 if (!PL_rsfp_filters) {
4145 filter_add(S_cr_textfilter,NULL);
4148 if (PL_rsfp_filters) {
4150 SvCUR_set(sv, 0); /* start with empty line */
4151 if (FILTER_READ(0, sv, 0) > 0)
4152 return ( SvPVX(sv) ) ;
4157 return (sv_gets(sv, PL_rsfp, append));
4161 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4165 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4167 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4171 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4172 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4174 return GvHV(gv); /* Foo:: */
4177 /* use constant CLASS => 'MyClass' */
4178 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4179 if (gv && GvCV(gv)) {
4180 SV * const sv = cv_const_sv(GvCV(gv));
4182 return gv_stashsv(sv, 0);
4185 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4190 S_tokenize_use(pTHX_ int is_use, char *s) {
4191 PERL_ARGS_ASSERT_TOKENIZE_USE;
4193 if (PL_expect != XSTATE)
4194 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4195 is_use ? "use" : "no"));
4198 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4199 s = force_version(s, TRUE);
4200 if (*s == ';' || *s == '}'
4201 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4202 NEXTVAL_NEXTTOKE.opval = NULL;
4205 else if (*s == 'v') {
4206 s = force_word(s,WORD,FALSE,TRUE);
4207 s = force_version(s, FALSE);
4211 s = force_word(s,WORD,FALSE,TRUE);
4212 s = force_version(s, FALSE);
4214 pl_yylval.ival = is_use;
4218 static const char* const exp_name[] =
4219 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4220 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4225 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4227 S_word_takes_any_delimeter(char *p, STRLEN len)
4229 return (len == 1 && strchr("msyq", p[0])) ||
4231 (p[0] == 't' && p[1] == 'r') ||
4232 (p[0] == 'q' && strchr("qwxr", p[1]))));
4236 S_check_scalar_slice(pTHX_ char *s)
4239 while (*s == ' ' || *s == '\t') s++;
4240 if (*s == 'q' && s[1] == 'w'
4241 && !isWORDCHAR_lazy_if(s+2,UTF))
4243 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4244 s += UTF ? UTF8SKIP(s) : 1;
4245 if (*s == '}' || *s == ']')
4246 pl_yylval.ival = OPpSLICEWARNING;
4252 Works out what to call the token just pulled out of the input
4253 stream. The yacc parser takes care of taking the ops we return and
4254 stitching them into a tree.
4257 The type of the next token
4260 Switch based on the current state:
4261 - if we already built the token before, use it
4262 - if we have a case modifier in a string, deal with that
4263 - handle other cases of interpolation inside a string
4264 - scan the next line if we are inside a format
4265 In the normal state switch on the next character:
4267 if alphabetic, go to key lookup
4268 unrecoginized character - croak
4269 - 0/4/26: handle end-of-line or EOF
4270 - cases for whitespace
4271 - \n and #: handle comments and line numbers
4272 - various operators, brackets and sigils
4275 - 'v': vstrings (or go to key lookup)
4276 - 'x' repetition operator (or go to key lookup)
4277 - other ASCII alphanumerics (key lookup begins here):
4280 scan built-in keyword (but do nothing with it yet)
4281 check for statement label
4282 check for lexical subs
4283 goto just_a_word if there is one
4284 see whether built-in keyword is overridden
4285 switch on keyword number:
4286 - default: just_a_word:
4287 not a built-in keyword; handle bareword lookup
4288 disambiguate between method and sub call
4289 fall back to bareword
4290 - cases for built-in keywords
4298 char *s = PL_bufptr;
4302 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4306 /* orig_keyword, gvp, and gv are initialized here because
4307 * jump to the label just_a_word_zero can bypass their
4308 * initialization later. */
4309 I32 orig_keyword = 0;
4314 SV* tmp = newSVpvs("");
4315 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4316 (IV)CopLINE(PL_curcop),
4317 lex_state_names[PL_lex_state],
4318 exp_name[PL_expect],
4319 pv_display(tmp, s, strlen(s), 0, 60));
4323 /* when we've already built the next token, just pull it out of the queue */
4326 pl_yylval = PL_nextval[PL_nexttoke];
4328 PL_lex_state = PL_lex_defer;
4329 PL_lex_defer = LEX_NORMAL;
4333 next_type = PL_nexttype[PL_nexttoke];
4334 if (next_type & (7<<24)) {
4335 if (next_type & (1<<24)) {
4336 if (PL_lex_brackets > 100)
4337 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4338 PL_lex_brackstack[PL_lex_brackets++] =
4339 (char) ((next_type >> 16) & 0xff);
4341 if (next_type & (2<<24))
4342 PL_lex_allbrackets++;
4343 if (next_type & (4<<24))
4344 PL_lex_allbrackets--;
4345 next_type &= 0xffff;
4347 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4351 switch (PL_lex_state) {
4353 case LEX_INTERPNORMAL:
4356 /* interpolated case modifiers like \L \U, including \Q and \E.
4357 when we get here, PL_bufptr is at the \
4359 case LEX_INTERPCASEMOD:
4361 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4363 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4364 PL_bufptr, PL_bufend, *PL_bufptr);
4366 /* handle \E or end of string */
4367 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4369 if (PL_lex_casemods) {
4370 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4371 PL_lex_casestack[PL_lex_casemods] = '\0';
4373 if (PL_bufptr != PL_bufend
4374 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4375 || oldmod == 'F')) {
4377 PL_lex_state = LEX_INTERPCONCAT;
4379 PL_lex_allbrackets--;
4382 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4383 /* Got an unpaired \E */
4384 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4385 "Useless use of \\E");
4387 if (PL_bufptr != PL_bufend)
4389 PL_lex_state = LEX_INTERPCONCAT;
4393 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4394 "### Saw case modifier\n"); });
4396 if (s[1] == '\\' && s[2] == 'E') {
4398 PL_lex_state = LEX_INTERPCONCAT;
4403 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4404 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4405 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4406 (strchr(PL_lex_casestack, 'L')
4407 || strchr(PL_lex_casestack, 'U')
4408 || strchr(PL_lex_casestack, 'F'))) {
4409 PL_lex_casestack[--PL_lex_casemods] = '\0';
4410 PL_lex_allbrackets--;
4413 if (PL_lex_casemods > 10)
4414 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4415 PL_lex_casestack[PL_lex_casemods++] = *s;
4416 PL_lex_casestack[PL_lex_casemods] = '\0';
4417 PL_lex_state = LEX_INTERPCONCAT;
4418 NEXTVAL_NEXTTOKE.ival = 0;
4419 force_next((2<<24)|'(');
4421 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4423 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4425 NEXTVAL_NEXTTOKE.ival = OP_LC;
4427 NEXTVAL_NEXTTOKE.ival = OP_UC;
4429 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4431 NEXTVAL_NEXTTOKE.ival = OP_FC;
4433 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4437 if (PL_lex_starts) {
4440 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4441 if (PL_lex_casemods == 1 && PL_lex_inpat)
4444 AopNOASSIGN(OP_CONCAT);
4450 case LEX_INTERPPUSH:
4451 return REPORT(sublex_push());
4453 case LEX_INTERPSTART:
4454 if (PL_bufptr == PL_bufend)
4455 return REPORT(sublex_done());
4456 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4457 "### Interpolated variable\n"); });
4459 /* for /@a/, we leave the joining for the regex engine to do
4460 * (unless we're within \Q etc) */
4461 PL_lex_dojoin = (*PL_bufptr == '@'
4462 && (!PL_lex_inpat || PL_lex_casemods));
4463 PL_lex_state = LEX_INTERPNORMAL;
4464 if (PL_lex_dojoin) {
4465 NEXTVAL_NEXTTOKE.ival = 0;
4467 force_ident("\"", '$');
4468 NEXTVAL_NEXTTOKE.ival = 0;
4470 NEXTVAL_NEXTTOKE.ival = 0;
4471 force_next((2<<24)|'(');
4472 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4475 /* Convert (?{...}) and friends to 'do {...}' */
4476 if (PL_lex_inpat && *PL_bufptr == '(') {
4477 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4479 if (*PL_bufptr != '{')
4481 PL_expect = XTERMBLOCK;
4485 if (PL_lex_starts++) {
4487 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4488 if (!PL_lex_casemods && PL_lex_inpat)
4491 AopNOASSIGN(OP_CONCAT);
4495 case LEX_INTERPENDMAYBE:
4496 if (intuit_more(PL_bufptr)) {
4497 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4503 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4504 XXX This hack can be removed if we stop setting PL_lex_state to
4505 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4506 if (UNLIKELY(!PL_lex_inwhat)) {
4507 PL_lex_state = LEX_NORMAL;
4511 if (PL_lex_dojoin) {
4512 const U8 dojoin_was = PL_lex_dojoin;
4513 PL_lex_dojoin = FALSE;
4514 PL_lex_state = LEX_INTERPCONCAT;
4515 PL_lex_allbrackets--;
4516 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4518 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4519 && SvEVALED(PL_lex_repl))
4521 if (PL_bufptr != PL_bufend)
4522 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4525 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4526 re_eval_str. If the here-doc body’s length equals the previous
4527 value of re_eval_start, re_eval_start will now be null. So
4528 check re_eval_str as well. */
4529 if (PL_parser->lex_shared->re_eval_start
4530 || PL_parser->lex_shared->re_eval_str) {
4532 if (*PL_bufptr != ')')
4533 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4535 /* having compiled a (?{..}) expression, return the original
4536 * text too, as a const */
4537 if (PL_parser->lex_shared->re_eval_str) {
4538 sv = PL_parser->lex_shared->re_eval_str;
4539 PL_parser->lex_shared->re_eval_str = NULL;
4541 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4542 SvPV_shrink_to_cur(sv);
4544 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4545 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4546 NEXTVAL_NEXTTOKE.opval =
4547 (OP*)newSVOP(OP_CONST, 0,
4550 PL_parser->lex_shared->re_eval_start = NULL;
4556 case LEX_INTERPCONCAT:
4558 if (PL_lex_brackets)
4559 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4560 (long) PL_lex_brackets);
4562 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4563 XXX This hack can be removed if we stop setting PL_lex_state to
4565 if (UNLIKELY(!PL_lex_inwhat)) {
4566 PL_lex_state = LEX_NORMAL;
4570 if (PL_bufptr == PL_bufend)
4571 return REPORT(sublex_done());
4573 /* m'foo' still needs to be parsed for possible (?{...}) */
4574 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4575 SV *sv = newSVsv(PL_linestr);
4577 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4581 s = scan_const(PL_bufptr);
4583 PL_lex_state = LEX_INTERPCASEMOD;
4585 PL_lex_state = LEX_INTERPSTART;
4588 if (s != PL_bufptr) {
4589 NEXTVAL_NEXTTOKE = pl_yylval;
4592 if (PL_lex_starts++) {
4593 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4594 if (!PL_lex_casemods && PL_lex_inpat)
4597 AopNOASSIGN(OP_CONCAT);
4607 s = scan_formline(PL_bufptr);
4608 if (!PL_lex_formbrack)
4617 /* We really do *not* want PL_linestr ever becoming a COW. */
4618 assert (!SvIsCOW(PL_linestr));
4620 PL_oldoldbufptr = PL_oldbufptr;
4622 PL_parser->saw_infix_sigil = 0;
4627 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4630 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4631 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4633 SVs_TEMP | SVf_UTF8),
4634 10, UNI_DISPLAY_ISPRINT)
4635 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4636 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4637 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4638 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4642 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4643 UTF8fARG(UTF, (s - d), d),
4648 goto fake_eof; /* emulate EOF on ^D or ^Z */
4650 if ((!PL_rsfp || PL_lex_inwhat)
4651 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4654 if (PL_lex_brackets &&
4655 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4656 yyerror((const char *)
4658 ? "Format not terminated"
4659 : "Missing right curly or square bracket"));
4661 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4662 "### Tokener got EOF\n");
4666 if (s++ < PL_bufend)
4667 goto retry; /* ignore stray nulls */
4670 if (!PL_in_eval && !PL_preambled) {
4671 PL_preambled = TRUE;
4673 /* Generate a string of Perl code to load the debugger.
4674 * If PERL5DB is set, it will return the contents of that,
4675 * otherwise a compile-time require of perl5db.pl. */
4677 const char * const pdb = PerlEnv_getenv("PERL5DB");
4680 sv_setpv(PL_linestr, pdb);
4681 sv_catpvs(PL_linestr,";");
4683 SETERRNO(0,SS_NORMAL);
4684 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4686 PL_parser->preambling = CopLINE(PL_curcop);
4688 sv_setpvs(PL_linestr,"");
4689 if (PL_preambleav) {
4690 SV **svp = AvARRAY(PL_preambleav);
4691 SV **const end = svp + AvFILLp(PL_preambleav);
4693 sv_catsv(PL_linestr, *svp);
4695 sv_catpvs(PL_linestr, ";");
4697 sv_free(MUTABLE_SV(PL_preambleav));
4698 PL_preambleav = NULL;
4701 sv_catpvs(PL_linestr,
4702 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4703 if (PL_minus_n || PL_minus_p) {
4704 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4706 sv_catpvs(PL_linestr,"chomp;");
4709 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4710 || *PL_splitstr == '"')
4711 && strchr(PL_splitstr + 1, *PL_splitstr))
4712 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4714 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4715 bytes can be used as quoting characters. :-) */
4716 const char *splits = PL_splitstr;
4717 sv_catpvs(PL_linestr, "our @F=split(q\0");
4720 if (*splits == '\\')
4721 sv_catpvn(PL_linestr, splits, 1);
4722 sv_catpvn(PL_linestr, splits, 1);
4723 } while (*splits++);
4724 /* This loop will embed the trailing NUL of
4725 PL_linestr as the last thing it does before
4727 sv_catpvs(PL_linestr, ");");
4731 sv_catpvs(PL_linestr,"our @F=split(' ');");
4734 sv_catpvs(PL_linestr, "\n");
4735 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4736 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4737 PL_last_lop = PL_last_uni = NULL;
4738 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4739 update_debugger_info(PL_linestr, NULL, 0);
4744 bof = PL_rsfp ? TRUE : FALSE;
4747 fake_eof = LEX_FAKE_EOF;
4749 PL_bufptr = PL_bufend;
4750 COPLINE_INC_WITH_HERELINES;
4751 if (!lex_next_chunk(fake_eof)) {
4752 CopLINE_dec(PL_curcop);
4754 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4756 CopLINE_dec(PL_curcop);
4758 /* If it looks like the start of a BOM or raw UTF-16,
4759 * check if it in fact is. */
4760 if (bof && PL_rsfp &&
4762 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4765 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4766 bof = (offset == (Off_t)SvCUR(PL_linestr));
4767 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4768 /* offset may include swallowed CR */
4770 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4773 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4774 s = swallow_bom((U8*)s);
4777 if (PL_parser->in_pod) {
4778 /* Incest with pod. */
4779 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4780 sv_setpvs(PL_linestr, "");
4781 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4782 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4783 PL_last_lop = PL_last_uni = NULL;
4784 PL_parser->in_pod = 0;
4787 if (PL_rsfp || PL_parser->filtered)
4789 } while (PL_parser->in_pod);
4790 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4791 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4792 PL_last_lop = PL_last_uni = NULL;
4793 if (CopLINE(PL_curcop) == 1) {
4794 while (s < PL_bufend && isSPACE(*s))
4796 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4800 if (*s == '#' && *(s+1) == '!')
4802 #ifdef ALTERNATE_SHEBANG
4804 static char const as[] = ALTERNATE_SHEBANG;
4805 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4806 d = s + (sizeof(as) - 1);
4808 #endif /* ALTERNATE_SHEBANG */
4817 while (*d && !isSPACE(*d))
4821 #ifdef ARG_ZERO_IS_SCRIPT
4822 if (ipathend > ipath) {
4824 * HP-UX (at least) sets argv[0] to the script name,
4825 * which makes $^X incorrect. And Digital UNIX and Linux,
4826 * at least, set argv[0] to the basename of the Perl
4827 * interpreter. So, having found "#!", we'll set it right.
4829 SV* copfilesv = CopFILESV(PL_curcop);
4832 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4834 assert(SvPOK(x) || SvGMAGICAL(x));
4835 if (sv_eq(x, copfilesv)) {
4836 sv_setpvn(x, ipath, ipathend - ipath);
4842 const char *bstart = SvPV_const(copfilesv, blen);
4843 const char * const lstart = SvPV_const(x, llen);
4845 bstart += blen - llen;
4846 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4847 sv_setpvn(x, ipath, ipathend - ipath);
4854 /* Anything to do if no copfilesv? */
4856 TAINT_NOT; /* $^X is always tainted, but that's OK */
4858 #endif /* ARG_ZERO_IS_SCRIPT */
4863 d = instr(s,"perl -");
4865 d = instr(s,"perl");
4867 /* avoid getting into infinite loops when shebang
4868 * line contains "Perl" rather than "perl" */
4870 for (d = ipathend-4; d >= ipath; --d) {
4871 if (isALPHA_FOLD_EQ(*d, 'p')
4872 && !ibcmp(d, "perl", 4))
4882 #ifdef ALTERNATE_SHEBANG
4884 * If the ALTERNATE_SHEBANG on this system starts with a
4885 * character that can be part of a Perl expression, then if
4886 * we see it but not "perl", we're probably looking at the
4887 * start of Perl code, not a request to hand off to some
4888 * other interpreter. Similarly, if "perl" is there, but
4889 * not in the first 'word' of the line, we assume the line
4890 * contains the start of the Perl program.
4892 if (d && *s != '#') {
4893 const char *c = ipath;
4894 while (*c && !strchr("; \t\r\n\f\v#", *c))
4897 d = NULL; /* "perl" not in first word; ignore */
4899 *s = '#'; /* Don't try to parse shebang line */
4901 #endif /* ALTERNATE_SHEBANG */
4906 !instr(s,"indir") &&
4907 instr(PL_origargv[0],"perl"))
4914 while (s < PL_bufend && isSPACE(*s))
4916 if (s < PL_bufend) {
4917 Newx(newargv,PL_origargc+3,char*);
4919 while (s < PL_bufend && !isSPACE(*s))
4922 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4925 newargv = PL_origargv;
4928 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4930 Perl_croak(aTHX_ "Can't exec %s", ipath);
4933 while (*d && !isSPACE(*d))
4935 while (SPACE_OR_TAB(*d))
4939 const bool switches_done = PL_doswitches;
4940 const U32 oldpdb = PL_perldb;
4941 const bool oldn = PL_minus_n;
4942 const bool oldp = PL_minus_p;
4946 bool baduni = FALSE;
4948 const char *d2 = d1 + 1;
4949 if (parse_unicode_opts((const char **)&d2)
4953 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4954 const char * const m = d1;
4955 while (*d1 && !isSPACE(*d1))
4957 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4960 d1 = moreswitches(d1);
4962 if (PL_doswitches && !switches_done) {
4963 int argc = PL_origargc;
4964 char **argv = PL_origargv;
4967 } while (argc && argv[0][0] == '-' && argv[0][1]);
4968 init_argv_symbols(argc,argv);
4970 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4971 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4972 /* if we have already added "LINE: while (<>) {",
4973 we must not do it again */
4975 sv_setpvs(PL_linestr, "");
4976 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4977 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4978 PL_last_lop = PL_last_uni = NULL;
4979 PL_preambled = FALSE;
4980 if (PERLDB_LINE || PERLDB_SAVESRC)
4981 (void)gv_fetchfile(PL_origfilename);
4988 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4989 PL_lex_state = LEX_FORMLINE;
4990 force_next(FORMRBRACK);
4995 #ifdef PERL_STRICT_CR
4996 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4998 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5000 case ' ': case '\t': case '\f': case '\v':
5005 if (PL_lex_state != LEX_NORMAL ||
5006 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5007 const bool in_comment = *s == '#';
5008 if (*s == '#' && s == PL_linestart && PL_in_eval
5009 && !PL_rsfp && !PL_parser->filtered) {
5010 /* handle eval qq[#line 1 "foo"\n ...] */
5011 CopLINE_dec(PL_curcop);
5015 while (d < PL_bufend && *d != '\n')
5019 else if (d > PL_bufend)
5020 /* Found by Ilya: feed random input to Perl. */
5021 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5024 if (in_comment && d == PL_bufend
5025 && PL_lex_state == LEX_INTERPNORMAL
5026 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5027 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5030 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5031 PL_lex_state = LEX_FORMLINE;
5032 force_next(FORMRBRACK);
5037 while (s < PL_bufend && *s != '\n')
5045 else if (s > PL_bufend)
5046 /* Found by Ilya: feed random input to Perl. */
5047 Perl_croak(aTHX_ "panic: input overflow");
5051 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5059 while (s < PL_bufend && SPACE_OR_TAB(*s))
5062 if (strnEQ(s,"=>",2)) {
5063 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5064 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5065 OPERATOR('-'); /* unary minus */
5068 case 'r': ftst = OP_FTEREAD; break;
5069 case 'w': ftst = OP_FTEWRITE; break;
5070 case 'x': ftst = OP_FTEEXEC; break;
5071 case 'o': ftst = OP_FTEOWNED; break;
5072 case 'R': ftst = OP_FTRREAD; break;
5073 case 'W': ftst = OP_FTRWRITE; break;
5074 case 'X': ftst = OP_FTREXEC; break;
5075 case 'O': ftst = OP_FTROWNED; break;
5076 case 'e': ftst = OP_FTIS; break;
5077 case 'z': ftst = OP_FTZERO; break;
5078 case 's': ftst = OP_FTSIZE; break;
5079 case 'f': ftst = OP_FTFILE; break;
5080 case 'd': ftst = OP_FTDIR; break;
5081 case 'l': ftst = OP_FTLINK; break;
5082 case 'p': ftst = OP_FTPIPE; break;
5083 case 'S': ftst = OP_FTSOCK; break;
5084 case 'u': ftst = OP_FTSUID; break;
5085 case 'g': ftst = OP_FTSGID; break;
5086 case 'k': ftst = OP_FTSVTX; break;
5087 case 'b': ftst = OP_FTBLK; break;
5088 case 'c': ftst = OP_FTCHR; break;
5089 case 't': ftst = OP_FTTTY; break;
5090 case 'T': ftst = OP_FTTEXT; break;
5091 case 'B': ftst = OP_FTBINARY; break;
5092 case 'M': case 'A': case 'C':
5093 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5095 case 'M': ftst = OP_FTMTIME; break;
5096 case 'A': ftst = OP_FTATIME; break;
5097 case 'C': ftst = OP_FTCTIME; break;
5105 PL_last_uni = PL_oldbufptr;
5106 PL_last_lop_op = (OPCODE)ftst;
5107 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5108 "### Saw file test %c\n", (int)tmp);
5113 /* Assume it was a minus followed by a one-letter named
5114 * subroutine call (or a -bareword), then. */
5115 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5116 "### '-%c' looked like a file test but was not\n",
5123 const char tmp = *s++;
5126 if (PL_expect == XOPERATOR)
5131 else if (*s == '>') {
5134 if (FEATURE_POSTDEREF_IS_ENABLED && (
5135 ((*s == '$' || *s == '&') && s[1] == '*')
5136 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5137 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5138 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5141 Perl_ck_warner_d(aTHX_
5142 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5143 "Postfix dereference is experimental"
5145 PL_expect = XPOSTDEREF;
5148 if (isIDFIRST_lazy_if(s,UTF)) {
5149 s = force_word(s,METHOD,FALSE,TRUE);
5157 if (PL_expect == XOPERATOR) {
5158 if (*s == '=' && !PL_lex_allbrackets &&
5159 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5166 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5168 OPERATOR('-'); /* unary minus */
5174 const char tmp = *s++;
5177 if (PL_expect == XOPERATOR)
5182 if (PL_expect == XOPERATOR) {
5183 if (*s == '=' && !PL_lex_allbrackets &&
5184 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5191 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5198 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5199 if (PL_expect != XOPERATOR) {
5200 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5201 PL_expect = XOPERATOR;
5202 force_ident(PL_tokenbuf, '*');
5210 if (*s == '=' && !PL_lex_allbrackets &&
5211 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5217 if (*s == '=' && !PL_lex_allbrackets &&
5218 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5222 PL_parser->saw_infix_sigil = 1;
5227 if (PL_expect == XOPERATOR) {
5228 if (s[1] == '=' && !PL_lex_allbrackets &&
5229 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5232 PL_parser->saw_infix_sigil = 1;
5235 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5236 PL_tokenbuf[0] = '%';
5237 s = scan_ident(s, PL_tokenbuf + 1,
5238 sizeof PL_tokenbuf - 1, FALSE);
5240 if (!PL_tokenbuf[1]) {
5243 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5245 PL_tokenbuf[0] = '@';
5247 PL_expect = XOPERATOR;
5248 force_ident_maybe_lex('%');
5253 bof = FEATURE_BITWISE_IS_ENABLED;
5254 if (bof && s[1] == '.')
5256 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5257 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5263 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5265 if (PL_lex_brackets > 100)
5266 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5267 PL_lex_brackstack[PL_lex_brackets++] = 0;
5268 PL_lex_allbrackets++;
5270 const char tmp = *s++;
5275 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5277 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5280 Perl_ck_warner_d(aTHX_
5281 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5282 "Smartmatch is experimental");
5286 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5288 BCop(OP_SCOMPLEMENT);
5290 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5292 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5299 goto just_a_word_zero_gv;
5305 switch (PL_expect) {
5307 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5309 PL_bufptr = s; /* update in case we back off */
5312 "Use of := for an empty attribute list is not allowed");
5319 PL_expect = XTERMBLOCK;
5323 while (isIDFIRST_lazy_if(s,UTF)) {
5326 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5327 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5328 if (tmp < 0) tmp = -tmp;
5343 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5345 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5346 COPLINE_SET_FROM_MULTI_END;
5348 /* MUST advance bufptr here to avoid bogus
5349 "at end of line" context messages from yyerror().
5351 PL_bufptr = s + len;
5352 yyerror("Unterminated attribute parameter in attribute list");
5356 return REPORT(0); /* EOF indicator */
5360 sv_catsv(sv, PL_lex_stuff);
5361 attrs = op_append_elem(OP_LIST, attrs,
5362 newSVOP(OP_CONST, 0, sv));
5363 SvREFCNT_dec_NN(PL_lex_stuff);
5364 PL_lex_stuff = NULL;
5367 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5369 if (PL_in_my == KEY_our) {
5370 deprecate(":unique");
5373 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5376 /* NOTE: any CV attrs applied here need to be part of
5377 the CVf_BUILTIN_ATTRS define in cv.h! */
5378 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5380 CvLVALUE_on(PL_compcv);
5382 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5384 deprecate(":locked");
5386 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5388 CvMETHOD_on(PL_compcv);
5390 else if (!PL_in_my && len == 5
5391 && strnEQ(SvPVX(sv), "const", len))
5394 Perl_ck_warner_d(aTHX_
5395 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5396 ":const is experimental"
5398 CvANONCONST_on(PL_compcv);
5399 if (!CvANON(PL_compcv))
5400 yyerror(":const is not permitted on named "
5403 /* After we've set the flags, it could be argued that
5404 we don't need to do the attributes.pm-based setting
5405 process, and shouldn't bother appending recognized
5406 flags. To experiment with that, uncomment the
5407 following "else". (Note that's already been
5408 uncommented. That keeps the above-applied built-in
5409 attributes from being intercepted (and possibly
5410 rejected) by a package's attribute routines, but is
5411 justified by the performance win for the common case
5412 of applying only built-in attributes.) */
5414 attrs = op_append_elem(OP_LIST, attrs,
5415 newSVOP(OP_CONST, 0,
5419 if (*s == ':' && s[1] != ':')
5422 break; /* require real whitespace or :'s */
5423 /* XXX losing whitespace on sequential attributes here */
5426 if (*s != ';' && *s != '}' &&
5427 !(PL_expect == XOPERATOR
5428 ? (*s == '=' || *s == ')')
5429 : (*s == '{' || *s == '('))) {
5430 const char q = ((*s == '\'') ? '"' : '\'');
5431 /* If here for an expression, and parsed no attrs, back
5433 if (PL_expect == XOPERATOR && !attrs) {
5437 /* MUST advance bufptr here to avoid bogus "at end of line"
5438 context messages from yyerror().
5441 yyerror( (const char *)
5443 ? Perl_form(aTHX_ "Invalid separator character "
5444 "%c%c%c in attribute list", q, *s, q)
5445 : "Unterminated attribute list" ) );
5453 NEXTVAL_NEXTTOKE.opval = attrs;
5459 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5463 PL_lex_allbrackets--;
5467 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5468 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5472 PL_lex_allbrackets++;
5475 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5482 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5485 PL_lex_allbrackets--;
5491 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5494 if (PL_lex_brackets <= 0)
5495 /* diag_listed_as: Unmatched right %s bracket */
5496 yyerror("Unmatched right square bracket");
5499 PL_lex_allbrackets--;
5500 if (PL_lex_state == LEX_INTERPNORMAL) {
5501 if (PL_lex_brackets == 0) {
5502 if (*s == '-' && s[1] == '>')
5503 PL_lex_state = LEX_INTERPENDMAYBE;
5504 else if (*s != '[' && *s != '{')
5505 PL_lex_state = LEX_INTERPEND;
5512 if (PL_lex_brackets > 100) {
5513 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5515 switch (PL_expect) {
5518 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5519 PL_lex_allbrackets++;
5520 OPERATOR(HASHBRACK);
5522 while (s < PL_bufend && SPACE_OR_TAB(*s))
5525 PL_tokenbuf[0] = '\0';
5526 if (d < PL_bufend && *d == '-') {
5527 PL_tokenbuf[0] = '-';
5529 while (d < PL_bufend && SPACE_OR_TAB(*d))
5532 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5533 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5535 while (d < PL_bufend && SPACE_OR_TAB(*d))
5538 const char minus = (PL_tokenbuf[0] == '-');
5539 s = force_word(s + minus, WORD, FALSE, TRUE);
5547 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5548 PL_lex_allbrackets++;
5553 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5554 PL_lex_allbrackets++;
5558 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5559 PL_lex_allbrackets++;
5564 if (PL_oldoldbufptr == PL_last_lop)
5565 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5567 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5568 PL_lex_allbrackets++;
5571 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5573 /* This hack is to get the ${} in the message. */
5575 yyerror("syntax error");
5578 OPERATOR(HASHBRACK);
5580 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5581 /* ${...} or @{...} etc., but not print {...}
5582 * Skip the disambiguation and treat this as a block.
5584 goto block_expectation;
5586 /* This hack serves to disambiguate a pair of curlies
5587 * as being a block or an anon hash. Normally, expectation
5588 * determines that, but in cases where we're not in a
5589 * position to expect anything in particular (like inside
5590 * eval"") we have to resolve the ambiguity. This code
5591 * covers the case where the first term in the curlies is a
5592 * quoted string. Most other cases need to be explicitly
5593 * disambiguated by prepending a "+" before the opening
5594 * curly in order to force resolution as an anon hash.
5596 * XXX should probably propagate the outer expectation
5597 * into eval"" to rely less on this hack, but that could
5598 * potentially break current behavior of eval"".
5602 if (*s == '\'' || *s == '"' || *s == '`') {
5603 /* common case: get past first string, handling escapes */
5604 for (t++; t < PL_bufend && *t != *s;)
5609 else if (*s == 'q') {
5612 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5613 && !isWORDCHAR(*t))))
5615 /* skip q//-like construct */
5617 char open, close, term;
5620 while (t < PL_bufend && isSPACE(*t))
5622 /* check for q => */
5623 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5624 OPERATOR(HASHBRACK);
5628 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5632 for (t++; t < PL_bufend; t++) {
5633 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5635 else if (*t == open)
5639 for (t++; t < PL_bufend; t++) {
5640 if (*t == '\\' && t+1 < PL_bufend)
5642 else if (*t == close && --brackets <= 0)
5644 else if (*t == open)
5651 /* skip plain q word */
5652 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5655 else if (isWORDCHAR_lazy_if(t,UTF)) {
5657 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5660 while (t < PL_bufend && isSPACE(*t))
5662 /* if comma follows first term, call it an anon hash */
5663 /* XXX it could be a comma expression with loop modifiers */
5664 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5665 || (*t == '=' && t[1] == '>')))
5666 OPERATOR(HASHBRACK);
5667 if (PL_expect == XREF)
5670 /* If there is an opening brace or 'sub:', treat it
5671 as a term to make ${{...}}{k} and &{sub:attr...}
5672 dwim. Otherwise, treat it as a statement, so
5673 map {no strict; ...} works.
5680 if (strnEQ(s, "sub", 3)) {
5691 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5697 pl_yylval.ival = CopLINE(PL_curcop);
5698 PL_copline = NOLINE; /* invalidate current command line number */
5699 TOKEN(formbrack ? '=' : '{');
5701 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5705 if (PL_lex_brackets <= 0)
5706 /* diag_listed_as: Unmatched right %s bracket */
5707 yyerror("Unmatched right curly bracket");
5709 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5710 PL_lex_allbrackets--;
5711 if (PL_lex_state == LEX_INTERPNORMAL) {
5712 if (PL_lex_brackets == 0) {
5713 if (PL_expect & XFAKEBRACK) {
5714 PL_expect &= XENUMMASK;
5715 PL_lex_state = LEX_INTERPEND;
5717 return yylex(); /* ignore fake brackets */
5719 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5720 && SvEVALED(PL_lex_repl))
5721 PL_lex_state = LEX_INTERPEND;
5722 else if (*s == '-' && s[1] == '>')
5723 PL_lex_state = LEX_INTERPENDMAYBE;
5724 else if (*s != '[' && *s != '{')
5725 PL_lex_state = LEX_INTERPEND;
5728 if (PL_expect & XFAKEBRACK) {
5729 PL_expect &= XENUMMASK;
5731 return yylex(); /* ignore fake brackets */
5733 force_next(formbrack ? '.' : '}');
5734 if (formbrack) LEAVE;
5735 if (formbrack == 2) { /* means . where arguments were expected */
5741 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5744 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5745 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5752 if (PL_expect == XOPERATOR) {
5753 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5754 && isIDFIRST_lazy_if(s,UTF))
5756 CopLINE_dec(PL_curcop);
5757 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5758 CopLINE_inc(PL_curcop);
5761 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5763 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5764 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5770 PL_parser->saw_infix_sigil = 1;
5771 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5777 PL_tokenbuf[0] = '&';
5778 s = scan_ident(s - 1, PL_tokenbuf + 1,
5779 sizeof PL_tokenbuf - 1, TRUE);
5780 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5781 if (PL_tokenbuf[1]) {
5782 force_ident_maybe_lex('&');
5791 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5792 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5800 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5802 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5803 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5807 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
5811 const char tmp = *s++;
5813 if (!PL_lex_allbrackets &&
5814 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5821 if (!PL_lex_allbrackets &&
5822 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5830 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5831 && strchr("+-*/%.^&|<",tmp))
5832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5833 "Reversed %c= operator",(int)tmp);
5835 if (PL_expect == XSTATE && isALPHA(tmp) &&
5836 (s == PL_linestart+1 || s[-2] == '\n') )
5838 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5839 || PL_lex_state != LEX_NORMAL) {
5844 if (strnEQ(s,"=cut",4)) {
5858 PL_parser->in_pod = 1;
5862 if (PL_expect == XBLOCK) {
5864 #ifdef PERL_STRICT_CR
5865 while (SPACE_OR_TAB(*t))
5867 while (SPACE_OR_TAB(*t) || *t == '\r')
5870 if (*t == '\n' || *t == '#') {
5873 SAVEI8(PL_parser->form_lex_state);
5874 SAVEI32(PL_lex_formbrack);
5875 PL_parser->form_lex_state = PL_lex_state;
5876 PL_lex_formbrack = PL_lex_brackets + 1;
5880 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5889 const char tmp = *s++;
5891 /* was this !=~ where !~ was meant?
5892 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5894 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5895 const char *t = s+1;
5897 while (t < PL_bufend && isSPACE(*t))
5900 if (*t == '/' || *t == '?' ||
5901 ((*t == 'm' || *t == 's' || *t == 'y')
5902 && !isWORDCHAR(t[1])) ||
5903 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5904 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5905 "!=~ should be !~");
5907 if (!PL_lex_allbrackets &&
5908 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5920 if (PL_expect != XOPERATOR) {
5921 if (s[1] != '<' && !strchr(s,'>'))
5923 if (s[1] == '<' && s[2] != '>')
5924 s = scan_heredoc(s);
5926 s = scan_inputsymbol(s);
5927 PL_expect = XOPERATOR;
5928 TOKEN(sublex_start());
5934 if (*s == '=' && !PL_lex_allbrackets &&
5935 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5939 SHop(OP_LEFT_SHIFT);
5944 if (!PL_lex_allbrackets &&
5945 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5952 if (!PL_lex_allbrackets &&
5953 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5961 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5969 const char tmp = *s++;
5971 if (*s == '=' && !PL_lex_allbrackets &&
5972 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5976 SHop(OP_RIGHT_SHIFT);
5978 else if (tmp == '=') {
5979 if (!PL_lex_allbrackets &&
5980 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5988 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5997 if (PL_expect == XOPERATOR) {
5998 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5999 return deprecate_commaless_var_list();
6002 else if (PL_expect == XPOSTDEREF) {
6005 POSTDEREF(DOLSHARP);
6010 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6011 PL_tokenbuf[0] = '@';
6012 s = scan_ident(s + 1, PL_tokenbuf + 1,
6013 sizeof PL_tokenbuf - 1, FALSE);
6014 if (PL_expect == XOPERATOR) {
6016 if (PL_bufptr > s) {
6018 PL_bufptr = PL_oldbufptr;
6020 no_op("Array length", d);
6022 if (!PL_tokenbuf[1])
6024 PL_expect = XOPERATOR;
6025 force_ident_maybe_lex('#');
6029 PL_tokenbuf[0] = '$';
6030 s = scan_ident(s, PL_tokenbuf + 1,
6031 sizeof PL_tokenbuf - 1, FALSE);
6032 if (PL_expect == XOPERATOR) {
6034 if (PL_bufptr > s) {
6036 PL_bufptr = PL_oldbufptr;
6040 if (!PL_tokenbuf[1]) {
6042 yyerror("Final $ should be \\$ or $name");
6048 const char tmp = *s;
6049 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6052 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6053 && intuit_more(s)) {
6055 PL_tokenbuf[0] = '@';
6056 if (ckWARN(WARN_SYNTAX)) {
6059 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6060 t += UTF ? UTF8SKIP(t) : 1;
6062 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6063 while (t < PL_bufend && *t != ']')
6065 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6066 "Multidimensional syntax %"UTF8f" not supported",
6067 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6071 else if (*s == '{') {
6073 PL_tokenbuf[0] = '%';
6074 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6075 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6077 char tmpbuf[sizeof PL_tokenbuf];
6080 } while (isSPACE(*t));
6081 if (isIDFIRST_lazy_if(t,UTF)) {
6083 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6088 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6090 "You need to quote \"%"UTF8f"\"",
6091 UTF8fARG(UTF, len, tmpbuf));
6097 PL_expect = XOPERATOR;
6098 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6099 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6100 if (!islop || PL_last_lop_op == OP_GREPSTART)
6101 PL_expect = XOPERATOR;
6102 else if (strchr("$@\"'`q", *s))
6103 PL_expect = XTERM; /* e.g. print $fh "foo" */
6104 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6105 PL_expect = XTERM; /* e.g. print $fh &sub */
6106 else if (isIDFIRST_lazy_if(s,UTF)) {
6107 char tmpbuf[sizeof PL_tokenbuf];
6109 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6110 if ((t2 = keyword(tmpbuf, len, 0))) {
6111 /* binary operators exclude handle interpretations */
6123 PL_expect = XTERM; /* e.g. print $fh length() */
6128 PL_expect = XTERM; /* e.g. print $fh subr() */
6131 else if (isDIGIT(*s))
6132 PL_expect = XTERM; /* e.g. print $fh 3 */
6133 else if (*s == '.' && isDIGIT(s[1]))
6134 PL_expect = XTERM; /* e.g. print $fh .3 */
6135 else if ((*s == '?' || *s == '-' || *s == '+')
6136 && !isSPACE(s[1]) && s[1] != '=')
6137 PL_expect = XTERM; /* e.g. print $fh -1 */
6138 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6140 PL_expect = XTERM; /* e.g. print $fh /.../
6141 XXX except DORDOR operator
6143 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6145 PL_expect = XTERM; /* print $fh <<"EOF" */
6148 force_ident_maybe_lex('$');
6152 if (PL_expect == XOPERATOR)
6154 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6155 PL_tokenbuf[0] = '@';
6156 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6158 if (!PL_tokenbuf[1]) {
6161 if (PL_lex_state == LEX_NORMAL)
6163 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6165 PL_tokenbuf[0] = '%';
6167 /* Warn about @ where they meant $. */
6168 if (*s == '[' || *s == '{') {
6169 if (ckWARN(WARN_SYNTAX)) {
6170 S_check_scalar_slice(aTHX_ s);
6174 PL_expect = XOPERATOR;
6175 force_ident_maybe_lex('@');
6178 case '/': /* may be division, defined-or, or pattern */
6179 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6180 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6181 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6186 else if (PL_expect == XOPERATOR) {
6188 if (*s == '=' && !PL_lex_allbrackets &&
6189 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6196 /* Disable warning on "study /blah/" */
6197 if (PL_oldoldbufptr == PL_last_uni
6198 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6199 || memNE(PL_last_uni, "study", 5)
6200 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6203 s = scan_pat(s,OP_MATCH);
6204 TERM(sublex_start());
6207 case '?': /* conditional */
6209 if (!PL_lex_allbrackets &&
6210 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6214 PL_lex_allbrackets++;
6218 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6219 #ifdef PERL_STRICT_CR
6222 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6224 && (s == PL_linestart || s[-1] == '\n') )
6227 formbrack = 2; /* dot seen where arguments expected */
6230 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6234 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6237 if (!PL_lex_allbrackets &&
6238 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6245 pl_yylval.ival = OPf_SPECIAL;
6251 if (*s == '=' && !PL_lex_allbrackets &&
6252 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6259 case '0': case '1': case '2': case '3': case '4':
6260 case '5': case '6': case '7': case '8': case '9':
6261 s = scan_num(s, &pl_yylval);
6262 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6263 if (PL_expect == XOPERATOR)
6268 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6271 COPLINE_SET_FROM_MULTI_END;
6272 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6273 if (PL_expect == XOPERATOR) {
6274 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6275 return deprecate_commaless_var_list();
6280 pl_yylval.ival = OP_CONST;
6281 TERM(sublex_start());
6284 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6287 printbuf("### Saw string before %s\n", s);
6289 PerlIO_printf(Perl_debug_log,
6290 "### Saw unterminated string\n");
6292 if (PL_expect == XOPERATOR) {
6293 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6294 return deprecate_commaless_var_list();
6301 pl_yylval.ival = OP_CONST;
6302 /* FIXME. I think that this can be const if char *d is replaced by
6303 more localised variables. */
6304 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6305 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6306 pl_yylval.ival = OP_STRINGIFY;
6310 if (pl_yylval.ival == OP_CONST)
6311 COPLINE_SET_FROM_MULTI_END;
6312 TERM(sublex_start());
6315 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6316 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6317 if (PL_expect == XOPERATOR)
6318 no_op("Backticks",s);
6321 pl_yylval.ival = OP_BACKTICK;
6322 TERM(sublex_start());
6326 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6328 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6330 if (PL_expect == XOPERATOR)
6331 no_op("Backslash",s);
6335 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6336 char *start = s + 2;
6337 while (isDIGIT(*start) || *start == '_')
6339 if (*start == '.' && isDIGIT(start[1])) {
6340 s = scan_num(s, &pl_yylval);
6343 else if ((*start == ':' && start[1] == ':')
6344 || (PL_expect == XSTATE && *start == ':'))
6346 else if (PL_expect == XSTATE) {
6348 while (d < PL_bufend && isSPACE(*d)) d++;
6349 if (*d == ':') goto keylookup;
6351 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6352 if (!isALPHA(*start) && (PL_expect == XTERM
6353 || PL_expect == XREF || PL_expect == XSTATE
6354 || PL_expect == XTERMORDORDOR)) {
6355 GV *const gv = gv_fetchpvn_flags(s, start - s,
6356 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6358 s = scan_num(s, &pl_yylval);
6365 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6418 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6420 /* Some keywords can be followed by any delimiter, including ':' */
6421 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6423 /* x::* is just a word, unless x is "CORE" */
6424 if (!anydelim && *s == ':' && s[1] == ':') {
6425 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6430 while (d < PL_bufend && isSPACE(*d))
6431 d++; /* no comments skipped here, or s### is misparsed */
6433 /* Is this a word before a => operator? */
6434 if (*d == '=' && d[1] == '>') {
6438 = (OP*)newSVOP(OP_CONST, 0,
6439 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6440 pl_yylval.opval->op_private = OPpCONST_BARE;
6444 /* Check for plugged-in keyword */
6448 char *saved_bufptr = PL_bufptr;
6450 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6452 if (result == KEYWORD_PLUGIN_DECLINE) {
6453 /* not a plugged-in keyword */
6454 PL_bufptr = saved_bufptr;
6455 } else if (result == KEYWORD_PLUGIN_STMT) {
6456 pl_yylval.opval = o;
6458 if (!PL_nexttoke) PL_expect = XSTATE;
6459 return REPORT(PLUGSTMT);
6460 } else if (result == KEYWORD_PLUGIN_EXPR) {
6461 pl_yylval.opval = o;
6463 if (!PL_nexttoke) PL_expect = XOPERATOR;
6464 return REPORT(PLUGEXPR);
6466 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6471 /* Check for built-in keyword */
6472 tmp = keyword(PL_tokenbuf, len, 0);
6474 /* Is this a label? */
6475 if (!anydelim && PL_expect == XSTATE
6476 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6478 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6479 pl_yylval.pval[len] = '\0';
6480 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6485 /* Check for lexical sub */
6486 if (PL_expect != XOPERATOR) {
6487 char tmpbuf[sizeof PL_tokenbuf + 1];
6489 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6490 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6491 if (off != NOT_IN_PAD) {
6492 assert(off); /* we assume this is boolean-true below */
6493 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6494 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6495 HEK * const stashname = HvNAME_HEK(stash);
6496 sv = newSVhek(stashname);
6497 sv_catpvs(sv, "::");
6498 sv_catpvn_flags(sv, PL_tokenbuf, len,
6499 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6500 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6510 rv2cv_op = newOP(OP_PADANY, 0);
6511 rv2cv_op->op_targ = off;
6512 cv = find_lexical_cv(off);
6520 if (tmp < 0) { /* second-class keyword? */
6521 GV *ogv = NULL; /* override (winner) */
6522 GV *hgv = NULL; /* hidden (loser) */
6523 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6525 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6526 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6530 if (GvIMPORTED_CV(gv))
6532 else if (! CvMETHOD(cv))
6536 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6540 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6541 : SvPCS_IMPORTED(gv)
6542 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6551 tmp = 0; /* overridden by import or by GLOBAL */
6554 && -tmp==KEY_lock /* XXX generalizable kludge */
6557 tmp = 0; /* any sub overrides "weak" keyword */
6559 else { /* no override */
6561 if (tmp == KEY_dump) {
6562 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6563 "dump() better written as CORE::dump()");
6567 if (hgv && tmp != KEY_x) /* never ambiguous */
6568 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6569 "Ambiguous call resolved as CORE::%s(), "
6570 "qualify as such or use &",
6575 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6576 && (!anydelim || *s != '#')) {
6577 /* no override, and not s### either; skipspace is safe here
6578 * check for => on following line */
6580 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6581 STRLEN soff = s - SvPVX(PL_linestr);
6582 s = skipspace_flags(s, LEX_NO_INCLINE);
6583 arrow = *s == '=' && s[1] == '>';
6584 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6585 s = SvPVX(PL_linestr) + soff;
6593 default: /* not a keyword */
6594 /* Trade off - by using this evil construction we can pull the
6595 variable gv into the block labelled keylookup. If not, then
6596 we have to give it function scope so that the goto from the
6597 earlier ':' case doesn't bypass the initialisation. */
6599 just_a_word_zero_gv:
6611 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6615 /* Get the rest if it looks like a package qualifier */
6617 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6619 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6622 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6623 UTF8fARG(UTF, len, PL_tokenbuf),
6624 *s == '\'' ? "'" : "::");
6629 if (PL_expect == XOPERATOR) {
6630 if (PL_bufptr == PL_linestart) {
6631 CopLINE_dec(PL_curcop);
6632 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6633 CopLINE_inc(PL_curcop);
6636 no_op("Bareword",s);
6639 /* See if the name is "Foo::",
6640 in which case Foo is a bareword
6641 (and a package name). */
6644 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6646 if (ckWARN(WARN_BAREWORD)
6647 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6648 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6649 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6650 UTF8fARG(UTF, len, PL_tokenbuf));
6652 PL_tokenbuf[len] = '\0';
6661 /* if we saw a global override before, get the right name */
6664 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6667 SV * const tmp_sv = sv;
6668 sv = newSVpvs("CORE::GLOBAL::");
6669 sv_catsv(sv, tmp_sv);
6670 SvREFCNT_dec(tmp_sv);
6674 /* Presume this is going to be a bareword of some sort. */
6676 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6677 pl_yylval.opval->op_private = OPpCONST_BARE;
6679 /* And if "Foo::", then that's what it certainly is. */
6685 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6686 const_op->op_private = OPpCONST_BARE;
6688 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6692 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6695 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6698 /* Use this var to track whether intuit_method has been
6699 called. intuit_method returns 0 or > 255. */
6702 /* See if it's the indirect object for a list operator. */
6704 if (PL_oldoldbufptr &&
6705 PL_oldoldbufptr < PL_bufptr &&
6706 (PL_oldoldbufptr == PL_last_lop
6707 || PL_oldoldbufptr == PL_last_uni) &&
6708 /* NO SKIPSPACE BEFORE HERE! */
6709 (PL_expect == XREF ||
6710 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6712 bool immediate_paren = *s == '(';
6714 /* (Now we can afford to cross potential line boundary.) */
6717 /* Two barewords in a row may indicate method call. */
6719 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6720 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6724 /* If not a declared subroutine, it's an indirect object. */
6725 /* (But it's an indir obj regardless for sort.) */
6726 /* Also, if "_" follows a filetest operator, it's a bareword */
6729 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6731 (PL_last_lop_op != OP_MAPSTART &&
6732 PL_last_lop_op != OP_GREPSTART))))
6733 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6734 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6737 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6742 PL_expect = XOPERATOR;
6745 /* Is this a word before a => operator? */
6746 if (*s == '=' && s[1] == '>' && !pkgname) {
6749 if (gvp || (lex && !off)) {
6750 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6751 /* This is our own scalar, created a few lines
6752 above, so this is safe. */
6754 sv_setpv(sv, PL_tokenbuf);
6755 if (UTF && !IN_BYTES
6756 && is_utf8_string((U8*)PL_tokenbuf, len))
6763 /* If followed by a paren, it's certainly a subroutine. */
6768 while (SPACE_OR_TAB(*d))
6770 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6775 NEXTVAL_NEXTTOKE.opval =
6776 off ? rv2cv_op : pl_yylval.opval;
6778 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6779 else op_free(rv2cv_op), force_next(WORD);
6784 /* If followed by var or block, call it a method (unless sub) */
6786 if ((*s == '$' || *s == '{') && !cv) {
6788 PL_last_lop = PL_oldbufptr;
6789 PL_last_lop_op = OP_METHOD;
6790 if (!PL_lex_allbrackets &&
6791 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6792 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6793 PL_expect = XBLOCKTERM;
6795 return REPORT(METHOD);
6798 /* If followed by a bareword, see if it looks like indir obj. */
6800 if (tmp == 1 && !orig_keyword
6801 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6802 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6805 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6807 sv_setpvn(sv, PL_tokenbuf, len);
6808 if (UTF && !IN_BYTES
6809 && is_utf8_string((U8*)PL_tokenbuf, len))
6811 else SvUTF8_off(sv);
6814 if (tmp == METHOD && !PL_lex_allbrackets &&
6815 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6816 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6820 /* Not a method, so call it a subroutine (if defined) */
6823 /* Check for a constant sub */
6824 if ((sv = cv_const_sv_or_av(cv))) {
6827 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6828 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6829 if (SvTYPE(sv) == SVt_PVAV)
6830 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6833 pl_yylval.opval->op_private = 0;
6834 pl_yylval.opval->op_folded = 1;
6835 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6840 op_free(pl_yylval.opval);
6842 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6843 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6844 PL_last_lop = PL_oldbufptr;
6845 PL_last_lop_op = OP_ENTERSUB;
6846 /* Is there a prototype? */
6850 STRLEN protolen = CvPROTOLEN(cv);
6851 const char *proto = CvPROTO(cv);
6853 proto = S_strip_spaces(aTHX_ proto, &protolen);
6856 if ((optional = *proto == ';'))
6859 while (*proto == ';');
6863 *proto == '$' || *proto == '_'
6864 || *proto == '*' || *proto == '+'
6869 *proto == '\\' && proto[1] && proto[2] == '\0'
6872 UNIPROTO(UNIOPSUB,optional);
6873 if (*proto == '\\' && proto[1] == '[') {
6874 const char *p = proto + 2;
6875 while(*p && *p != ']')
6877 if(*p == ']' && !p[1])
6878 UNIPROTO(UNIOPSUB,optional);
6880 if (*proto == '&' && *s == '{') {
6882 sv_setpvs(PL_subname, "__ANON__");
6884 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6885 if (!PL_lex_allbrackets &&
6886 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6887 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6891 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6893 force_next(off ? PRIVATEREF : WORD);
6894 if (!PL_lex_allbrackets &&
6895 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6896 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6900 /* Call it a bare word */
6902 if (PL_hints & HINT_STRICT_SUBS)
6903 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6906 /* after "print" and similar functions (corresponding to
6907 * "F? L" in opcode.pl), whatever wasn't already parsed as
6908 * a filehandle should be subject to "strict subs".
6909 * Likewise for the optional indirect-object argument to system
6910 * or exec, which can't be a bareword */
6911 if ((PL_last_lop_op == OP_PRINT
6912 || PL_last_lop_op == OP_PRTF
6913 || PL_last_lop_op == OP_SAY
6914 || PL_last_lop_op == OP_SYSTEM
6915 || PL_last_lop_op == OP_EXEC)
6916 && (PL_hints & HINT_STRICT_SUBS))
6917 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6918 if (lastchar != '-') {
6919 if (ckWARN(WARN_RESERVED)) {
6923 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6925 /* PL_warn_reserved is constant */
6926 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6927 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6937 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6938 && saw_infix_sigil) {
6939 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6940 "Operator or semicolon missing before %c%"UTF8f,
6942 UTF8fARG(UTF, strlen(PL_tokenbuf),
6944 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6945 "Ambiguous use of %c resolved as operator %c",
6946 lastchar, lastchar);
6953 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6958 (OP*)newSVOP(OP_CONST, 0,
6959 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6962 case KEY___PACKAGE__:
6964 (OP*)newSVOP(OP_CONST, 0,
6966 ? newSVhek(HvNAME_HEK(PL_curstash))
6973 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6974 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6977 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6979 gv_init(gv,stash,"DATA",4,0);
6982 GvIOp(gv) = newIO();
6983 IoIFP(GvIOp(gv)) = PL_rsfp;
6984 #if defined(HAS_FCNTL) && defined(F_SETFD)
6986 const int fd = PerlIO_fileno(PL_rsfp);
6987 fcntl(fd,F_SETFD,fd >= 3);
6990 /* Mark this internal pseudo-handle as clean */
6991 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6992 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6993 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6995 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6996 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6997 /* if the script was opened in binmode, we need to revert
6998 * it to text mode for compatibility; but only iff it has CRs
6999 * XXX this is a questionable hack at best. */
7000 if (PL_bufend-PL_bufptr > 2
7001 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7004 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7005 loc = PerlIO_tell(PL_rsfp);
7006 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7009 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7011 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7012 #endif /* NETWARE */
7014 PerlIO_seek(PL_rsfp, loc, 0);
7018 #ifdef PERLIO_LAYERS
7021 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7022 else if (IN_ENCODING) {
7028 XPUSHs(_get_encoding());
7030 call_method("name", G_SCALAR);
7034 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7035 Perl_form(aTHX_ ":encoding(%"SVf")",
7048 FUN0OP(CvCLONE(PL_compcv)
7049 ? newOP(OP_RUNCV, 0)
7050 : newPVOP(OP_RUNCV,0,NULL));
7059 if (PL_expect == XSTATE) {
7070 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7071 if ((*s == ':' && s[1] == ':')
7072 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7076 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7080 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7081 UTF8fARG(UTF, len, PL_tokenbuf));
7084 else if (tmp == KEY_require || tmp == KEY_do
7086 /* that's a way to remember we saw "CORE::" */
7098 LOP(OP_ACCEPT,XTERM);
7101 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7106 LOP(OP_ATAN2,XTERM);
7112 LOP(OP_BINMODE,XTERM);
7115 LOP(OP_BLESS,XTERM);
7124 /* We have to disambiguate the two senses of
7125 "continue". If the next token is a '{' then
7126 treat it as the start of a continue block;
7127 otherwise treat it as a control operator.
7137 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7147 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7156 if (!PL_cryptseen) {
7157 PL_cryptseen = TRUE;
7161 LOP(OP_CRYPT,XTERM);
7164 LOP(OP_CHMOD,XTERM);
7167 LOP(OP_CHOWN,XTERM);
7170 LOP(OP_CONNECT,XTERM);
7190 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7192 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7193 && !keyword(PL_tokenbuf + 1, len, 0)) {
7196 force_ident_maybe_lex('&');
7201 if (orig_keyword == KEY_do) {
7210 PL_hints |= HINT_BLOCK_SCOPE;
7220 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7221 STR_WITH_LEN("NDBM_File::"),
7222 STR_WITH_LEN("DB_File::"),
7223 STR_WITH_LEN("GDBM_File::"),
7224 STR_WITH_LEN("SDBM_File::"),
7225 STR_WITH_LEN("ODBM_File::"),
7227 LOP(OP_DBMOPEN,XTERM);
7239 pl_yylval.ival = CopLINE(PL_curcop);
7243 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7255 if (*s == '{') { /* block eval */
7256 PL_expect = XTERMBLOCK;
7257 UNIBRACK(OP_ENTERTRY);
7259 else { /* string eval */
7261 UNIBRACK(OP_ENTEREVAL);
7266 UNIBRACK(-OP_ENTEREVAL);
7280 case KEY_endhostent:
7286 case KEY_endservent:
7289 case KEY_endprotoent:
7300 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7302 pl_yylval.ival = CopLINE(PL_curcop);
7304 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7307 if ((PL_bufend - p) >= 3 &&
7308 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7310 else if ((PL_bufend - p) >= 4 &&
7311 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7314 /* skip optional package name, as in "for my abc $x (..)" */
7315 if (isIDFIRST_lazy_if(p,UTF)) {
7316 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7320 Perl_croak(aTHX_ "Missing $ on loop variable");
7325 LOP(OP_FORMLINE,XTERM);
7334 LOP(OP_FCNTL,XTERM);
7340 LOP(OP_FLOCK,XTERM);
7343 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7348 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7353 LOP(OP_GREPSTART, XREF);
7370 case KEY_getpriority:
7371 LOP(OP_GETPRIORITY,XTERM);
7373 case KEY_getprotobyname:
7376 case KEY_getprotobynumber:
7377 LOP(OP_GPBYNUMBER,XTERM);
7379 case KEY_getprotoent:
7391 case KEY_getpeername:
7392 UNI(OP_GETPEERNAME);
7394 case KEY_gethostbyname:
7397 case KEY_gethostbyaddr:
7398 LOP(OP_GHBYADDR,XTERM);
7400 case KEY_gethostent:
7403 case KEY_getnetbyname:
7406 case KEY_getnetbyaddr:
7407 LOP(OP_GNBYADDR,XTERM);
7412 case KEY_getservbyname:
7413 LOP(OP_GSBYNAME,XTERM);
7415 case KEY_getservbyport:
7416 LOP(OP_GSBYPORT,XTERM);
7418 case KEY_getservent:
7421 case KEY_getsockname:
7422 UNI(OP_GETSOCKNAME);
7424 case KEY_getsockopt:
7425 LOP(OP_GSOCKOPT,XTERM);
7440 pl_yylval.ival = CopLINE(PL_curcop);
7441 Perl_ck_warner_d(aTHX_
7442 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7443 "given is experimental");
7448 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7456 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7458 pl_yylval.ival = CopLINE(PL_curcop);
7462 LOP(OP_INDEX,XTERM);
7468 LOP(OP_IOCTL,XTERM);
7496 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7501 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7515 LOP(OP_LISTEN,XTERM);
7524 s = scan_pat(s,OP_MATCH);
7525 TERM(sublex_start());
7528 LOP(OP_MAPSTART, XREF);
7531 LOP(OP_MKDIR,XTERM);
7534 LOP(OP_MSGCTL,XTERM);
7537 LOP(OP_MSGGET,XTERM);
7540 LOP(OP_MSGRCV,XTERM);
7543 LOP(OP_MSGSND,XTERM);
7548 PL_in_my = (U16)tmp;
7550 if (isIDFIRST_lazy_if(s,UTF)) {
7551 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7552 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7554 if (!FEATURE_LEXSUBS_IS_ENABLED)
7556 "Experimental \"%s\" subs not enabled",
7557 tmp == KEY_my ? "my" :
7558 tmp == KEY_state ? "state" : "our");
7559 Perl_ck_warner_d(aTHX_
7560 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7561 "The lexical_subs feature is experimental");
7564 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7565 if (!PL_in_my_stash) {
7569 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7570 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7571 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7581 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7586 s = tokenize_use(0, s);
7590 if (*s == '(' || (s = skipspace(s), *s == '('))
7593 if (!PL_lex_allbrackets &&
7594 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7595 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7601 if (isIDFIRST_lazy_if(s,UTF)) {
7603 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7605 for (t=d; isSPACE(*t);)
7607 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7609 && !(t[0] == '=' && t[1] == '>')
7610 && !(t[0] == ':' && t[1] == ':')
7611 && !keyword(s, d-s, 0)
7613 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7614 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7615 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7621 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7623 pl_yylval.ival = OP_OR;
7633 LOP(OP_OPEN_DIR,XTERM);
7636 checkcomma(s,PL_tokenbuf,"filehandle");
7640 checkcomma(s,PL_tokenbuf,"filehandle");
7659 s = force_word(s,WORD,FALSE,TRUE);
7661 s = force_strict_version(s);
7665 LOP(OP_PIPE_OP,XTERM);
7668 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7671 COPLINE_SET_FROM_MULTI_END;
7672 pl_yylval.ival = OP_CONST;
7673 TERM(sublex_start());
7680 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7683 COPLINE_SET_FROM_MULTI_END;
7684 PL_expect = XOPERATOR;
7685 if (SvCUR(PL_lex_stuff)) {
7686 int warned_comma = !ckWARN(WARN_QW);
7687 int warned_comment = warned_comma;
7688 d = SvPV_force(PL_lex_stuff, len);
7690 for (; isSPACE(*d) && len; --len, ++d)
7695 if (!warned_comma || !warned_comment) {
7696 for (; !isSPACE(*d) && len; --len, ++d) {
7697 if (!warned_comma && *d == ',') {
7698 Perl_warner(aTHX_ packWARN(WARN_QW),
7699 "Possible attempt to separate words with commas");
7702 else if (!warned_comment && *d == '#') {
7703 Perl_warner(aTHX_ packWARN(WARN_QW),
7704 "Possible attempt to put comments in qw() list");
7710 for (; !isSPACE(*d) && len; --len, ++d)
7713 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7714 words = op_append_elem(OP_LIST, words,
7715 newSVOP(OP_CONST, 0, tokeq(sv)));
7720 words = newNULLLIST();
7721 SvREFCNT_dec_NN(PL_lex_stuff);
7722 PL_lex_stuff = NULL;
7723 PL_expect = XOPERATOR;
7724 pl_yylval.opval = sawparens(words);
7729 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7732 pl_yylval.ival = OP_STRINGIFY;
7733 if (SvIVX(PL_lex_stuff) == '\'')
7734 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7735 TERM(sublex_start());
7738 s = scan_pat(s,OP_QR);
7739 TERM(sublex_start());
7742 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7745 pl_yylval.ival = OP_BACKTICK;
7746 TERM(sublex_start());
7754 s = force_version(s, FALSE);
7756 else if (*s != 'v' || !isDIGIT(s[1])
7757 || (s = force_version(s, TRUE), *s == 'v'))
7759 *PL_tokenbuf = '\0';
7760 s = force_word(s,WORD,TRUE,TRUE);
7761 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7762 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7763 GV_ADD | (UTF ? SVf_UTF8 : 0));
7765 yyerror("<> at require-statement should be quotes");
7767 if (orig_keyword == KEY_require) {
7773 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7775 PL_last_uni = PL_oldbufptr;
7776 PL_last_lop_op = OP_REQUIRE;
7778 return REPORT( (int)REQUIRE );
7787 LOP(OP_RENAME,XTERM);
7796 LOP(OP_RINDEX,XTERM);
7805 UNIDOR(OP_READLINE);
7808 UNIDOR(OP_BACKTICK);
7817 LOP(OP_REVERSE,XTERM);
7820 UNIDOR(OP_READLINK);
7827 if (pl_yylval.opval)
7828 TERM(sublex_start());
7830 TOKEN(1); /* force error */
7833 checkcomma(s,PL_tokenbuf,"filehandle");
7843 LOP(OP_SELECT,XTERM);
7849 LOP(OP_SEMCTL,XTERM);
7852 LOP(OP_SEMGET,XTERM);
7855 LOP(OP_SEMOP,XTERM);
7861 LOP(OP_SETPGRP,XTERM);
7863 case KEY_setpriority:
7864 LOP(OP_SETPRIORITY,XTERM);
7866 case KEY_sethostent:
7872 case KEY_setservent:
7875 case KEY_setprotoent:
7885 LOP(OP_SEEKDIR,XTERM);
7887 case KEY_setsockopt:
7888 LOP(OP_SSOCKOPT,XTERM);
7894 LOP(OP_SHMCTL,XTERM);
7897 LOP(OP_SHMGET,XTERM);
7900 LOP(OP_SHMREAD,XTERM);
7903 LOP(OP_SHMWRITE,XTERM);
7906 LOP(OP_SHUTDOWN,XTERM);
7915 LOP(OP_SOCKET,XTERM);
7917 case KEY_socketpair:
7918 LOP(OP_SOCKPAIR,XTERM);
7921 checkcomma(s,PL_tokenbuf,"subroutine name");
7924 s = force_word(s,WORD,TRUE,TRUE);
7928 LOP(OP_SPLIT,XTERM);
7931 LOP(OP_SPRINTF,XTERM);
7934 LOP(OP_SPLICE,XTERM);
7949 LOP(OP_SUBSTR,XTERM);
7955 char * const tmpbuf = PL_tokenbuf + 1;
7956 expectation attrful;
7957 bool have_name, have_proto;
7958 const int key = tmp;
7959 SV *format_name = NULL;
7964 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7965 (*s == ':' && s[1] == ':'))
7969 attrful = XATTRBLOCK;
7970 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7972 if (key == KEY_format)
7973 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7975 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7977 PL_tokenbuf, len + 1, 0
7979 sv_setpvn(PL_subname, tmpbuf, len);
7981 sv_setsv(PL_subname,PL_curstname);
7982 sv_catpvs(PL_subname,"::");
7983 sv_catpvn(PL_subname,tmpbuf,len);
7985 if (SvUTF8(PL_linestr))
7986 SvUTF8_on(PL_subname);
7993 if (key == KEY_my || key == KEY_our || key==KEY_state)
7996 /* diag_listed_as: Missing name in "%s sub" */
7998 "Missing name in \"%s\"", PL_bufptr);
8000 PL_expect = XTERMBLOCK;
8001 attrful = XATTRTERM;
8002 sv_setpvs(PL_subname,"?");
8006 if (key == KEY_format) {
8008 NEXTVAL_NEXTTOKE.opval
8009 = (OP*)newSVOP(OP_CONST,0, format_name);
8010 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8016 /* Look for a prototype */
8017 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8018 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8019 COPLINE_SET_FROM_MULTI_END;
8021 Perl_croak(aTHX_ "Prototype not terminated");
8022 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8030 if (*s == ':' && s[1] != ':')
8031 PL_expect = attrful;
8032 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
8034 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8035 else if (*s != ';' && *s != '}')
8036 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8040 NEXTVAL_NEXTTOKE.opval =
8041 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8042 PL_lex_stuff = NULL;
8047 sv_setpvs(PL_subname, "__ANON__");
8049 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8052 force_ident_maybe_lex('&');
8057 LOP(OP_SYSTEM,XREF);
8060 LOP(OP_SYMLINK,XTERM);
8063 LOP(OP_SYSCALL,XTERM);
8066 LOP(OP_SYSOPEN,XTERM);
8069 LOP(OP_SYSSEEK,XTERM);
8072 LOP(OP_SYSREAD,XTERM);
8075 LOP(OP_SYSWRITE,XTERM);
8080 TERM(sublex_start());
8101 LOP(OP_TRUNCATE,XTERM);
8113 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8115 pl_yylval.ival = CopLINE(PL_curcop);
8119 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8121 pl_yylval.ival = CopLINE(PL_curcop);
8125 LOP(OP_UNLINK,XTERM);
8131 LOP(OP_UNPACK,XTERM);
8134 LOP(OP_UTIME,XTERM);
8140 LOP(OP_UNSHIFT,XTERM);
8143 s = tokenize_use(1, s);
8153 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8155 pl_yylval.ival = CopLINE(PL_curcop);
8156 Perl_ck_warner_d(aTHX_
8157 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8158 "when is experimental");
8162 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8164 pl_yylval.ival = CopLINE(PL_curcop);
8168 PL_hints |= HINT_BLOCK_SCOPE;
8175 LOP(OP_WAITPID,XTERM);
8181 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8182 * we use the same number on EBCDIC */
8183 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8187 if (PL_expect == XOPERATOR) {
8188 if (*s == '=' && !PL_lex_allbrackets &&
8189 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8197 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8199 pl_yylval.ival = OP_XOR;
8208 Looks up an identifier in the pad or in a package
8211 PRIVATEREF if this is a lexical name.
8212 WORD if this belongs to a package.
8215 if we're in a my declaration
8216 croak if they tried to say my($foo::bar)
8217 build the ops for a my() declaration
8218 if it's an access to a my() variable
8219 build ops for access to a my() variable
8220 if in a dq string, and they've said @foo and we can't find @foo
8222 build ops for a bareword
8226 S_pending_ident(pTHX)
8229 const char pit = (char)pl_yylval.ival;
8230 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8231 /* All routes through this function want to know if there is a colon. */
8232 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8234 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8235 "### Pending identifier '%s'\n", PL_tokenbuf); });
8237 /* if we're in a my(), we can't allow dynamics here.
8238 $foo'bar has already been turned into $foo::bar, so
8239 just check for colons.
8241 if it's a legal name, the OP is a PADANY.
8244 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8246 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8247 "variable %s in \"our\"",
8248 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8249 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8253 /* "my" variable %s can't be in a package */
8254 /* PL_no_myglob is constant */
8255 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8256 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8257 PL_in_my == KEY_my ? "my" : "state",
8258 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8260 UTF ? SVf_UTF8 : 0);
8264 pl_yylval.opval = newOP(OP_PADANY, 0);
8265 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8266 UTF ? SVf_UTF8 : 0);
8272 build the ops for accesses to a my() variable.
8277 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8279 if (tmp != NOT_IN_PAD) {
8280 /* might be an "our" variable" */
8281 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8282 /* build ops for a bareword */
8283 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8284 HEK * const stashname = HvNAME_HEK(stash);
8285 SV * const sym = newSVhek(stashname);
8286 sv_catpvs(sym, "::");
8287 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8288 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8289 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8293 ((PL_tokenbuf[0] == '$') ? SVt_PV
8294 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8299 pl_yylval.opval = newOP(OP_PADANY, 0);
8300 pl_yylval.opval->op_targ = tmp;
8306 Whine if they've said @foo in a doublequoted string,
8307 and @foo isn't a variable we can find in the symbol
8310 if (ckWARN(WARN_AMBIGUOUS) &&
8311 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8312 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8313 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8314 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8315 /* DO NOT warn for @- and @+ */
8316 && !( PL_tokenbuf[2] == '\0' &&
8317 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8320 /* Downgraded from fatal to warning 20000522 mjd */
8321 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8322 "Possible unintended interpolation of %"UTF8f
8324 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8328 /* build ops for a bareword */
8329 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8330 newSVpvn_flags(PL_tokenbuf + 1,
8332 UTF ? SVf_UTF8 : 0 ));
8333 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8335 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8336 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8337 | ( UTF ? SVf_UTF8 : 0 ),
8338 ((PL_tokenbuf[0] == '$') ? SVt_PV
8339 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8345 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8347 PERL_ARGS_ASSERT_CHECKCOMMA;
8349 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8350 if (ckWARN(WARN_SYNTAX)) {
8353 for (w = s+2; *w && level; w++) {
8361 /* the list of chars below is for end of statements or
8362 * block / parens, boolean operators (&&, ||, //) and branch
8363 * constructs (or, and, if, until, unless, while, err, for).
8364 * Not a very solid hack... */
8365 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8366 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8367 "%s (...) interpreted as function",name);
8370 while (s < PL_bufend && isSPACE(*s))
8374 while (s < PL_bufend && isSPACE(*s))
8376 if (isIDFIRST_lazy_if(s,UTF)) {
8377 const char * const w = s;
8378 s += UTF ? UTF8SKIP(s) : 1;
8379 while (isWORDCHAR_lazy_if(s,UTF))
8380 s += UTF ? UTF8SKIP(s) : 1;
8381 while (s < PL_bufend && isSPACE(*s))
8386 if (keyword(w, s - w, 0))
8389 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8390 if (gv && GvCVu(gv))
8394 Copy(w, tmpbuf+1, s - w, char);
8396 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8397 if (off != NOT_IN_PAD) return;
8399 Perl_croak(aTHX_ "No comma allowed after %s", what);
8404 /* S_new_constant(): do any overload::constant lookup.
8406 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8407 Best used as sv=new_constant(..., sv, ...).
8408 If s, pv are NULL, calls subroutine with one argument,
8409 and <type> is used with error messages only.
8410 <type> is assumed to be well formed UTF-8 */
8413 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8414 SV *sv, SV *pv, const char *type, STRLEN typelen)
8417 HV * table = GvHV(PL_hintgv); /* ^H */
8422 const char *why1 = "", *why2 = "", *why3 = "";
8424 PERL_ARGS_ASSERT_NEW_CONSTANT;
8425 /* We assume that this is true: */
8426 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8429 /* charnames doesn't work well if there have been errors found */
8430 if (PL_error_count > 0 && *key == 'c')
8432 SvREFCNT_dec_NN(sv);
8433 return &PL_sv_undef;
8436 sv_2mortal(sv); /* Parent created it permanently */
8438 || ! (PL_hints & HINT_LOCALIZE_HH)
8439 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8444 /* Here haven't found what we're looking for. If it is charnames,
8445 * perhaps it needs to be loaded. Try doing that before giving up */
8447 Perl_load_module(aTHX_
8449 newSVpvs("_charnames"),
8450 /* version parameter; no need to specify it, as if
8451 * we get too early a version, will fail anyway,
8452 * not being able to find '_charnames' */
8457 assert(sp == PL_stack_sp);
8458 table = GvHV(PL_hintgv);
8460 && (PL_hints & HINT_LOCALIZE_HH)
8461 && (cvp = hv_fetch(table, key, keylen, FALSE))
8467 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8468 msg = Perl_form(aTHX_
8469 "Constant(%.*s) unknown",
8470 (int)(type ? typelen : len),
8476 why3 = "} is not defined";
8479 msg = Perl_form(aTHX_
8480 /* The +3 is for '\N{'; -4 for that, plus '}' */
8481 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8485 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8486 (int)(type ? typelen : len),
8487 (type ? type: s), why1, why2, why3);
8490 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8491 return SvREFCNT_inc_simple_NN(sv);
8496 pv = newSVpvn_flags(s, len, SVs_TEMP);
8498 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8500 typesv = &PL_sv_undef;
8502 PUSHSTACKi(PERLSI_OVERLOAD);
8514 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8518 /* Check the eval first */
8519 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8521 const char * errstr;
8522 sv_catpvs(errsv, "Propagated");
8523 errstr = SvPV_const(errsv, errlen);
8524 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8526 res = SvREFCNT_inc_simple_NN(sv);
8530 SvREFCNT_inc_simple_void_NN(res);
8539 why1 = "Call to &{$^H{";
8541 why3 = "}} did not return a defined value";
8543 (void)sv_2mortal(sv);
8550 PERL_STATIC_INLINE void
8551 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8552 PERL_ARGS_ASSERT_PARSE_IDENT;
8556 Perl_croak(aTHX_ "%s", ident_too_long);
8557 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8558 /* The UTF-8 case must come first, otherwise things
8559 * like c\N{COMBINING TILDE} would start failing, as the
8560 * isWORDCHAR_A case below would gobble the 'c' up.
8563 char *t = *s + UTF8SKIP(*s);
8564 while (isIDCONT_utf8((U8*)t))
8566 if (*d + (t - *s) > e)
8567 Perl_croak(aTHX_ "%s", ident_too_long);
8568 Copy(*s, *d, t - *s, char);
8572 else if ( isWORDCHAR_A(**s) ) {
8575 } while (isWORDCHAR_A(**s) && *d < e);
8577 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8582 else if (allow_package && **s == ':' && (*s)[1] == ':'
8583 /* Disallow things like Foo::$bar. For the curious, this is
8584 * the code path that triggers the "Bad name after" warning
8585 * when looking for barewords.
8587 && (*s)[2] != '$') {
8597 /* Returns a NUL terminated string, with the length of the string written to
8601 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8604 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8605 bool is_utf8 = cBOOL(UTF);
8607 PERL_ARGS_ASSERT_SCAN_WORD;
8609 parse_ident(&s, &d, e, allow_package, is_utf8);
8616 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8618 I32 herelines = PL_parser->herelines;
8619 SSize_t bracket = -1;
8622 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8623 bool is_utf8 = cBOOL(UTF);
8624 I32 orig_copline = 0, tmp_copline = 0;
8626 PERL_ARGS_ASSERT_SCAN_IDENT;
8628 if (isSPACE(*s) || !*s)
8631 while (isDIGIT(*s)) {
8633 Perl_croak(aTHX_ "%s", ident_too_long);
8638 parse_ident(&s, &d, e, 1, is_utf8);
8643 /* Either a digit variable, or parse_ident() found an identifier
8644 (anything valid as a bareword), so job done and return. */
8645 if (PL_lex_state != LEX_NORMAL)
8646 PL_lex_state = LEX_INTERPENDMAYBE;
8649 if (*s == '$' && s[1] &&
8650 (isIDFIRST_lazy_if(s+1,is_utf8)
8651 || isDIGIT_A((U8)s[1])
8654 || strnEQ(s+1,"::",2)) )
8656 /* Dereferencing a value in a scalar variable.
8657 The alternatives are different syntaxes for a scalar variable.
8658 Using ' as a leading package separator isn't allowed. :: is. */
8661 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8663 bracket = s - SvPVX(PL_linestr);
8665 orig_copline = CopLINE(PL_curcop);
8666 if (s < PL_bufend && isSPACE(*s)) {
8671 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8672 * iff Unicode semantics are to be used. The legal ones are any of:
8673 * a) all ASCII characters except:
8674 * 1) space-type ones, like \t and SPACE;
8677 * The final case currently doesn't get this far in the program, so we
8678 * don't test for it. If that were to change, it would be ok to allow it.
8679 * c) When not under Unicode rules, any upper Latin1 character
8680 * d) Otherwise, when unicode rules are used, all XIDS characters.
8682 * Because all ASCII characters have the same representation whether
8683 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8684 * '{' without knowing if is UTF-8 or not.
8685 * EBCDIC already uses the rules that ASCII platforms will use after the
8686 * deprecation cycle; see comment below about the deprecation. */
8688 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8689 (isGRAPH_A(*(s)) || ((is_utf8) \
8690 ? isIDFIRST_utf8((U8*) (s)) \
8692 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8694 # define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s)) \
8695 && LIKELY(*(s) != '\0') \
8697 || isASCII_utf8((U8*) (s)) \
8698 || isIDFIRST_utf8((U8*) (s))))
8700 if ((s <= PL_bufend - (is_utf8)
8703 && VALID_LEN_ONE_IDENT(s, is_utf8))
8705 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8706 * because often it has no graphic representation. (We can't get to
8707 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8710 ? ! isGRAPH_utf8( (U8*) s)
8711 : (! isGRAPH_L1( (U8) *s)
8712 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8714 /* Split messages for back compat */
8715 if (isCNTRL_A( (U8) *s)) {
8716 deprecate("literal control characters in variable names");
8719 deprecate("literal non-graphic characters in variable names");
8724 const STRLEN skip = UTF8SKIP(s);
8727 for ( i = 0; i < skip; i++ )
8735 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8736 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8740 /* Warn about ambiguous code after unary operators if {...} notation isn't
8741 used. There's no difference in ambiguity; it's merely a heuristic
8742 about when not to warn. */
8743 else if (ck_uni && bracket == -1)
8745 if (bracket != -1) {
8746 /* If we were processing {...} notation then... */
8747 if (isIDFIRST_lazy_if(d,is_utf8)) {
8748 /* if it starts as a valid identifier, assume that it is one.
8749 (the later check for } being at the expected point will trap
8750 cases where this doesn't pan out.) */
8751 d += is_utf8 ? UTF8SKIP(d) : 1;
8752 parse_ident(&s, &d, e, 1, is_utf8);
8754 tmp_copline = CopLINE(PL_curcop);
8755 if (s < PL_bufend && isSPACE(*s)) {
8758 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8759 /* ${foo[0]} and ${foo{bar}} notation. */
8760 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8761 const char * const brack =
8763 ((*s == '[') ? "[...]" : "{...}");
8764 orig_copline = CopLINE(PL_curcop);
8765 CopLINE_set(PL_curcop, tmp_copline);
8766 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8767 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8768 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8769 funny, dest, brack, funny, dest, brack);
8770 CopLINE_set(PL_curcop, orig_copline);
8773 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8774 PL_lex_allbrackets++;
8778 /* Handle extended ${^Foo} variables
8779 * 1999-02-27 mjd-perl-patch@plover.com */
8780 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8784 while (isWORDCHAR(*s) && d < e) {
8788 Perl_croak(aTHX_ "%s", ident_too_long);
8793 tmp_copline = CopLINE(PL_curcop);
8794 if (s < PL_bufend && isSPACE(*s)) {
8798 /* Expect to find a closing } after consuming any trailing whitespace.
8802 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8803 PL_lex_state = LEX_INTERPEND;
8806 if (PL_lex_state == LEX_NORMAL) {
8807 if (ckWARN(WARN_AMBIGUOUS) &&
8808 (keyword(dest, d - dest, 0)
8809 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8811 SV *tmp = newSVpvn_flags( dest, d - dest,
8812 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8815 orig_copline = CopLINE(PL_curcop);
8816 CopLINE_set(PL_curcop, tmp_copline);
8817 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8818 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8819 funny, SVfARG(tmp), funny, SVfARG(tmp));
8820 CopLINE_set(PL_curcop, orig_copline);
8825 /* Didn't find the closing } at the point we expected, so restore
8826 state such that the next thing to process is the opening { and */
8827 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8828 CopLINE_set(PL_curcop, orig_copline);
8829 PL_parser->herelines = herelines;
8833 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8834 PL_lex_state = LEX_INTERPEND;
8839 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8841 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8842 * found in the parse starting at 's', based on the subset that are valid
8843 * in this context input to this routine in 'valid_flags'. Advances s.
8844 * Returns TRUE if the input should be treated as a valid flag, so the next
8845 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8846 * upon first call on the current regex. This routine will set it to any
8847 * charset modifier found. The caller shouldn't change it. This way,
8848 * another charset modifier encountered in the parse can be detected as an
8849 * error, as we have decided to allow only one */
8852 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8854 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8855 if (isWORDCHAR_lazy_if(*s, UTF)) {
8856 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8857 UTF ? SVf_UTF8 : 0);
8859 /* Pretend that it worked, so will continue processing before
8868 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8869 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8870 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8871 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8872 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8873 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8874 case LOCALE_PAT_MOD:
8876 goto multiple_charsets;
8878 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8881 case UNICODE_PAT_MOD:
8883 goto multiple_charsets;
8885 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8888 case ASCII_RESTRICT_PAT_MOD:
8890 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8894 /* Error if previous modifier wasn't an 'a', but if it was, see
8895 * if, and accept, a second occurrence (only) */
8897 || get_regex_charset(*pmfl)
8898 != REGEX_ASCII_RESTRICTED_CHARSET)
8900 goto multiple_charsets;
8902 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8906 case DEPENDS_PAT_MOD:
8908 goto multiple_charsets;
8910 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8919 if (*charset != c) {
8920 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8922 else if (c == 'a') {
8923 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8924 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8927 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8930 /* Pretend that it worked, so will continue processing before dieing */
8936 S_scan_pat(pTHX_ char *start, I32 type)
8940 const char * const valid_flags =
8941 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8942 char charset = '\0'; /* character set modifier */
8943 unsigned int x_mod_count = 0;
8945 PERL_ARGS_ASSERT_SCAN_PAT;
8947 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8949 Perl_croak(aTHX_ "Search pattern not terminated");
8951 pm = (PMOP*)newPMOP(type, 0);
8952 if (PL_multi_open == '?') {
8953 /* This is the only point in the code that sets PMf_ONCE: */
8954 pm->op_pmflags |= PMf_ONCE;
8956 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8957 allows us to restrict the list needed by reset to just the ??
8959 assert(type != OP_TRANS);
8961 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8964 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8967 elements = mg->mg_len / sizeof(PMOP**);
8968 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8969 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8970 mg->mg_len = elements * sizeof(PMOP**);
8971 PmopSTASH_set(pm,PL_curstash);
8975 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8976 * anon CV. False positives like qr/[(?{]/ are harmless */
8978 if (type == OP_QR) {
8980 char *e, *p = SvPV(PL_lex_stuff, len);
8982 for (; p < e; p++) {
8983 if (p[0] == '(' && p[1] == '?'
8984 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8986 pm->op_pmflags |= PMf_HAS_CV;
8990 pm->op_pmflags |= PMf_IS_QR;
8993 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
8994 &s, &charset, &x_mod_count))
8996 /* issue a warning if /c is specified,but /g is not */
8997 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8999 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9000 "Use of /c modifier is meaningless without /g" );
9003 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9005 PL_lex_op = (OP*)pm;
9006 pl_yylval.ival = OP_MATCH;
9011 S_scan_subst(pTHX_ char *start)
9018 char charset = '\0'; /* character set modifier */
9019 unsigned int x_mod_count = 0;
9022 PERL_ARGS_ASSERT_SCAN_SUBST;
9024 pl_yylval.ival = OP_NULL;
9026 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9029 Perl_croak(aTHX_ "Substitution pattern not terminated");
9033 first_start = PL_multi_start;
9034 first_line = CopLINE(PL_curcop);
9035 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9037 SvREFCNT_dec_NN(PL_lex_stuff);
9038 PL_lex_stuff = NULL;
9039 Perl_croak(aTHX_ "Substitution replacement not terminated");
9041 PL_multi_start = first_start; /* so whole substitution is taken together */
9043 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9047 if (*s == EXEC_PAT_MOD) {
9051 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9052 &s, &charset, &x_mod_count))
9058 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9060 if ((pm->op_pmflags & PMf_CONTINUE)) {
9061 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9065 SV * const repl = newSVpvs("");
9068 pm->op_pmflags |= PMf_EVAL;
9071 sv_catpvs(repl, "eval ");
9073 sv_catpvs(repl, "do ");
9075 sv_catpvs(repl, "{");
9076 sv_catsv(repl, PL_sublex_info.repl);
9077 sv_catpvs(repl, "}");
9079 SvREFCNT_dec(PL_sublex_info.repl);
9080 PL_sublex_info.repl = repl;
9082 if (CopLINE(PL_curcop) != first_line) {
9083 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9084 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9085 CopLINE(PL_curcop) - first_line;
9086 CopLINE_set(PL_curcop, first_line);
9089 PL_lex_op = (OP*)pm;
9090 pl_yylval.ival = OP_SUBST;
9095 S_scan_trans(pTHX_ char *start)
9102 bool nondestruct = 0;
9105 PERL_ARGS_ASSERT_SCAN_TRANS;
9107 pl_yylval.ival = OP_NULL;
9109 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9111 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9115 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9117 SvREFCNT_dec_NN(PL_lex_stuff);
9118 PL_lex_stuff = NULL;
9119 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9122 complement = del = squash = 0;
9126 complement = OPpTRANS_COMPLEMENT;
9129 del = OPpTRANS_DELETE;
9132 squash = OPpTRANS_SQUASH;
9144 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9145 o->op_private &= ~OPpTRANS_ALL;
9146 o->op_private |= del|squash|complement|
9147 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9148 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9151 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9158 Takes a pointer to the first < in <<FOO.
9159 Returns a pointer to the byte following <<FOO.
9161 This function scans a heredoc, which involves different methods
9162 depending on whether we are in a string eval, quoted construct, etc.
9163 This is because PL_linestr could containing a single line of input, or
9164 a whole string being evalled, or the contents of the current quote-
9167 The two basic methods are:
9168 - Steal lines from the input stream
9169 - Scan the heredoc in PL_linestr and remove it therefrom
9171 In a file scope or filtered eval, the first method is used; in a
9172 string eval, the second.
9174 In a quote-like operator, we have to choose between the two,
9175 depending on where we can find a newline. We peek into outer lex-
9176 ing scopes until we find one with a newline in it. If we reach the
9177 outermost lexing scope and it is a file, we use the stream method.
9178 Otherwise it is treated as an eval.
9182 S_scan_heredoc(pTHX_ char *s)
9184 I32 op_type = OP_SCALAR;
9191 const bool infile = PL_rsfp || PL_parser->filtered;
9192 const line_t origline = CopLINE(PL_curcop);
9193 LEXSHARED *shared = PL_parser->lex_shared;
9195 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9198 d = PL_tokenbuf + 1;
9199 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9200 *PL_tokenbuf = '\n';
9202 while (SPACE_OR_TAB(*peek))
9204 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9207 s = delimcpy(d, e, s, PL_bufend, term, &len);
9209 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9215 /* <<\FOO is equivalent to <<'FOO' */
9219 if (!isWORDCHAR_lazy_if(s,UTF))
9220 deprecate("bare << to mean <<\"\"");
9222 while (isWORDCHAR_lazy_if(peek,UTF)) {
9223 peek += UTF ? UTF8SKIP(peek) : 1;
9225 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9226 Copy(s, d, len, char);
9230 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9231 Perl_croak(aTHX_ "Delimiter for here document is too long");
9234 len = d - PL_tokenbuf;
9236 #ifndef PERL_STRICT_CR
9237 d = strchr(s, '\r');
9239 char * const olds = s;
9241 while (s < PL_bufend) {
9247 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9256 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9261 tmpstr = newSV_type(SVt_PVIV);
9265 SvIV_set(tmpstr, -1);
9267 else if (term == '`') {
9268 op_type = OP_BACKTICK;
9269 SvIV_set(tmpstr, '\\');
9272 PL_multi_start = origline + 1 + PL_parser->herelines;
9273 PL_multi_open = PL_multi_close = '<';
9274 /* inside a string eval or quote-like operator */
9275 if (!infile || PL_lex_inwhat) {
9278 char * const olds = s;
9279 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9280 /* These two fields are not set until an inner lexing scope is
9281 entered. But we need them set here. */
9282 shared->ls_bufptr = s;
9283 shared->ls_linestr = PL_linestr;
9285 /* Look for a newline. If the current buffer does not have one,
9286 peek into the line buffer of the parent lexing scope, going
9287 up as many levels as necessary to find one with a newline
9290 while (!(s = (char *)memchr(
9291 (void *)shared->ls_bufptr, '\n',
9292 SvEND(shared->ls_linestr)-shared->ls_bufptr
9294 shared = shared->ls_prev;
9295 /* shared is only null if we have gone beyond the outermost
9296 lexing scope. In a file, we will have broken out of the
9297 loop in the previous iteration. In an eval, the string buf-
9298 fer ends with "\n;", so the while condition above will have
9299 evaluated to false. So shared can never be null. Or so you
9300 might think. Odd syntax errors like s;@{<<; can gobble up
9301 the implicit semicolon at the end of a flie, causing the
9302 file handle to be closed even when we are not in a string
9303 eval. So shared may be null in that case. */
9304 if (UNLIKELY(!shared))
9306 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9307 most lexing scope. In a file, shared->ls_linestr at that
9308 level is just one line, so there is no body to steal. */
9309 if (infile && !shared->ls_prev) {
9315 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9318 linestr = shared->ls_linestr;
9319 bufend = SvEND(linestr);
9321 while (s < bufend - len + 1 &&
9322 memNE(s,PL_tokenbuf,len) ) {
9324 ++PL_parser->herelines;
9326 if (s >= bufend - len + 1) {
9329 sv_setpvn(tmpstr,d+1,s-d);
9331 /* the preceding stmt passes a newline */
9332 PL_parser->herelines++;
9334 /* s now points to the newline after the heredoc terminator.
9335 d points to the newline before the body of the heredoc.
9338 /* We are going to modify linestr in place here, so set
9339 aside copies of the string if necessary for re-evals or
9341 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9342 check shared->re_eval_str. */
9343 if (shared->re_eval_start || shared->re_eval_str) {
9344 /* Set aside the rest of the regexp */
9345 if (!shared->re_eval_str)
9346 shared->re_eval_str =
9347 newSVpvn(shared->re_eval_start,
9348 bufend - shared->re_eval_start);
9349 shared->re_eval_start -= s-d;
9351 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9352 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9353 cx->blk_eval.cur_text == linestr)
9355 cx->blk_eval.cur_text = newSVsv(linestr);
9356 SvSCREAM_on(cx->blk_eval.cur_text);
9358 /* Copy everything from s onwards back to d. */
9359 Move(s,d,bufend-s + 1,char);
9360 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9361 /* Setting PL_bufend only applies when we have not dug deeper
9362 into other scopes, because sublex_done sets PL_bufend to
9363 SvEND(PL_linestr). */
9364 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9371 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9372 term = PL_tokenbuf[1];
9374 linestr_save = PL_linestr; /* must restore this afterwards */
9375 d = s; /* and this */
9376 PL_linestr = newSVpvs("");
9377 PL_bufend = SvPVX(PL_linestr);
9379 PL_bufptr = PL_bufend;
9380 CopLINE_set(PL_curcop,
9381 origline + 1 + PL_parser->herelines);
9382 if (!lex_next_chunk(LEX_NO_TERM)
9383 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9384 /* Simply freeing linestr_save might seem simpler here, as it
9385 does not matter what PL_linestr points to, since we are
9386 about to croak; but in a quote-like op, linestr_save
9387 will have been prospectively freed already, via
9388 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9389 restore PL_linestr. */
9390 SvREFCNT_dec_NN(PL_linestr);
9391 PL_linestr = linestr_save;
9394 CopLINE_set(PL_curcop, origline);
9395 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9396 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9397 /* ^That should be enough to avoid this needing to grow: */
9398 sv_catpvs(PL_linestr, "\n\0");
9399 assert(s == SvPVX(PL_linestr));
9400 PL_bufend = SvEND(PL_linestr);
9403 PL_parser->herelines++;
9404 PL_last_lop = PL_last_uni = NULL;
9405 #ifndef PERL_STRICT_CR
9406 if (PL_bufend - PL_linestart >= 2) {
9407 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9408 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9410 PL_bufend[-2] = '\n';
9412 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9414 else if (PL_bufend[-1] == '\r')
9415 PL_bufend[-1] = '\n';
9417 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9418 PL_bufend[-1] = '\n';
9420 if (*s == term && PL_bufend-s >= len
9421 && memEQ(s,PL_tokenbuf + 1,len)) {
9422 SvREFCNT_dec(PL_linestr);
9423 PL_linestr = linestr_save;
9424 PL_linestart = SvPVX(linestr_save);
9425 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9430 sv_catsv(tmpstr,PL_linestr);
9434 PL_multi_end = origline + PL_parser->herelines;
9435 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9436 SvPV_shrink_to_cur(tmpstr);
9439 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9441 else if (IN_ENCODING)
9442 sv_recode_to_utf8(tmpstr, _get_encoding());
9444 PL_lex_stuff = tmpstr;
9445 pl_yylval.ival = op_type;
9449 SvREFCNT_dec(tmpstr);
9450 CopLINE_set(PL_curcop, origline);
9451 missingterm(PL_tokenbuf + 1);
9455 takes: current position in input buffer
9456 returns: new position in input buffer
9457 side-effects: pl_yylval and lex_op are set.
9462 <<>> read from ARGV without magic open
9463 <FH> read from filehandle
9464 <pkg::FH> read from package qualified filehandle
9465 <pkg'FH> read from package qualified filehandle
9466 <$fh> read from filehandle in $fh
9472 S_scan_inputsymbol(pTHX_ char *start)
9474 char *s = start; /* current position in buffer */
9477 bool nomagicopen = FALSE;
9478 char *d = PL_tokenbuf; /* start of temp holding space */
9479 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9481 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9483 end = strchr(s, '\n');
9486 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9493 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9495 /* die if we didn't have space for the contents of the <>,
9496 or if it didn't end, or if we see a newline
9499 if (len >= (I32)sizeof PL_tokenbuf)
9500 Perl_croak(aTHX_ "Excessively long <> operator");
9502 Perl_croak(aTHX_ "Unterminated <> operator");
9507 Remember, only scalar variables are interpreted as filehandles by
9508 this code. Anything more complex (e.g., <$fh{$num}>) will be
9509 treated as a glob() call.
9510 This code makes use of the fact that except for the $ at the front,
9511 a scalar variable and a filehandle look the same.
9513 if (*d == '$' && d[1]) d++;
9515 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9516 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9517 d += UTF ? UTF8SKIP(d) : 1;
9519 /* If we've tried to read what we allow filehandles to look like, and
9520 there's still text left, then it must be a glob() and not a getline.
9521 Use scan_str to pull out the stuff between the <> and treat it
9522 as nothing more than a string.
9525 if (d - PL_tokenbuf != len) {
9526 pl_yylval.ival = OP_GLOB;
9527 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9529 Perl_croak(aTHX_ "Glob not terminated");
9533 bool readline_overriden = FALSE;
9535 /* we're in a filehandle read situation */
9538 /* turn <> into <ARGV> */
9540 Copy("ARGV",d,5,char);
9542 /* Check whether readline() is overriden */
9543 if ((gv_readline = gv_override("readline",8)))
9544 readline_overriden = TRUE;
9546 /* if <$fh>, create the ops to turn the variable into a
9550 /* try to find it in the pad for this block, otherwise find
9551 add symbol table ops
9553 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9554 if (tmp != NOT_IN_PAD) {
9555 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9556 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9557 HEK * const stashname = HvNAME_HEK(stash);
9558 SV * const sym = sv_2mortal(newSVhek(stashname));
9559 sv_catpvs(sym, "::");
9565 OP * const o = newOP(OP_PADSV, 0);
9567 PL_lex_op = readline_overriden
9568 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9569 op_append_elem(OP_LIST, o,
9570 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9571 : (OP*)newUNOP(OP_READLINE, 0, o);
9579 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9581 PL_lex_op = readline_overriden
9582 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9583 op_append_elem(OP_LIST,
9584 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9585 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9586 : (OP*)newUNOP(OP_READLINE, 0,
9587 newUNOP(OP_RV2SV, 0,
9588 newGVOP(OP_GV, 0, gv)));
9590 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9591 pl_yylval.ival = OP_NULL;
9594 /* If it's none of the above, it must be a literal filehandle
9595 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9597 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9598 PL_lex_op = readline_overriden
9599 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9600 op_append_elem(OP_LIST,
9601 newGVOP(OP_GV, 0, gv),
9602 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9603 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9604 pl_yylval.ival = OP_NULL;
9614 start position in buffer
9615 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9616 only if they are of the open/close form
9617 keep_delims preserve the delimiters around the string
9618 re_reparse compiling a run-time /(?{})/:
9619 collapse // to /, and skip encoding src
9620 delimp if non-null, this is set to the position of
9621 the closing delimiter, or just after it if
9622 the closing and opening delimiters differ
9623 (i.e., the opening delimiter of a substitu-
9625 returns: position to continue reading from buffer
9626 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9627 updates the read buffer.
9629 This subroutine pulls a string out of the input. It is called for:
9630 q single quotes q(literal text)
9631 ' single quotes 'literal text'
9632 qq double quotes qq(interpolate $here please)
9633 " double quotes "interpolate $here please"
9634 qx backticks qx(/bin/ls -l)
9635 ` backticks `/bin/ls -l`
9636 qw quote words @EXPORT_OK = qw( func() $spam )
9637 m// regexp match m/this/
9638 s/// regexp substitute s/this/that/
9639 tr/// string transliterate tr/this/that/
9640 y/// string transliterate y/this/that/
9641 ($*@) sub prototypes sub foo ($)
9642 (stuff) sub attr parameters sub foo : attr(stuff)
9643 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9645 In most of these cases (all but <>, patterns and transliterate)
9646 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9647 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9648 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9651 It skips whitespace before the string starts, and treats the first
9652 character as the delimiter. If the delimiter is one of ([{< then
9653 the corresponding "close" character )]}> is used as the closing
9654 delimiter. It allows quoting of delimiters, and if the string has
9655 balanced delimiters ([{<>}]) it allows nesting.
9657 On success, the SV with the resulting string is put into lex_stuff or,
9658 if that is already non-NULL, into lex_repl. The second case occurs only
9659 when parsing the RHS of the special constructs s/// and tr/// (y///).
9660 For convenience, the terminating delimiter character is stuffed into
9665 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9669 SV *sv; /* scalar value: string */
9670 const char *tmps; /* temp string, used for delimiter matching */
9671 char *s = start; /* current position in the buffer */
9672 char term; /* terminating character */
9673 char *to; /* current position in the sv's data */
9674 I32 brackets = 1; /* bracket nesting level */
9675 bool has_utf8 = FALSE; /* is there any utf8 content? */
9676 I32 termcode; /* terminating char. code */
9677 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9678 STRLEN termlen; /* length of terminating string */
9679 int last_off = 0; /* last position for nesting bracket */
9682 PERL_ARGS_ASSERT_SCAN_STR;
9684 /* skip space before the delimiter */
9689 /* mark where we are, in case we need to report errors */
9692 /* after skipping whitespace, the next character is the terminator */
9695 termcode = termstr[0] = term;
9699 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9700 Copy(s, termstr, termlen, U8);
9701 if (!UTF8_IS_INVARIANT(term))
9705 /* mark where we are */
9706 PL_multi_start = CopLINE(PL_curcop);
9707 PL_multi_open = term;
9708 herelines = PL_parser->herelines;
9710 /* find corresponding closing delimiter */
9711 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9712 termcode = termstr[0] = term = tmps[5];
9714 PL_multi_close = term;
9716 if (PL_multi_open == PL_multi_close) {
9717 keep_bracketed_quoted = FALSE;
9720 /* create a new SV to hold the contents. 79 is the SV's initial length.
9721 What a random number. */
9722 sv = newSV_type(SVt_PVIV);
9724 SvIV_set(sv, termcode);
9725 (void)SvPOK_only(sv); /* validate pointer */
9727 /* move past delimiter and try to read a complete string */
9729 sv_catpvn(sv, s, termlen);
9732 if (IN_ENCODING && !UTF && !re_reparse) {
9736 int offset = s - SvPVX_const(PL_linestr);
9737 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9738 &offset, (char*)termstr, termlen);
9742 if (SvIsCOW(PL_linestr)) {
9743 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9744 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9745 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9746 char *buf = SvPVX(PL_linestr);
9747 bufend_pos = PL_parser->bufend - buf;
9748 bufptr_pos = PL_parser->bufptr - buf;
9749 oldbufptr_pos = PL_parser->oldbufptr - buf;
9750 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9751 linestart_pos = PL_parser->linestart - buf;
9752 last_uni_pos = PL_parser->last_uni
9753 ? PL_parser->last_uni - buf
9755 last_lop_pos = PL_parser->last_lop
9756 ? PL_parser->last_lop - buf
9759 PL_parser->lex_shared->re_eval_start ?
9760 PL_parser->lex_shared->re_eval_start - buf : 0;
9763 sv_force_normal(PL_linestr);
9765 buf = SvPVX(PL_linestr);
9766 PL_parser->bufend = buf + bufend_pos;
9767 PL_parser->bufptr = buf + bufptr_pos;
9768 PL_parser->oldbufptr = buf + oldbufptr_pos;
9769 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9770 PL_parser->linestart = buf + linestart_pos;
9771 if (PL_parser->last_uni)
9772 PL_parser->last_uni = buf + last_uni_pos;
9773 if (PL_parser->last_lop)
9774 PL_parser->last_lop = buf + last_lop_pos;
9775 if (PL_parser->lex_shared->re_eval_start)
9776 PL_parser->lex_shared->re_eval_start =
9777 buf + re_eval_start_pos;
9780 ns = SvPVX_const(PL_linestr) + offset;
9781 svlast = SvEND(sv) - 1;
9783 for (; s < ns; s++) {
9784 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9785 COPLINE_INC_WITH_HERELINES;
9788 goto read_more_line;
9790 /* handle quoted delimiters */
9791 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9793 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9795 if ((svlast-1 - t) % 2) {
9796 if (!keep_bracketed_quoted) {
9799 SvCUR_set(sv, SvCUR(sv) - 1);
9804 if (PL_multi_open == PL_multi_close) {
9810 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9811 /* At here, all closes are "was quoted" one,
9812 so we don't check PL_multi_close. */
9814 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9819 else if (*t == PL_multi_open)
9827 SvCUR_set(sv, w - SvPVX_const(sv));
9829 last_off = w - SvPVX(sv);
9830 if (--brackets <= 0)
9836 SvCUR_set(sv, SvCUR(sv) - 1);
9842 /* extend sv if need be */
9843 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9844 /* set 'to' to the next character in the sv's string */
9845 to = SvPVX(sv)+SvCUR(sv);
9847 /* if open delimiter is the close delimiter read unbridle */
9848 if (PL_multi_open == PL_multi_close) {
9849 for (; s < PL_bufend; s++,to++) {
9850 /* embedded newlines increment the current line number */
9851 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9852 COPLINE_INC_WITH_HERELINES;
9853 /* handle quoted delimiters */
9854 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9855 if (!keep_bracketed_quoted
9857 || (re_reparse && s[1] == '\\'))
9860 else /* any other quotes are simply copied straight through */
9863 /* terminate when run out of buffer (the for() condition), or
9864 have found the terminator */
9865 else if (*s == term) {
9868 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9871 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9877 /* if the terminator isn't the same as the start character (e.g.,
9878 matched brackets), we have to allow more in the quoting, and
9879 be prepared for nested brackets.
9882 /* read until we run out of string, or we find the terminator */
9883 for (; s < PL_bufend; s++,to++) {
9884 /* embedded newlines increment the line count */
9885 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9886 COPLINE_INC_WITH_HERELINES;
9887 /* backslashes can escape the open or closing characters */
9888 if (*s == '\\' && s+1 < PL_bufend) {
9889 if (!keep_bracketed_quoted &&
9890 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9897 /* allow nested opens and closes */
9898 else if (*s == PL_multi_close && --brackets <= 0)
9900 else if (*s == PL_multi_open)
9902 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9907 /* terminate the copied string and update the sv's end-of-string */
9909 SvCUR_set(sv, to - SvPVX_const(sv));
9912 * this next chunk reads more into the buffer if we're not done yet
9916 break; /* handle case where we are done yet :-) */
9918 #ifndef PERL_STRICT_CR
9919 if (to - SvPVX_const(sv) >= 2) {
9920 if ((to[-2] == '\r' && to[-1] == '\n') ||
9921 (to[-2] == '\n' && to[-1] == '\r'))
9925 SvCUR_set(sv, to - SvPVX_const(sv));
9927 else if (to[-1] == '\r')
9930 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9935 /* if we're out of file, or a read fails, bail and reset the current
9936 line marker so we can report where the unterminated string began
9938 COPLINE_INC_WITH_HERELINES;
9939 PL_bufptr = PL_bufend;
9940 if (!lex_next_chunk(0)) {
9942 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9948 /* at this point, we have successfully read the delimited string */
9950 if (!IN_ENCODING || UTF || re_reparse) {
9953 sv_catpvn(sv, s, termlen);
9956 if (has_utf8 || (IN_ENCODING && !re_reparse))
9959 PL_multi_end = CopLINE(PL_curcop);
9960 CopLINE_set(PL_curcop, PL_multi_start);
9961 PL_parser->herelines = herelines;
9963 /* if we allocated too much space, give some back */
9964 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9965 SvLEN_set(sv, SvCUR(sv) + 1);
9966 SvPV_renew(sv, SvLEN(sv));
9969 /* decide whether this is the first or second quoted string we've read
9974 PL_sublex_info.repl = sv;
9977 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9983 takes: pointer to position in buffer
9984 returns: pointer to new position in buffer
9985 side-effects: builds ops for the constant in pl_yylval.op
9987 Read a number in any of the formats that Perl accepts:
9989 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9990 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9991 0b[01](_?[01])* binary integers
9992 0[0-7](_?[0-7])* octal integers
9993 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9994 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9996 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9999 If it reads a number without a decimal point or an exponent, it will
10000 try converting the number to an integer and see if it can do so
10001 without loss of precision.
10005 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10007 const char *s = start; /* current position in buffer */
10008 char *d; /* destination in temp buffer */
10009 char *e; /* end of temp buffer */
10010 NV nv; /* number read, as a double */
10011 SV *sv = NULL; /* place to put the converted number */
10012 bool floatit; /* boolean: int or float? */
10013 const char *lastub = NULL; /* position of last underbar */
10014 static const char* const number_too_long = "Number too long";
10015 /* Hexadecimal floating point.
10017 * In many places (where we have quads and NV is IEEE 754 double)
10018 * we can fit the mantissa bits of a NV into an unsigned quad.
10019 * (Note that UVs might not be quads even when we have quads.)
10020 * This will not work everywhere, though (either no quads, or
10021 * using long doubles), in which case we have to resort to NV,
10022 * which will probably mean horrible loss of precision due to
10023 * multiple fp operations. */
10024 bool hexfp = FALSE;
10025 int total_bits = 0;
10026 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10027 # define HEXFP_UQUAD
10028 Uquad_t hexfp_uquad = 0;
10029 int hexfp_frac_bits = 0;
10034 NV hexfp_mult = 1.0;
10035 UV high_non_zero = 0; /* highest digit */
10037 PERL_ARGS_ASSERT_SCAN_NUM;
10039 /* We use the first character to decide what type of number this is */
10043 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10045 /* if it starts with a 0, it could be an octal number, a decimal in
10046 0.13 disguise, or a hexadecimal number, or a binary number. */
10050 u holds the "number so far"
10051 shift the power of 2 of the base
10052 (hex == 4, octal == 3, binary == 1)
10053 overflowed was the number more than we can hold?
10055 Shift is used when we add a digit. It also serves as an "are
10056 we in octal/hex/binary?" indicator to disallow hex characters
10057 when in octal mode.
10062 bool overflowed = FALSE;
10063 bool just_zero = TRUE; /* just plain 0 or binary number? */
10064 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10065 static const char* const bases[5] =
10066 { "", "binary", "", "octal", "hexadecimal" };
10067 static const char* const Bases[5] =
10068 { "", "Binary", "", "Octal", "Hexadecimal" };
10069 static const char* const maxima[5] =
10071 "0b11111111111111111111111111111111",
10075 const char *base, *Base, *max;
10077 /* check for hex */
10078 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10082 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10087 /* check for a decimal in disguise */
10088 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10090 /* so it must be octal */
10097 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10098 "Misplaced _ in number");
10102 base = bases[shift];
10103 Base = Bases[shift];
10104 max = maxima[shift];
10106 /* read the rest of the number */
10108 /* x is used in the overflow test,
10109 b is the digit we're adding on. */
10114 /* if we don't mention it, we're done */
10118 /* _ are ignored -- but warned about if consecutive */
10120 if (lastub && s == lastub + 1)
10121 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10122 "Misplaced _ in number");
10126 /* 8 and 9 are not octal */
10127 case '8': case '9':
10129 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10133 case '2': case '3': case '4':
10134 case '5': case '6': case '7':
10136 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10139 case '0': case '1':
10140 b = *s++ & 15; /* ASCII digit -> value of digit */
10144 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10145 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10146 /* make sure they said 0x */
10149 b = (*s++ & 7) + 9;
10151 /* Prepare to put the digit we have onto the end
10152 of the number so far. We check for overflows.
10158 x = u << shift; /* make room for the digit */
10160 total_bits += shift;
10162 if ((x >> shift) != u
10163 && !(PL_hints & HINT_NEW_BINARY)) {
10166 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10167 "Integer overflow in %s number",
10170 u = x | b; /* add the digit to the end */
10173 n *= nvshift[shift];
10174 /* If an NV has not enough bits in its
10175 * mantissa to represent an UV this summing of
10176 * small low-order numbers is a waste of time
10177 * (because the NV cannot preserve the
10178 * low-order bits anyway): we could just
10179 * remember when did we overflow and in the
10180 * end just multiply n by the right
10185 if (high_non_zero == 0 && b > 0)
10188 /* this could be hexfp, but peek ahead
10189 * to avoid matching ".." */
10190 if (UNLIKELY(HEXFP_PEEK(s))) {
10198 /* if we get here, we had success: make a scalar value from
10203 /* final misplaced underbar check */
10204 if (s[-1] == '_') {
10205 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10208 if (UNLIKELY(HEXFP_PEEK(s))) {
10209 /* Do sloppy (on the underbars) but quick detection
10210 * (and value construction) for hexfp, the decimal
10211 * detection will shortly be more thorough with the
10212 * underbar checks. */
10216 #else /* HEXFP_NV */
10221 NV mult = 1 / 16.0;
10224 while (isXDIGIT(*h) || *h == '_') {
10225 if (isXDIGIT(*h)) {
10226 U8 b = XDIGIT_VALUE(*h);
10227 total_bits += shift;
10229 hexfp_uquad <<= shift;
10231 hexfp_frac_bits += shift;
10232 #else /* HEXFP_NV */
10233 hexfp_nv += b * mult;
10241 if (total_bits >= 4) {
10242 if (high_non_zero < 0x8)
10244 if (high_non_zero < 0x4)
10246 if (high_non_zero < 0x2)
10250 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10251 bool negexp = FALSE;
10255 else if (*h == '-') {
10261 while (isDIGIT(*h) || *h == '_') {
10264 hexfp_exp += *h - '0';
10267 -hexfp_exp < NV_MIN_EXP - 1) {
10268 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10269 "Hexadecimal float: exponent underflow");
10276 hexfp_exp > NV_MAX_EXP - 1) {
10277 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10278 "Hexadecimal float: exponent overflow");
10287 hexfp_exp = -hexfp_exp;
10289 hexfp_exp -= hexfp_frac_bits;
10291 hexfp_mult = pow(2.0, hexfp_exp);
10299 if (n > 4294967295.0)
10300 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10301 "%s number > %s non-portable",
10307 if (u > 0xffffffff)
10308 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10309 "%s number > %s non-portable",
10314 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10315 sv = new_constant(start, s - start, "integer",
10316 sv, NULL, NULL, 0);
10317 else if (PL_hints & HINT_NEW_BINARY)
10318 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10323 handle decimal numbers.
10324 we're also sent here when we read a 0 as the first digit
10326 case '1': case '2': case '3': case '4': case '5':
10327 case '6': case '7': case '8': case '9': case '.':
10330 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10339 /* read next group of digits and _ and copy into d */
10340 while (isDIGIT(*s) || *s == '_' ||
10341 UNLIKELY(hexfp && isXDIGIT(*s))) {
10342 /* skip underscores, checking for misplaced ones
10346 if (lastub && s == lastub + 1)
10347 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10348 "Misplaced _ in number");
10352 /* check for end of fixed-length buffer */
10354 Perl_croak(aTHX_ "%s", number_too_long);
10355 /* if we're ok, copy the character */
10360 /* final misplaced underbar check */
10361 if (lastub && s == lastub + 1) {
10362 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10365 /* read a decimal portion if there is one. avoid
10366 3..5 being interpreted as the number 3. followed
10369 if (*s == '.' && s[1] != '.') {
10374 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10375 "Misplaced _ in number");
10379 /* copy, ignoring underbars, until we run out of digits.
10381 for (; isDIGIT(*s) || *s == '_' ||
10382 UNLIKELY(hexfp && isXDIGIT(*s));
10384 /* fixed length buffer check */
10386 Perl_croak(aTHX_ "%s", number_too_long);
10388 if (lastub && s == lastub + 1)
10389 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10390 "Misplaced _ in number");
10396 /* fractional part ending in underbar? */
10397 if (s[-1] == '_') {
10398 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10399 "Misplaced _ in number");
10401 if (*s == '.' && isDIGIT(s[1])) {
10402 /* oops, it's really a v-string, but without the "v" */
10408 /* read exponent part, if present */
10409 if ((isALPHA_FOLD_EQ(*s, 'e')
10410 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10411 && strchr("+-0123456789_", s[1]))
10415 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10416 ditto for p (hexfloats) */
10417 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10418 /* At least some Mach atof()s don't grok 'E' */
10421 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10428 /* stray preinitial _ */
10430 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10431 "Misplaced _ in number");
10435 /* allow positive or negative exponent */
10436 if (*s == '+' || *s == '-')
10439 /* stray initial _ */
10441 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10442 "Misplaced _ in number");
10446 /* read digits of exponent */
10447 while (isDIGIT(*s) || *s == '_') {
10450 Perl_croak(aTHX_ "%s", number_too_long);
10454 if (((lastub && s == lastub + 1) ||
10455 (!isDIGIT(s[1]) && s[1] != '_')))
10456 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10457 "Misplaced _ in number");
10465 We try to do an integer conversion first if no characters
10466 indicating "float" have been found.
10471 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10473 if (flags == IS_NUMBER_IN_UV) {
10475 sv = newSViv(uv); /* Prefer IVs over UVs. */
10478 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10479 if (uv <= (UV) IV_MIN)
10480 sv = newSViv(-(IV)uv);
10487 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10488 /* terminate the string */
10490 if (UNLIKELY(hexfp)) {
10491 # ifdef NV_MANT_DIG
10492 if (total_bits > NV_MANT_DIG)
10493 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10494 "Hexadecimal float: mantissa overflow");
10497 nv = hexfp_uquad * hexfp_mult;
10498 #else /* HEXFP_NV */
10499 nv = hexfp_nv * hexfp_mult;
10502 nv = Atof(PL_tokenbuf);
10504 RESTORE_LC_NUMERIC_UNDERLYING();
10509 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10510 const char *const key = floatit ? "float" : "integer";
10511 const STRLEN keylen = floatit ? 5 : 7;
10512 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10513 key, keylen, sv, NULL, NULL, 0);
10517 /* if it starts with a v, it could be a v-string */
10520 sv = newSV(5); /* preallocate storage space */
10521 ENTER_with_name("scan_vstring");
10523 s = scan_vstring(s, PL_bufend, sv);
10524 SvREFCNT_inc_simple_void_NN(sv);
10525 LEAVE_with_name("scan_vstring");
10529 /* make the op for the constant and return */
10532 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10534 lvalp->opval = NULL;
10540 S_scan_formline(pTHX_ char *s)
10544 SV * const stuff = newSVpvs("");
10545 bool needargs = FALSE;
10546 bool eofmt = FALSE;
10548 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10550 while (!needargs) {
10553 #ifdef PERL_STRICT_CR
10554 while (SPACE_OR_TAB(*t))
10557 while (SPACE_OR_TAB(*t) || *t == '\r')
10560 if (*t == '\n' || t == PL_bufend) {
10565 eol = (char *) memchr(s,'\n',PL_bufend-s);
10569 for (t = s; t < eol; t++) {
10570 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10572 goto enough; /* ~~ must be first line in formline */
10574 if (*t == '@' || *t == '^')
10578 sv_catpvn(stuff, s, eol-s);
10579 #ifndef PERL_STRICT_CR
10580 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10581 char *end = SvPVX(stuff) + SvCUR(stuff);
10584 SvCUR_set(stuff, SvCUR(stuff) - 1);
10592 if ((PL_rsfp || PL_parser->filtered)
10593 && PL_parser->form_lex_state == LEX_NORMAL) {
10595 PL_bufptr = PL_bufend;
10596 COPLINE_INC_WITH_HERELINES;
10597 got_some = lex_next_chunk(0);
10598 CopLINE_dec(PL_curcop);
10606 if (!SvCUR(stuff) || needargs)
10607 PL_lex_state = PL_parser->form_lex_state;
10608 if (SvCUR(stuff)) {
10609 PL_expect = XSTATE;
10611 const char *s2 = s;
10612 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10616 PL_expect = XTERMBLOCK;
10617 NEXTVAL_NEXTTOKE.ival = 0;
10620 NEXTVAL_NEXTTOKE.ival = 0;
10621 force_next(FORMLBRACK);
10624 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10626 else if (IN_ENCODING)
10627 sv_recode_to_utf8(stuff, _get_encoding());
10629 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10633 SvREFCNT_dec(stuff);
10635 PL_lex_formbrack = 0;
10641 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10643 const I32 oldsavestack_ix = PL_savestack_ix;
10644 CV* const outsidecv = PL_compcv;
10646 SAVEI32(PL_subline);
10647 save_item(PL_subname);
10648 SAVESPTR(PL_compcv);
10650 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10651 CvFLAGS(PL_compcv) |= flags;
10653 PL_subline = CopLINE(PL_curcop);
10654 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10655 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10656 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10657 if (outsidecv && CvPADLIST(outsidecv))
10658 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10660 return oldsavestack_ix;
10664 S_yywarn(pTHX_ const char *const s, U32 flags)
10666 PERL_ARGS_ASSERT_YYWARN;
10668 PL_in_eval |= EVAL_WARNONLY;
10669 yyerror_pv(s, flags);
10674 Perl_yyerror(pTHX_ const char *const s)
10676 PERL_ARGS_ASSERT_YYERROR;
10677 return yyerror_pvn(s, strlen(s), 0);
10681 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10683 PERL_ARGS_ASSERT_YYERROR_PV;
10684 return yyerror_pvn(s, strlen(s), flags);
10688 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10690 const char *context = NULL;
10693 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10694 int yychar = PL_parser->yychar;
10696 PERL_ARGS_ASSERT_YYERROR_PVN;
10698 if (!yychar || (yychar == ';' && !PL_rsfp))
10699 sv_catpvs(where_sv, "at EOF");
10700 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10701 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10702 PL_oldbufptr != PL_bufptr) {
10705 The code below is removed for NetWare because it abends/crashes on NetWare
10706 when the script has error such as not having the closing quotes like:
10707 if ($var eq "value)
10708 Checking of white spaces is anyway done in NetWare code.
10711 while (isSPACE(*PL_oldoldbufptr))
10714 context = PL_oldoldbufptr;
10715 contlen = PL_bufptr - PL_oldoldbufptr;
10717 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10718 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10721 The code below is removed for NetWare because it abends/crashes on NetWare
10722 when the script has error such as not having the closing quotes like:
10723 if ($var eq "value)
10724 Checking of white spaces is anyway done in NetWare code.
10727 while (isSPACE(*PL_oldbufptr))
10730 context = PL_oldbufptr;
10731 contlen = PL_bufptr - PL_oldbufptr;
10733 else if (yychar > 255)
10734 sv_catpvs(where_sv, "next token ???");
10735 else if (yychar == YYEMPTY) {
10736 if (PL_lex_state == LEX_NORMAL ||
10737 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10738 sv_catpvs(where_sv, "at end of line");
10739 else if (PL_lex_inpat)
10740 sv_catpvs(where_sv, "within pattern");
10742 sv_catpvs(where_sv, "within string");
10745 sv_catpvs(where_sv, "next char ");
10747 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10748 else if (isPRINT_LC(yychar)) {
10749 const char string = yychar;
10750 sv_catpvn(where_sv, &string, 1);
10753 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10755 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10756 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10757 OutCopFILE(PL_curcop),
10758 (IV)(PL_parser->preambling == NOLINE
10759 ? CopLINE(PL_curcop)
10760 : PL_parser->preambling));
10762 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10763 UTF8fARG(UTF, contlen, context));
10765 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10766 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10767 Perl_sv_catpvf(aTHX_ msg,
10768 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10769 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10772 if (PL_in_eval & EVAL_WARNONLY) {
10773 PL_in_eval &= ~EVAL_WARNONLY;
10774 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10778 if (PL_error_count >= 10) {
10780 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10781 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10782 SVfARG(errsv), OutCopFILE(PL_curcop));
10784 Perl_croak(aTHX_ "%s has too many errors.\n",
10785 OutCopFILE(PL_curcop));
10788 PL_in_my_stash = NULL;
10793 S_swallow_bom(pTHX_ U8 *s)
10795 const STRLEN slen = SvCUR(PL_linestr);
10797 PERL_ARGS_ASSERT_SWALLOW_BOM;
10801 if (s[1] == 0xFE) {
10802 /* UTF-16 little-endian? (or UTF-32LE?) */
10803 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10804 /* diag_listed_as: Unsupported script encoding %s */
10805 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10806 #ifndef PERL_NO_UTF16_FILTER
10807 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10809 if (PL_bufend > (char*)s) {
10810 s = add_utf16_textfilter(s, TRUE);
10813 /* diag_listed_as: Unsupported script encoding %s */
10814 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10819 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10820 #ifndef PERL_NO_UTF16_FILTER
10821 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10823 if (PL_bufend > (char *)s) {
10824 s = add_utf16_textfilter(s, FALSE);
10827 /* diag_listed_as: Unsupported script encoding %s */
10828 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10832 case BOM_UTF8_FIRST_BYTE: {
10833 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10834 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10835 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10836 s += len + 1; /* UTF-8 */
10843 if (s[2] == 0xFE && s[3] == 0xFF) {
10844 /* UTF-32 big-endian */
10845 /* diag_listed_as: Unsupported script encoding %s */
10846 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10849 else if (s[2] == 0 && s[3] != 0) {
10852 * are a good indicator of UTF-16BE. */
10853 #ifndef PERL_NO_UTF16_FILTER
10854 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10855 s = add_utf16_textfilter(s, FALSE);
10857 /* diag_listed_as: Unsupported script encoding %s */
10858 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10865 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10868 * are a good indicator of UTF-16LE. */
10869 #ifndef PERL_NO_UTF16_FILTER
10870 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10871 s = add_utf16_textfilter(s, TRUE);
10873 /* diag_listed_as: Unsupported script encoding %s */
10874 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10882 #ifndef PERL_NO_UTF16_FILTER
10884 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10886 SV *const filter = FILTER_DATA(idx);
10887 /* We re-use this each time round, throwing the contents away before we
10889 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10890 SV *const utf8_buffer = filter;
10891 IV status = IoPAGE(filter);
10892 const bool reverse = cBOOL(IoLINES(filter));
10895 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10897 /* As we're automatically added, at the lowest level, and hence only called
10898 from this file, we can be sure that we're not called in block mode. Hence
10899 don't bother writing code to deal with block mode. */
10901 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10904 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10906 DEBUG_P(PerlIO_printf(Perl_debug_log,
10907 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10908 FPTR2DPTR(void *, S_utf16_textfilter),
10909 reverse ? 'l' : 'b', idx, maxlen, status,
10910 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10917 /* First, look in our buffer of existing UTF-8 data: */
10918 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10922 } else if (status == 0) {
10924 IoPAGE(filter) = 0;
10925 nl = SvEND(utf8_buffer);
10928 STRLEN got = nl - SvPVX(utf8_buffer);
10929 /* Did we have anything to append? */
10931 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10932 /* Everything else in this code works just fine if SVp_POK isn't
10933 set. This, however, needs it, and we need it to work, else
10934 we loop infinitely because the buffer is never consumed. */
10935 sv_chop(utf8_buffer, nl);
10939 /* OK, not a complete line there, so need to read some more UTF-16.
10940 Read an extra octect if the buffer currently has an odd number. */
10944 if (SvCUR(utf16_buffer) >= 2) {
10945 /* Location of the high octet of the last complete code point.
10946 Gosh, UTF-16 is a pain. All the benefits of variable length,
10947 *coupled* with all the benefits of partial reads and
10949 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10950 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10952 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10956 /* We have the first half of a surrogate. Read more. */
10957 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10960 status = FILTER_READ(idx + 1, utf16_buffer,
10961 160 + (SvCUR(utf16_buffer) & 1));
10962 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10963 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10966 IoPAGE(filter) = status;
10971 chars = SvCUR(utf16_buffer) >> 1;
10972 have = SvCUR(utf8_buffer);
10973 SvGROW(utf8_buffer, have + chars * 3 + 1);
10976 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10977 (U8*)SvPVX_const(utf8_buffer) + have,
10978 chars * 2, &newlen);
10980 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10981 (U8*)SvPVX_const(utf8_buffer) + have,
10982 chars * 2, &newlen);
10984 SvCUR_set(utf8_buffer, have + newlen);
10987 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10988 it's private to us, and utf16_to_utf8{,reversed} take a
10989 (pointer,length) pair, rather than a NUL-terminated string. */
10990 if(SvCUR(utf16_buffer) & 1) {
10991 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10992 SvCUR_set(utf16_buffer, 1);
10994 SvCUR_set(utf16_buffer, 0);
10997 DEBUG_P(PerlIO_printf(Perl_debug_log,
10998 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11000 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11001 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11006 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11008 SV *filter = filter_add(S_utf16_textfilter, NULL);
11010 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11012 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11013 sv_setpvs(filter, "");
11014 IoLINES(filter) = reversed;
11015 IoPAGE(filter) = 1; /* Not EOF */
11017 /* Sadly, we have to return a valid pointer, come what may, so we have to
11018 ignore any error return from this. */
11019 SvCUR_set(PL_linestr, 0);
11020 if (FILTER_READ(0, PL_linestr, 0)) {
11021 SvUTF8_on(PL_linestr);
11023 SvUTF8_on(PL_linestr);
11025 PL_bufend = SvEND(PL_linestr);
11026 return (U8*)SvPVX(PL_linestr);
11031 Returns a pointer to the next character after the parsed
11032 vstring, as well as updating the passed in sv.
11034 Function must be called like
11036 sv = sv_2mortal(newSV(5));
11037 s = scan_vstring(s,e,sv);
11039 where s and e are the start and end of the string.
11040 The sv should already be large enough to store the vstring
11041 passed in, for performance reasons.
11043 This function may croak if fatal warnings are enabled in the
11044 calling scope, hence the sv_2mortal in the example (to prevent
11045 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11051 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11053 const char *pos = s;
11054 const char *start = s;
11056 PERL_ARGS_ASSERT_SCAN_VSTRING;
11058 if (*pos == 'v') pos++; /* get past 'v' */
11059 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11061 if ( *pos != '.') {
11062 /* this may not be a v-string if followed by => */
11063 const char *next = pos;
11064 while (next < e && isSPACE(*next))
11066 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11067 /* return string not v-string */
11068 sv_setpvn(sv,(char *)s,pos-s);
11069 return (char *)pos;
11073 if (!isALPHA(*pos)) {
11074 U8 tmpbuf[UTF8_MAXBYTES+1];
11077 s++; /* get past 'v' */
11082 /* this is atoi() that tolerates underscores */
11085 const char *end = pos;
11087 while (--end >= s) {
11089 const UV orev = rev;
11090 rev += (*end - '0') * mult;
11093 /* diag_listed_as: Integer overflow in %s number */
11094 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11095 "Integer overflow in decimal number");
11099 if (rev > 0x7FFFFFFF)
11100 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11102 /* Append native character for the rev point */
11103 tmpend = uvchr_to_utf8(tmpbuf, rev);
11104 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11105 if (!UVCHR_IS_INVARIANT(rev))
11107 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11113 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11117 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11124 Perl_keyword_plugin_standard(pTHX_
11125 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11127 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11128 PERL_UNUSED_CONTEXT;
11129 PERL_UNUSED_ARG(keyword_ptr);
11130 PERL_UNUSED_ARG(keyword_len);
11131 PERL_UNUSED_ARG(op_ptr);
11132 return KEYWORD_PLUGIN_DECLINE;
11135 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11137 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11139 SAVEI32(PL_lex_brackets);
11140 if (PL_lex_brackets > 100)
11141 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11142 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11143 SAVEI32(PL_lex_allbrackets);
11144 PL_lex_allbrackets = 0;
11145 SAVEI8(PL_lex_fakeeof);
11146 PL_lex_fakeeof = (U8)fakeeof;
11147 if(yyparse(gramtype) && !PL_parser->error_count)
11148 qerror(Perl_mess(aTHX_ "Parse error"));
11151 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11153 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11157 SAVEVPTR(PL_eval_root);
11158 PL_eval_root = NULL;
11159 parse_recdescent(gramtype, fakeeof);
11165 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11167 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11170 if (flags & ~PARSE_OPTIONAL)
11171 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11172 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11173 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11174 if (!PL_parser->error_count)
11175 qerror(Perl_mess(aTHX_ "Parse error"));
11176 exprop = newOP(OP_NULL, 0);
11182 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11184 Parse a Perl arithmetic expression. This may contain operators of precedence
11185 down to the bit shift operators. The expression must be followed (and thus
11186 terminated) either by a comparison or lower-precedence operator or by
11187 something that would normally terminate an expression such as semicolon.
11188 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11189 otherwise it is mandatory. It is up to the caller to ensure that the
11190 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11191 the source of the code to be parsed and the lexical context for the
11194 The op tree representing the expression is returned. If an optional
11195 expression is absent, a null pointer is returned, otherwise the pointer
11198 If an error occurs in parsing or compilation, in most cases a valid op
11199 tree is returned anyway. The error is reflected in the parser state,
11200 normally resulting in a single exception at the top level of parsing
11201 which covers all the compilation errors that occurred. Some compilation
11202 errors, however, will throw an exception immediately.
11208 Perl_parse_arithexpr(pTHX_ U32 flags)
11210 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11214 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11216 Parse a Perl term expression. This may contain operators of precedence
11217 down to the assignment operators. The expression must be followed (and thus
11218 terminated) either by a comma or lower-precedence operator or by
11219 something that would normally terminate an expression such as semicolon.
11220 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11221 otherwise it is mandatory. It is up to the caller to ensure that the
11222 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11223 the source of the code to be parsed and the lexical context for the
11226 The op tree representing the expression is returned. If an optional
11227 expression is absent, a null pointer is returned, otherwise the pointer
11230 If an error occurs in parsing or compilation, in most cases a valid op
11231 tree is returned anyway. The error is reflected in the parser state,
11232 normally resulting in a single exception at the top level of parsing
11233 which covers all the compilation errors that occurred. Some compilation
11234 errors, however, will throw an exception immediately.
11240 Perl_parse_termexpr(pTHX_ U32 flags)
11242 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11246 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11248 Parse a Perl list expression. This may contain operators of precedence
11249 down to the comma operator. The expression must be followed (and thus
11250 terminated) either by a low-precedence logic operator such as C<or> or by
11251 something that would normally terminate an expression such as semicolon.
11252 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11253 otherwise it is mandatory. It is up to the caller to ensure that the
11254 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11255 the source of the code to be parsed and the lexical context for the
11258 The op tree representing the expression is returned. If an optional
11259 expression is absent, a null pointer is returned, otherwise the pointer
11262 If an error occurs in parsing or compilation, in most cases a valid op
11263 tree is returned anyway. The error is reflected in the parser state,
11264 normally resulting in a single exception at the top level of parsing
11265 which covers all the compilation errors that occurred. Some compilation
11266 errors, however, will throw an exception immediately.
11272 Perl_parse_listexpr(pTHX_ U32 flags)
11274 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11278 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11280 Parse a single complete Perl expression. This allows the full
11281 expression grammar, including the lowest-precedence operators such
11282 as C<or>. The expression must be followed (and thus terminated) by a
11283 token that an expression would normally be terminated by: end-of-file,
11284 closing bracketing punctuation, semicolon, or one of the keywords that
11285 signals a postfix expression-statement modifier. If I<flags> includes
11286 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11287 mandatory. It is up to the caller to ensure that the dynamic parser
11288 state (L</PL_parser> et al) is correctly set to reflect the source of
11289 the code to be parsed and the lexical context for the expression.
11291 The op tree representing the expression is returned. If an optional
11292 expression is absent, a null pointer is returned, otherwise the pointer
11295 If an error occurs in parsing or compilation, in most cases a valid op
11296 tree is returned anyway. The error is reflected in the parser state,
11297 normally resulting in a single exception at the top level of parsing
11298 which covers all the compilation errors that occurred. Some compilation
11299 errors, however, will throw an exception immediately.
11305 Perl_parse_fullexpr(pTHX_ U32 flags)
11307 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11311 =for apidoc Amx|OP *|parse_block|U32 flags
11313 Parse a single complete Perl code block. This consists of an opening
11314 brace, a sequence of statements, and a closing brace. The block
11315 constitutes a lexical scope, so C<my> variables and various compile-time
11316 effects can be contained within it. It is up to the caller to ensure
11317 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11318 reflect the source of the code to be parsed and the lexical context for
11321 The op tree representing the code block is returned. This is always a
11322 real op, never a null pointer. It will normally be a C<lineseq> list,
11323 including C<nextstate> or equivalent ops. No ops to construct any kind
11324 of runtime scope are included by virtue of it being a block.
11326 If an error occurs in parsing or compilation, in most cases a valid op
11327 tree (most likely null) is returned anyway. The error is reflected in
11328 the parser state, normally resulting in a single exception at the top
11329 level of parsing which covers all the compilation errors that occurred.
11330 Some compilation errors, however, will throw an exception immediately.
11332 The I<flags> parameter is reserved for future use, and must always
11339 Perl_parse_block(pTHX_ U32 flags)
11342 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11343 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11347 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11349 Parse a single unadorned Perl statement. This may be a normal imperative
11350 statement or a declaration that has compile-time effect. It does not
11351 include any label or other affixture. It is up to the caller to ensure
11352 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11353 reflect the source of the code to be parsed and the lexical context for
11356 The op tree representing the statement is returned. This may be a
11357 null pointer if the statement is null, for example if it was actually
11358 a subroutine definition (which has compile-time side effects). If not
11359 null, it will be ops directly implementing the statement, suitable to
11360 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11361 equivalent op (except for those embedded in a scope contained entirely
11362 within the statement).
11364 If an error occurs in parsing or compilation, in most cases a valid op
11365 tree (most likely null) is returned anyway. The error is reflected in
11366 the parser state, normally resulting in a single exception at the top
11367 level of parsing which covers all the compilation errors that occurred.
11368 Some compilation errors, however, will throw an exception immediately.
11370 The I<flags> parameter is reserved for future use, and must always
11377 Perl_parse_barestmt(pTHX_ U32 flags)
11380 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11381 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11385 =for apidoc Amx|SV *|parse_label|U32 flags
11387 Parse a single label, possibly optional, of the type that may prefix a
11388 Perl statement. It is up to the caller to ensure that the dynamic parser
11389 state (L</PL_parser> et al) is correctly set to reflect the source of
11390 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11391 label is optional, otherwise it is mandatory.
11393 The name of the label is returned in the form of a fresh scalar. If an
11394 optional label is absent, a null pointer is returned.
11396 If an error occurs in parsing, which can only occur if the label is
11397 mandatory, a valid label is returned anyway. The error is reflected in
11398 the parser state, normally resulting in a single exception at the top
11399 level of parsing which covers all the compilation errors that occurred.
11405 Perl_parse_label(pTHX_ U32 flags)
11407 if (flags & ~PARSE_OPTIONAL)
11408 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11409 if (PL_lex_state == LEX_KNOWNEXT) {
11410 PL_parser->yychar = yylex();
11411 if (PL_parser->yychar == LABEL) {
11412 char * const lpv = pl_yylval.pval;
11413 STRLEN llen = strlen(lpv);
11414 PL_parser->yychar = YYEMPTY;
11415 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11422 STRLEN wlen, bufptr_pos;
11425 if (!isIDFIRST_lazy_if(s, UTF))
11427 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11428 if (word_takes_any_delimeter(s, wlen))
11430 bufptr_pos = s - SvPVX(PL_linestr);
11432 lex_read_space(LEX_KEEP_PREVIOUS);
11434 s = SvPVX(PL_linestr) + bufptr_pos;
11435 if (t[0] == ':' && t[1] != ':') {
11436 PL_oldoldbufptr = PL_oldbufptr;
11439 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11443 if (flags & PARSE_OPTIONAL) {
11446 qerror(Perl_mess(aTHX_ "Parse error"));
11447 return newSVpvs("x");
11454 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11456 Parse a single complete Perl statement. This may be a normal imperative
11457 statement or a declaration that has compile-time effect, and may include
11458 optional labels. It is up to the caller to ensure that the dynamic
11459 parser state (L</PL_parser> et al) is correctly set to reflect the source
11460 of the code to be parsed and the lexical context for the statement.
11462 The op tree representing the statement is returned. This may be a
11463 null pointer if the statement is null, for example if it was actually
11464 a subroutine definition (which has compile-time side effects). If not
11465 null, it will be the result of a L</newSTATEOP> call, normally including
11466 a C<nextstate> or equivalent op.
11468 If an error occurs in parsing or compilation, in most cases a valid op
11469 tree (most likely null) is returned anyway. The error is reflected in
11470 the parser state, normally resulting in a single exception at the top
11471 level of parsing which covers all the compilation errors that occurred.
11472 Some compilation errors, however, will throw an exception immediately.
11474 The I<flags> parameter is reserved for future use, and must always
11481 Perl_parse_fullstmt(pTHX_ U32 flags)
11484 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11485 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11489 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11491 Parse a sequence of zero or more Perl statements. These may be normal
11492 imperative statements, including optional labels, or declarations
11493 that have compile-time effect, or any mixture thereof. The statement
11494 sequence ends when a closing brace or end-of-file is encountered in a
11495 place where a new statement could have validly started. It is up to
11496 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11497 is correctly set to reflect the source of the code to be parsed and the
11498 lexical context for the statements.
11500 The op tree representing the statement sequence is returned. This may
11501 be a null pointer if the statements were all null, for example if there
11502 were no statements or if there were only subroutine definitions (which
11503 have compile-time side effects). If not null, it will be a C<lineseq>
11504 list, normally including C<nextstate> or equivalent ops.
11506 If an error occurs in parsing or compilation, in most cases a valid op
11507 tree is returned anyway. The error is reflected in the parser state,
11508 normally resulting in a single exception at the top level of parsing
11509 which covers all the compilation errors that occurred. Some compilation
11510 errors, however, will throw an exception immediately.
11512 The I<flags> parameter is reserved for future use, and must always
11519 Perl_parse_stmtseq(pTHX_ U32 flags)
11524 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11525 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11526 c = lex_peek_unichar(0);
11527 if (c != -1 && c != /*{*/'}')
11528 qerror(Perl_mess(aTHX_ "Parse error"));
11532 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11534 S_lex_token_boundary(pTHX)
11536 PL_oldoldbufptr = PL_oldbufptr;
11537 PL_oldbufptr = PL_bufptr;
11540 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11542 S_parse_opt_lexvar(pTHX)
11547 lex_token_boundary();
11548 sigil = lex_read_unichar(0);
11549 if (lex_peek_unichar(0) == '#') {
11550 qerror(Perl_mess(aTHX_ "Parse error"));
11554 c = lex_peek_unichar(0);
11555 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11558 d = PL_tokenbuf + 1;
11559 PL_tokenbuf[0] = (char)sigil;
11560 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11562 if (d == PL_tokenbuf+1)
11564 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11565 OPf_MOD | (OPpLVAL_INTRO<<8));
11566 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11571 Perl_parse_subsignature(pTHX)
11574 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11575 OP *initops = NULL;
11577 c = lex_peek_unichar(0);
11578 while (c != /*(*/')') {
11582 if (prev_type == 2)
11583 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11584 var = parse_opt_lexvar();
11586 newBINOP(OP_AELEM, 0,
11587 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11589 newSVOP(OP_CONST, 0, newSViv(pos))) :
11592 c = lex_peek_unichar(0);
11594 lex_token_boundary();
11595 lex_read_unichar(0);
11597 c = lex_peek_unichar(0);
11598 if (c == ',' || c == /*(*/')') {
11600 qerror(Perl_mess(aTHX_ "Optional parameter "
11601 "lacks default expression"));
11603 OP *defexpr = parse_termexpr(0);
11604 if (defexpr->op_type == OP_UNDEF &&
11605 !(defexpr->op_flags & OPf_KIDS)) {
11610 scalar(newUNOP(OP_RV2AV, 0,
11611 newGVOP(OP_GV, 0, PL_defgv))),
11612 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11614 newCONDOP(0, ifop, expr, defexpr) :
11615 newLOGOP(OP_OR, 0, ifop, defexpr);
11620 if (prev_type == 1)
11621 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11622 "follows optional parameter"));
11624 min_arity = pos + 1;
11626 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11628 initops = op_append_list(OP_LINESEQ, initops,
11629 newSTATEOP(0, NULL, expr));
11635 if (prev_type == 2)
11636 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11637 var = parse_opt_lexvar();
11639 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11640 newBINOP(OP_BIT_AND, 0,
11641 scalar(newUNOP(OP_RV2AV, 0,
11642 newGVOP(OP_GV, 0, PL_defgv))),
11643 newSVOP(OP_CONST, 0, newSViv(1))),
11644 op_convert_list(OP_DIE, 0,
11645 op_convert_list(OP_SPRINTF, 0,
11646 op_append_list(OP_LIST,
11647 newSVOP(OP_CONST, 0,
11648 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11650 op_append_list(OP_LIST,
11651 newSVOP(OP_CONST, 0, newSViv(1)),
11652 newSVOP(OP_CONST, 0, newSViv(2))),
11653 newOP(OP_CALLER, 0))))));
11654 if (pos != min_arity)
11655 chkop = newLOGOP(OP_AND, 0,
11657 scalar(newUNOP(OP_RV2AV, 0,
11658 newGVOP(OP_GV, 0, PL_defgv))),
11659 newSVOP(OP_CONST, 0, newSViv(pos))),
11661 initops = op_append_list(OP_LINESEQ,
11662 newSTATEOP(0, NULL, chkop),
11667 op_prepend_elem(OP_ASLICE,
11668 newOP(OP_PUSHMARK, 0),
11669 newLISTOP(OP_ASLICE, 0,
11671 newSVOP(OP_CONST, 0, newSViv(pos)),
11672 newUNOP(OP_AV2ARYLEN, 0,
11673 ref(newUNOP(OP_RV2AV, 0,
11674 newGVOP(OP_GV, 0, PL_defgv)),
11676 ref(newUNOP(OP_RV2AV, 0,
11677 newGVOP(OP_GV, 0, PL_defgv)),
11679 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11680 initops = op_append_list(OP_LINESEQ, initops,
11681 newSTATEOP(0, NULL,
11682 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11689 qerror(Perl_mess(aTHX_ "Parse error"));
11693 c = lex_peek_unichar(0);
11695 case /*(*/')': break;
11698 lex_token_boundary();
11699 lex_read_unichar(0);
11701 c = lex_peek_unichar(0);
11702 } while (c == ',');
11708 if (min_arity != 0) {
11709 initops = op_append_list(OP_LINESEQ,
11710 newSTATEOP(0, NULL,
11713 scalar(newUNOP(OP_RV2AV, 0,
11714 newGVOP(OP_GV, 0, PL_defgv))),
11715 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11716 op_convert_list(OP_DIE, 0,
11717 op_convert_list(OP_SPRINTF, 0,
11718 op_append_list(OP_LIST,
11719 newSVOP(OP_CONST, 0,
11720 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11722 op_append_list(OP_LIST,
11723 newSVOP(OP_CONST, 0, newSViv(1)),
11724 newSVOP(OP_CONST, 0, newSViv(2))),
11725 newOP(OP_CALLER, 0))))))),
11728 if (max_arity != -1) {
11729 initops = op_append_list(OP_LINESEQ,
11730 newSTATEOP(0, NULL,
11733 scalar(newUNOP(OP_RV2AV, 0,
11734 newGVOP(OP_GV, 0, PL_defgv))),
11735 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11736 op_convert_list(OP_DIE, 0,
11737 op_convert_list(OP_SPRINTF, 0,
11738 op_append_list(OP_LIST,
11739 newSVOP(OP_CONST, 0,
11740 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11742 op_append_list(OP_LIST,
11743 newSVOP(OP_CONST, 0, newSViv(1)),
11744 newSVOP(OP_CONST, 0, newSViv(2))),
11745 newOP(OP_CALLER, 0))))))),
11752 * ex: set ts=8 sts=4 sw=4 et: