3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_sublex_info (PL_parser->sublex_info)
69 #define PL_linestr (PL_parser->linestr)
70 #define PL_expect (PL_parser->expect)
71 #define PL_copline (PL_parser->copline)
72 #define PL_bufptr (PL_parser->bufptr)
73 #define PL_oldbufptr (PL_parser->oldbufptr)
74 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
75 #define PL_linestart (PL_parser->linestart)
76 #define PL_bufend (PL_parser->bufend)
77 #define PL_last_uni (PL_parser->last_uni)
78 #define PL_last_lop (PL_parser->last_lop)
79 #define PL_last_lop_op (PL_parser->last_lop_op)
80 #define PL_lex_state (PL_parser->lex_state)
81 #define PL_rsfp (PL_parser->rsfp)
82 #define PL_rsfp_filters (PL_parser->rsfp_filters)
83 #define PL_in_my (PL_parser->in_my)
84 #define PL_in_my_stash (PL_parser->in_my_stash)
85 #define PL_tokenbuf (PL_parser->tokenbuf)
86 #define PL_multi_end (PL_parser->multi_end)
87 #define PL_error_count (PL_parser->error_count)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_nexttype (PL_parser->nexttype)
91 # define PL_nextval (PL_parser->nextval)
93 static const char* const ident_too_long = "Identifier too long";
95 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
97 #define XENUMMASK 0x3f
99 #define XFAKEBRACK 0x80
101 #ifdef USE_UTF8_SCRIPTS
102 # define UTF cBOOL(!IN_BYTES)
104 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
107 /* The maximum number of characters preceding the unrecognized one to display */
108 #define UNRECOGNIZED_PRECEDE_COUNT 10
110 /* In variables named $^X, these are the legal values for X.
111 * 1999-02-27 mjd-perl-patch@plover.com */
112 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
114 #define SPACE_OR_TAB(c) isBLANK_A(c)
116 #define HEXFP_PEEK(s) \
118 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
119 isALPHA_FOLD_EQ(s[0], 'p'))
121 /* LEX_* are values for PL_lex_state, the state of the lexer.
122 * They are arranged oddly so that the guard on the switch statement
123 * can get by with a single comparison (if the compiler is smart enough).
125 * These values refer to the various states within a sublex parse,
126 * i.e. within a double quotish string
129 /* #define LEX_NOTPARSING 11 is done in perl.h. */
131 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
132 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
133 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
134 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
135 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
137 /* at end of code, eg "$x" followed by: */
138 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
139 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
141 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
142 string or after \E, $foo, etc */
143 #define LEX_INTERPCONST 2 /* NOT USED */
144 #define LEX_FORMLINE 1 /* expecting a format line */
145 #define LEX_KNOWNEXT 0 /* next token known; just return it */
149 static const char* const lex_state_names[] = {
164 #include "keywords.h"
166 /* CLINE is a macro that ensures PL_copline has a sane value */
168 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 * Convenience functions to return different tokens and prime the
172 * lexer for the next token. They all take an argument.
174 * TOKEN : generic token (used for '(', DOLSHARP, etc)
175 * OPERATOR : generic operator
176 * AOPERATOR : assignment operator
177 * PREBLOCK : beginning the block after an if, while, foreach, ...
178 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
179 * PREREF : *EXPR where EXPR is not a simple identifier
180 * TERM : expression term
181 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
182 * LOOPX : loop exiting command (goto, last, dump, etc)
183 * FTST : file test operator
184 * FUN0 : zero-argument function
185 * FUN0OP : zero-argument function, with its op created in this file
186 * FUN1 : not used, except for not, which isn't a UNIOP
187 * BOop : bitwise or or xor
189 * BCop : bitwise complement
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
194 * AopNOASSIGN : addition-level operator that is never part of .=
195 * Mop : multiplication-level operator
196 * Eop : equality-testing operator
197 * Rop : relational operator <= != gt
199 * Also see LOP and lop() below.
202 #ifdef DEBUGGING /* Serve -DT. */
203 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
205 # define REPORT(retval) (retval)
208 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
209 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
210 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
211 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
213 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
214 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
215 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
216 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
218 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
220 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
221 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
222 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
223 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
224 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
225 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
226 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
228 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
229 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
230 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
231 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
232 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
233 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
234 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
235 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
237 /* This bit of chicanery makes a unary function followed by
238 * a parenthesis into a function with one argument, highest precedence.
239 * The UNIDOR macro is for unary functions that can be followed by the //
240 * operator (such as C<shift // 0>).
242 #define UNI3(f,x,have_x) { \
243 pl_yylval.ival = f; \
244 if (have_x) PL_expect = x; \
246 PL_last_uni = PL_oldbufptr; \
247 PL_last_lop_op = f; \
249 return REPORT( (int)FUNC1 ); \
251 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
253 #define UNI(f) UNI3(f,XTERM,1)
254 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
255 #define UNIPROTO(f,optional) { \
256 if (optional) PL_last_uni = PL_oldbufptr; \
260 #define UNIBRACK(f) UNI3(f,0,0)
262 /* grandfather return to old style */
265 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
266 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
267 pl_yylval.ival = (f); \
273 #define COPLINE_INC_WITH_HERELINES \
275 CopLINE_inc(PL_curcop); \
276 if (PL_parser->herelines) \
277 CopLINE(PL_curcop) += PL_parser->herelines, \
278 PL_parser->herelines = 0; \
280 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
281 * is no sublex_push to follow. */
282 #define COPLINE_SET_FROM_MULTI_END \
284 CopLINE_set(PL_curcop, PL_multi_end); \
285 if (PL_multi_end != PL_multi_start) \
286 PL_parser->herelines = 0; \
292 /* how to interpret the pl_yylval associated with the token */
296 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
301 static struct debug_tokens {
303 enum token_type type;
305 } const debug_tokens[] =
307 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
308 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
309 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
310 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
311 { ARROW, TOKENTYPE_NONE, "ARROW" },
312 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
313 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
314 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
315 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
316 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
317 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
318 { DO, TOKENTYPE_NONE, "DO" },
319 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
320 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
321 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
322 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
323 { ELSE, TOKENTYPE_NONE, "ELSE" },
324 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
325 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
326 { FOR, TOKENTYPE_IVAL, "FOR" },
327 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
328 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
329 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
330 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
331 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
332 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
333 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
334 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
335 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
336 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
337 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
338 { IF, TOKENTYPE_IVAL, "IF" },
339 { LABEL, TOKENTYPE_PVAL, "LABEL" },
340 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
341 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
342 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
343 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
344 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
345 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
346 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
347 { MY, TOKENTYPE_IVAL, "MY" },
348 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
349 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
350 { OROP, TOKENTYPE_IVAL, "OROP" },
351 { OROR, TOKENTYPE_NONE, "OROR" },
352 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
353 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
354 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
355 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
356 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
357 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
358 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
359 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
360 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
361 { PREINC, TOKENTYPE_NONE, "PREINC" },
362 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
363 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
364 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
365 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
366 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
367 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
368 { SUB, TOKENTYPE_NONE, "SUB" },
369 { THING, TOKENTYPE_OPVAL, "THING" },
370 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
371 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
372 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
373 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
374 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
375 { USE, TOKENTYPE_IVAL, "USE" },
376 { WHEN, TOKENTYPE_IVAL, "WHEN" },
377 { WHILE, TOKENTYPE_IVAL, "WHILE" },
378 { WORD, TOKENTYPE_OPVAL, "WORD" },
379 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
380 { 0, TOKENTYPE_NONE, NULL }
383 /* dump the returned token in rv, plus any optional arg in pl_yylval */
386 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
388 PERL_ARGS_ASSERT_TOKEREPORT;
391 const char *name = NULL;
392 enum token_type type = TOKENTYPE_NONE;
393 const struct debug_tokens *p;
394 SV* const report = newSVpvs("<== ");
396 for (p = debug_tokens; p->token; p++) {
397 if (p->token == (int)rv) {
404 Perl_sv_catpv(aTHX_ report, name);
405 else if (isGRAPH(rv))
407 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
409 sv_catpvs(report, " (pending identifier)");
412 sv_catpvs(report, "EOF");
414 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
419 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
421 case TOKENTYPE_OPNUM:
422 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
423 PL_op_name[lvalp->ival]);
426 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
428 case TOKENTYPE_OPVAL:
430 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
431 PL_op_name[lvalp->opval->op_type]);
432 if (lvalp->opval->op_type == OP_CONST) {
433 Perl_sv_catpvf(aTHX_ report, " %s",
434 SvPEEK(cSVOPx_sv(lvalp->opval)));
439 sv_catpvs(report, "(opval=null)");
442 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
448 /* print the buffer with suitable escapes */
451 S_printbuf(pTHX_ const char *const fmt, const char *const s)
453 SV* const tmp = newSVpvs("");
455 PERL_ARGS_ASSERT_PRINTBUF;
457 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
458 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
466 S_deprecate_commaless_var_list(pTHX) {
468 deprecate("comma-less variable list");
469 return REPORT(','); /* grandfather non-comma-format format */
475 * This subroutine looks for an '=' next to the operator that has just been
476 * parsed and turns it into an ASSIGNOP if it finds one.
480 S_ao(pTHX_ int toketype)
482 if (*PL_bufptr == '=') {
484 if (toketype == ANDAND)
485 pl_yylval.ival = OP_ANDASSIGN;
486 else if (toketype == OROR)
487 pl_yylval.ival = OP_ORASSIGN;
488 else if (toketype == DORDOR)
489 pl_yylval.ival = OP_DORASSIGN;
492 return REPORT(toketype);
497 * When Perl expects an operator and finds something else, no_op
498 * prints the warning. It always prints "<something> found where
499 * operator expected. It prints "Missing semicolon on previous line?"
500 * if the surprise occurs at the start of the line. "do you need to
501 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
502 * where the compiler doesn't know if foo is a method call or a function.
503 * It prints "Missing operator before end of line" if there's nothing
504 * after the missing operator, or "... before <...>" if there is something
505 * after the missing operator.
507 * PL_bufptr is expected to point to the start of the thing that was found,
508 * and s after the next token or partial token.
512 S_no_op(pTHX_ const char *const what, char *s)
514 char * const oldbp = PL_bufptr;
515 const bool is_first = (PL_oldbufptr == PL_linestart);
517 PERL_ARGS_ASSERT_NO_OP;
523 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
524 if (ckWARN_d(WARN_SYNTAX)) {
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
527 "\t(Missing semicolon on previous line?)\n");
528 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
530 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
531 t += UTF ? UTF8SKIP(t) : 1)
533 if (t < PL_bufptr && isSPACE(*t))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Do you need to predeclare %"UTF8f"?)\n",
536 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing operator before %"UTF8f"?)\n",
542 UTF8fARG(UTF, s - oldbp, oldbp));
550 * Complain about missing quote/regexp/heredoc terminator.
551 * If it's called with NULL then it cauterizes the line buffer.
552 * If we're in a delimited string and the delimiter is a control
553 * character, it's reformatted into a two-char sequence like ^C.
558 S_missingterm(pTHX_ char *s)
563 char * const nl = strrchr(s,'\n');
567 else if ((U8) PL_multi_close < 32) {
569 tmpbuf[1] = (char)toCTRL(PL_multi_close);
574 *tmpbuf = (char)PL_multi_close;
578 q = strchr(s,'"') ? '\'' : '"';
579 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
585 * Check whether the named feature is enabled.
588 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
590 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
592 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
594 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
596 if (namelen > MAX_FEATURE_LEN)
598 memcpy(&he_name[8], name, namelen);
600 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
601 REFCOUNTED_HE_EXISTS));
605 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
606 * utf16-to-utf8-reversed.
609 #ifdef PERL_CR_FILTER
613 const char *s = SvPVX_const(sv);
614 const char * const e = s + SvCUR(sv);
616 PERL_ARGS_ASSERT_STRIP_RETURN;
618 /* outer loop optimized to do nothing if there are no CR-LFs */
620 if (*s++ == '\r' && *s == '\n') {
621 /* hit a CR-LF, need to copy the rest */
625 if (*s == '\r' && s[1] == '\n')
636 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
639 if (count > 0 && !maxlen)
646 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
648 Creates and initialises a new lexer/parser state object, supplying
649 a context in which to lex and parse from a new source of Perl code.
650 A pointer to the new state object is placed in L</PL_parser>. An entry
651 is made on the save stack so that upon unwinding the new state object
652 will be destroyed and the former value of L</PL_parser> will be restored.
653 Nothing else need be done to clean up the parsing context.
655 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
656 non-null, provides a string (in SV form) containing code to be parsed.
657 A copy of the string is made, so subsequent modification of C<line>
658 does not affect parsing. C<rsfp>, if non-null, provides an input stream
659 from which code will be read to be parsed. If both are non-null, the
660 code in C<line> comes first and must consist of complete lines of input,
661 and C<rsfp> supplies the remainder of the source.
663 The C<flags> parameter is reserved for future use. Currently it is only
664 used by perl internally, so extensions should always pass zero.
669 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
670 can share filters with the current parser.
671 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
672 caller, hence isn't owned by the parser, so shouldn't be closed on parser
673 destruction. This is used to handle the case of defaulting to reading the
674 script from the standard input because no filename was given on the command
675 line (without getting confused by situation where STDIN has been closed, so
676 the script handle is opened on fd 0) */
679 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
681 const char *s = NULL;
682 yy_parser *parser, *oparser;
683 if (flags && flags & ~LEX_START_FLAGS)
684 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
686 /* create and initialise a parser */
688 Newxz(parser, 1, yy_parser);
689 parser->old_parser = oparser = PL_parser;
692 parser->stack = NULL;
694 parser->stack_size = 0;
696 /* on scope exit, free this parser and restore any outer one */
698 parser->saved_curcop = PL_curcop;
700 /* initialise lexer state */
702 parser->nexttoke = 0;
703 parser->error_count = oparser ? oparser->error_count : 0;
704 parser->copline = parser->preambling = NOLINE;
705 parser->lex_state = LEX_NORMAL;
706 parser->expect = XSTATE;
708 parser->rsfp_filters =
709 !(flags & LEX_START_SAME_FILTER) || !oparser
711 : MUTABLE_AV(SvREFCNT_inc(
712 oparser->rsfp_filters
713 ? oparser->rsfp_filters
714 : (oparser->rsfp_filters = newAV())
717 Newx(parser->lex_brackstack, 120, char);
718 Newx(parser->lex_casestack, 12, char);
719 *parser->lex_casestack = '\0';
720 Newxz(parser->lex_shared, 1, LEXSHARED);
724 s = SvPV_const(line, len);
725 parser->linestr = flags & LEX_START_COPIED
726 ? SvREFCNT_inc_simple_NN(line)
727 : newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
730 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
732 parser->oldoldbufptr =
735 parser->linestart = SvPVX(parser->linestr);
736 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
737 parser->last_lop = parser->last_uni = NULL;
739 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
740 |LEX_DONT_CLOSE_RSFP));
741 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
742 |LEX_DONT_CLOSE_RSFP));
744 parser->in_pod = parser->filtered = 0;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser
761 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
764 SvREFCNT_dec(parser->lex_stuff);
765 SvREFCNT_dec(parser->sublex_info.repl);
767 Safefree(parser->lex_brackstack);
768 Safefree(parser->lex_casestack);
769 Safefree(parser->lex_shared);
770 PL_parser = parser->old_parser;
775 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
777 I32 nexttoke = parser->nexttoke;
778 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
780 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
781 && parser->nextval[nexttoke].opval
782 && parser->nextval[nexttoke].opval->op_slabbed
783 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
784 op_free(parser->nextval[nexttoke].opval);
785 parser->nextval[nexttoke].opval = NULL;
792 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
794 Buffer scalar containing the chunk currently under consideration of the
795 text currently being lexed. This is always a plain string scalar (for
796 which C<SvPOK> is true). It is not intended to be used as a scalar by
797 normal scalar means; instead refer to the buffer directly by the pointer
798 variables described below.
800 The lexer maintains various C<char*> pointers to things in the
801 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
802 reallocated, all of these pointers must be updated. Don't attempt to
803 do this manually, but rather use L</lex_grow_linestr> if you need to
804 reallocate the buffer.
806 The content of the text chunk in the buffer is commonly exactly one
807 complete line of input, up to and including a newline terminator,
808 but there are situations where it is otherwise. The octets of the
809 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
810 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
811 flag on this scalar, which may disagree with it.
813 For direct examination of the buffer, the variable
814 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
815 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
816 of these pointers is usually preferable to examination of the scalar
817 through normal scalar means.
819 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
821 Direct pointer to the end of the chunk of text currently being lexed, the
822 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
823 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
824 always located at the end of the buffer, and does not count as part of
825 the buffer's contents.
827 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
829 Points to the current position of lexing inside the lexer buffer.
830 Characters around this point may be freely examined, within
831 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
832 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
833 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
835 Lexing code (whether in the Perl core or not) moves this pointer past
836 the characters that it consumes. It is also expected to perform some
837 bookkeeping whenever a newline character is consumed. This movement
838 can be more conveniently performed by the function L</lex_read_to>,
839 which handles newlines appropriately.
841 Interpretation of the buffer's octets can be abstracted out by
842 using the slightly higher-level functions L</lex_peek_unichar> and
843 L</lex_read_unichar>.
845 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
847 Points to the start of the current line inside the lexer buffer.
848 This is useful for indicating at which column an error occurred, and
849 not much else. This must be updated by any lexing code that consumes
850 a newline; the function L</lex_read_to> handles this detail.
856 =for apidoc Amx|bool|lex_bufutf8
858 Indicates whether the octets in the lexer buffer
859 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
860 of Unicode characters. If not, they should be interpreted as Latin-1
861 characters. This is analogous to the C<SvUTF8> flag for scalars.
863 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
864 contains valid UTF-8. Lexing code must be robust in the face of invalid
867 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
868 is significant, but not the whole story regarding the input character
869 encoding. Normally, when a file is being read, the scalar contains octets
870 and its C<SvUTF8> flag is off, but the octets should be interpreted as
871 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
872 however, the scalar may have the C<SvUTF8> flag on, and in this case its
873 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
874 is in effect. This logic may change in the future; use this function
875 instead of implementing the logic yourself.
881 Perl_lex_bufutf8(pTHX)
887 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
889 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
890 at least C<len> octets (including terminating C<NUL>). Returns a
891 pointer to the reallocated buffer. This is necessary before making
892 any direct modification of the buffer that would increase its length.
893 L</lex_stuff_pvn> provides a more convenient way to insert text into
896 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
897 this function updates all of the lexer's variables that point directly
904 Perl_lex_grow_linestr(pTHX_ STRLEN len)
908 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
909 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
910 linestr = PL_parser->linestr;
911 buf = SvPVX(linestr);
912 if (len <= SvLEN(linestr))
914 bufend_pos = PL_parser->bufend - buf;
915 bufptr_pos = PL_parser->bufptr - buf;
916 oldbufptr_pos = PL_parser->oldbufptr - buf;
917 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
918 linestart_pos = PL_parser->linestart - buf;
919 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
920 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
921 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
922 PL_parser->lex_shared->re_eval_start - buf : 0;
924 buf = sv_grow(linestr, len);
926 PL_parser->bufend = buf + bufend_pos;
927 PL_parser->bufptr = buf + bufptr_pos;
928 PL_parser->oldbufptr = buf + oldbufptr_pos;
929 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
930 PL_parser->linestart = buf + linestart_pos;
931 if (PL_parser->last_uni)
932 PL_parser->last_uni = buf + last_uni_pos;
933 if (PL_parser->last_lop)
934 PL_parser->last_lop = buf + last_lop_pos;
935 if (PL_parser->lex_shared->re_eval_start)
936 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
941 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
943 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
944 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
945 reallocating the buffer if necessary. This means that lexing code that
946 runs later will see the characters as if they had appeared in the input.
947 It is not recommended to do this as part of normal parsing, and most
948 uses of this facility run the risk of the inserted characters being
949 interpreted in an unintended manner.
951 The string to be inserted is represented by C<len> octets starting
952 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
953 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
954 The characters are recoded for the lexer buffer, according to how the
955 buffer is currently being interpreted (L</lex_bufutf8>). If a string
956 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
957 function is more convenient.
963 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
967 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
968 if (flags & ~(LEX_STUFF_UTF8))
969 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
971 if (flags & LEX_STUFF_UTF8) {
974 STRLEN highhalf = 0; /* Count of variants */
975 const char *p, *e = pv+len;
976 for (p = pv; p != e; p++) {
977 if (! UTF8_IS_INVARIANT(*p)) {
983 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
984 bufptr = PL_parser->bufptr;
985 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
986 SvCUR_set(PL_parser->linestr,
987 SvCUR(PL_parser->linestr) + len+highhalf);
988 PL_parser->bufend += len+highhalf;
989 for (p = pv; p != e; p++) {
991 if (! UTF8_IS_INVARIANT(c)) {
992 *bufptr++ = UTF8_TWO_BYTE_HI(c);
993 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1000 if (flags & LEX_STUFF_UTF8) {
1001 STRLEN highhalf = 0;
1002 const char *p, *e = pv+len;
1003 for (p = pv; p != e; p++) {
1005 if (UTF8_IS_ABOVE_LATIN1(c)) {
1006 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1007 "non-Latin-1 character into Latin-1 input");
1008 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1011 } else if (! UTF8_IS_INVARIANT(c)) {
1012 /* malformed UTF-8 */
1014 SAVESPTR(PL_warnhook);
1015 PL_warnhook = PERL_WARNHOOK_FATAL;
1016 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1022 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1023 bufptr = PL_parser->bufptr;
1024 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1025 SvCUR_set(PL_parser->linestr,
1026 SvCUR(PL_parser->linestr) + len-highhalf);
1027 PL_parser->bufend += len-highhalf;
1030 if (UTF8_IS_INVARIANT(*p)) {
1036 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1042 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1043 bufptr = PL_parser->bufptr;
1044 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1045 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1046 PL_parser->bufend += len;
1047 Copy(pv, bufptr, len, char);
1053 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1055 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1056 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1057 reallocating the buffer if necessary. This means that lexing code that
1058 runs later will see the characters as if they had appeared in the input.
1059 It is not recommended to do this as part of normal parsing, and most
1060 uses of this facility run the risk of the inserted characters being
1061 interpreted in an unintended manner.
1063 The string to be inserted is represented by octets starting at C<pv>
1064 and continuing to the first nul. These octets are interpreted as either
1065 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1066 in C<flags>. The characters are recoded for the lexer buffer, according
1067 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1068 If it is not convenient to nul-terminate a string to be inserted, the
1069 L</lex_stuff_pvn> function is more appropriate.
1075 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1077 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1078 lex_stuff_pvn(pv, strlen(pv), flags);
1082 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1084 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1085 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1086 reallocating the buffer if necessary. This means that lexing code that
1087 runs later will see the characters as if they had appeared in the input.
1088 It is not recommended to do this as part of normal parsing, and most
1089 uses of this facility run the risk of the inserted characters being
1090 interpreted in an unintended manner.
1092 The string to be inserted is the string value of C<sv>. The characters
1093 are recoded for the lexer buffer, according to how the buffer is currently
1094 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1095 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1096 need to construct a scalar.
1102 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1106 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1110 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1114 =for apidoc Amx|void|lex_unstuff|char *ptr
1116 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1117 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1118 This hides the discarded text from any lexing code that runs later,
1119 as if the text had never appeared.
1121 This is not the normal way to consume lexed text. For that, use
1128 Perl_lex_unstuff(pTHX_ char *ptr)
1132 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1133 buf = PL_parser->bufptr;
1135 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 bufend = PL_parser->bufend;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1141 unstuff_len = ptr - buf;
1142 Move(ptr, buf, bufend+1-ptr, char);
1143 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1144 PL_parser->bufend = bufend - unstuff_len;
1148 =for apidoc Amx|void|lex_read_to|char *ptr
1150 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1151 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1152 performing the correct bookkeeping whenever a newline character is passed.
1153 This is the normal way to consume lexed text.
1155 Interpretation of the buffer's octets can be abstracted out by
1156 using the slightly higher-level functions L</lex_peek_unichar> and
1157 L</lex_read_unichar>.
1163 Perl_lex_read_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_READ_TO;
1167 s = PL_parser->bufptr;
1168 if (ptr < s || ptr > PL_parser->bufend)
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1170 for (; s != ptr; s++)
1172 COPLINE_INC_WITH_HERELINES;
1173 PL_parser->linestart = s+1;
1175 PL_parser->bufptr = ptr;
1179 =for apidoc Amx|void|lex_discard_to|char *ptr
1181 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1182 up to C<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. C<ptr> must not
1184 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1185 it is not permitted to discard text that has yet to be lexed.
1187 Normally it is not necessarily to do this directly, because it suffices to
1188 use the implicit discarding behaviour of L</lex_next_chunk> and things
1189 based on it. However, if a token stretches across multiple lines,
1190 and the lexing code has kept multiple lines of text in the buffer for
1191 that purpose, then after completion of the token it would be wise to
1192 explicitly discard the now-unneeded earlier lines, to avoid future
1193 multi-line tokens growing the buffer without bound.
1199 Perl_lex_discard_to(pTHX_ char *ptr)
1203 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1204 buf = SvPVX(PL_parser->linestr);
1206 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1209 if (ptr > PL_parser->bufptr)
1210 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1211 discard_len = ptr - buf;
1212 if (PL_parser->oldbufptr < ptr)
1213 PL_parser->oldbufptr = ptr;
1214 if (PL_parser->oldoldbufptr < ptr)
1215 PL_parser->oldoldbufptr = ptr;
1216 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1217 PL_parser->last_uni = NULL;
1218 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1219 PL_parser->last_lop = NULL;
1220 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1221 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1222 PL_parser->bufend -= discard_len;
1223 PL_parser->bufptr -= discard_len;
1224 PL_parser->oldbufptr -= discard_len;
1225 PL_parser->oldoldbufptr -= discard_len;
1226 if (PL_parser->last_uni)
1227 PL_parser->last_uni -= discard_len;
1228 if (PL_parser->last_lop)
1229 PL_parser->last_lop -= discard_len;
1233 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1235 Reads in the next chunk of text to be lexed, appending it to
1236 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1237 looked to the end of the current chunk and wants to know more. It is
1238 usual, but not necessary, for lexing to have consumed the entirety of
1239 the current chunk at this time.
1241 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1242 chunk (i.e., the current chunk has been entirely consumed), normally the
1243 current chunk will be discarded at the same time that the new chunk is
1244 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1245 will not be discarded. If the current chunk has not been entirely
1246 consumed, then it will not be discarded regardless of the flag.
1248 Returns true if some new text was added to the buffer, or false if the
1249 buffer has reached the end of the input text.
1254 #define LEX_FAKE_EOF 0x80000000
1255 #define LEX_NO_TERM 0x40000000 /* here-doc */
1258 Perl_lex_next_chunk(pTHX_ U32 flags)
1262 STRLEN old_bufend_pos, new_bufend_pos;
1263 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1264 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1265 bool got_some_for_debugger = 0;
1267 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1268 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1269 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1271 linestr = PL_parser->linestr;
1272 buf = SvPVX(linestr);
1273 if (!(flags & LEX_KEEP_PREVIOUS)
1274 && PL_parser->bufptr == PL_parser->bufend)
1276 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1278 if (PL_parser->last_uni != PL_parser->bufend)
1279 PL_parser->last_uni = NULL;
1280 if (PL_parser->last_lop != PL_parser->bufend)
1281 PL_parser->last_lop = NULL;
1282 last_uni_pos = last_lop_pos = 0;
1286 old_bufend_pos = PL_parser->bufend - buf;
1287 bufptr_pos = PL_parser->bufptr - buf;
1288 oldbufptr_pos = PL_parser->oldbufptr - buf;
1289 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1290 linestart_pos = PL_parser->linestart - buf;
1291 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1292 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1294 if (flags & LEX_FAKE_EOF) {
1296 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1298 } else if (filter_gets(linestr, old_bufend_pos)) {
1300 got_some_for_debugger = 1;
1301 } else if (flags & LEX_NO_TERM) {
1304 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1305 sv_setpvs(linestr, "");
1307 /* End of real input. Close filehandle (unless it was STDIN),
1308 * then add implicit termination.
1310 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1311 PerlIO_clearerr(PL_parser->rsfp);
1312 else if (PL_parser->rsfp)
1313 (void)PerlIO_close(PL_parser->rsfp);
1314 PL_parser->rsfp = NULL;
1315 PL_parser->in_pod = PL_parser->filtered = 0;
1316 if (!PL_in_eval && PL_minus_p) {
1318 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1319 PL_minus_n = PL_minus_p = 0;
1320 } else if (!PL_in_eval && PL_minus_n) {
1321 sv_catpvs(linestr, /*{*/";}");
1324 sv_catpvs(linestr, ";");
1327 buf = SvPVX(linestr);
1328 new_bufend_pos = SvCUR(linestr);
1329 PL_parser->bufend = buf + new_bufend_pos;
1330 PL_parser->bufptr = buf + bufptr_pos;
1331 PL_parser->oldbufptr = buf + oldbufptr_pos;
1332 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1333 PL_parser->linestart = buf + linestart_pos;
1334 if (PL_parser->last_uni)
1335 PL_parser->last_uni = buf + last_uni_pos;
1336 if (PL_parser->last_lop)
1337 PL_parser->last_lop = buf + last_lop_pos;
1338 if (PL_parser->preambling != NOLINE) {
1339 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1340 PL_parser->preambling = NOLINE;
1342 if ( got_some_for_debugger
1343 && PERLDB_LINE_OR_SAVESRC
1344 && PL_curstash != PL_debstash)
1346 /* debugger active and we're not compiling the debugger code,
1347 * so store the line into the debugger's array of lines
1349 update_debugger_info(NULL, buf+old_bufend_pos,
1350 new_bufend_pos-old_bufend_pos);
1356 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1358 Looks ahead one (Unicode) character in the text currently being lexed.
1359 Returns the codepoint (unsigned integer value) of the next character,
1360 or -1 if lexing has reached the end of the input text. To consume the
1361 peeked character, use L</lex_read_unichar>.
1363 If the next character is in (or extends into) the next chunk of input
1364 text, the next chunk will be read in. Normally the current chunk will be
1365 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1366 bit set, then the current chunk will not be discarded.
1368 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1369 is encountered, an exception is generated.
1375 Perl_lex_peek_unichar(pTHX_ U32 flags)
1379 if (flags & ~(LEX_KEEP_PREVIOUS))
1380 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1381 s = PL_parser->bufptr;
1382 bufend = PL_parser->bufend;
1388 if (!lex_next_chunk(flags))
1390 s = PL_parser->bufptr;
1391 bufend = PL_parser->bufend;
1394 if (UTF8_IS_INVARIANT(head))
1396 if (UTF8_IS_START(head)) {
1397 len = UTF8SKIP(&head);
1398 while ((STRLEN)(bufend-s) < len) {
1399 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1401 s = PL_parser->bufptr;
1402 bufend = PL_parser->bufend;
1405 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1406 if (retlen == (STRLEN)-1) {
1407 /* malformed UTF-8 */
1409 SAVESPTR(PL_warnhook);
1410 PL_warnhook = PERL_WARNHOOK_FATAL;
1411 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1417 if (!lex_next_chunk(flags))
1419 s = PL_parser->bufptr;
1426 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1428 Reads the next (Unicode) character in the text currently being lexed.
1429 Returns the codepoint (unsigned integer value) of the character read,
1430 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1431 if lexing has reached the end of the input text. To non-destructively
1432 examine the next character, use L</lex_peek_unichar> instead.
1434 If the next character is in (or extends into) the next chunk of input
1435 text, the next chunk will be read in. Normally the current chunk will be
1436 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1437 bit set, then the current chunk will not be discarded.
1439 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1440 is encountered, an exception is generated.
1446 Perl_lex_read_unichar(pTHX_ U32 flags)
1449 if (flags & ~(LEX_KEEP_PREVIOUS))
1450 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1451 c = lex_peek_unichar(flags);
1454 COPLINE_INC_WITH_HERELINES;
1456 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1458 ++(PL_parser->bufptr);
1464 =for apidoc Amx|void|lex_read_space|U32 flags
1466 Reads optional spaces, in Perl style, in the text currently being
1467 lexed. The spaces may include ordinary whitespace characters and
1468 Perl-style comments. C<#line> directives are processed if encountered.
1469 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1470 at a non-space character (or the end of the input text).
1472 If spaces extend into the next chunk of input text, the next chunk will
1473 be read in. Normally the current chunk will be discarded at the same
1474 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1475 chunk will not be discarded.
1480 #define LEX_NO_INCLINE 0x40000000
1481 #define LEX_NO_NEXT_CHUNK 0x80000000
1484 Perl_lex_read_space(pTHX_ U32 flags)
1487 const bool can_incline = !(flags & LEX_NO_INCLINE);
1488 bool need_incline = 0;
1489 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1490 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1491 s = PL_parser->bufptr;
1492 bufend = PL_parser->bufend;
1498 } while (!(c == '\n' || (c == 0 && s == bufend)));
1499 } else if (c == '\n') {
1502 PL_parser->linestart = s;
1508 } else if (isSPACE(c)) {
1510 } else if (c == 0 && s == bufend) {
1513 if (flags & LEX_NO_NEXT_CHUNK)
1515 PL_parser->bufptr = s;
1516 l = CopLINE(PL_curcop);
1517 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1518 got_more = lex_next_chunk(flags);
1519 CopLINE_set(PL_curcop, l);
1520 s = PL_parser->bufptr;
1521 bufend = PL_parser->bufend;
1524 if (can_incline && need_incline && PL_parser->rsfp) {
1534 PL_parser->bufptr = s;
1539 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1541 This function performs syntax checking on a prototype, C<proto>.
1542 If C<warn> is true, any illegal characters or mismatched brackets
1543 will trigger illegalproto warnings, declaring that they were
1544 detected in the prototype for C<name>.
1546 The return value is C<true> if this is a valid prototype, and
1547 C<false> if it is not, regardless of whether C<warn> was C<true> or
1550 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1557 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1559 STRLEN len, origlen;
1560 char *p = proto ? SvPV(proto, len) : NULL;
1561 bool bad_proto = FALSE;
1562 bool in_brackets = FALSE;
1563 bool after_slash = FALSE;
1564 char greedy_proto = ' ';
1565 bool proto_after_greedy_proto = FALSE;
1566 bool must_be_last = FALSE;
1567 bool underscore = FALSE;
1568 bool bad_proto_after_underscore = FALSE;
1570 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1576 for (; len--; p++) {
1579 proto_after_greedy_proto = TRUE;
1581 if (!strchr(";@%", *p))
1582 bad_proto_after_underscore = TRUE;
1585 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1592 in_brackets = FALSE;
1593 else if ((*p == '@' || *p == '%')
1597 must_be_last = TRUE;
1606 after_slash = FALSE;
1611 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1614 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1615 origlen, UNI_DISPLAY_ISPRINT)
1616 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1618 if (proto_after_greedy_proto)
1619 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1620 "Prototype after '%c' for %"SVf" : %s",
1621 greedy_proto, SVfARG(name), p);
1623 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1624 "Missing ']' in prototype for %"SVf" : %s",
1627 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1628 "Illegal character in prototype for %"SVf" : %s",
1630 if (bad_proto_after_underscore)
1631 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1632 "Illegal character after '_' in prototype for %"SVf" : %s",
1636 return (! (proto_after_greedy_proto || bad_proto) );
1641 * This subroutine has nothing to do with tilting, whether at windmills
1642 * or pinball tables. Its name is short for "increment line". It
1643 * increments the current line number in CopLINE(PL_curcop) and checks
1644 * to see whether the line starts with a comment of the form
1645 * # line 500 "foo.pm"
1646 * If so, it sets the current line number and file to the values in the comment.
1650 S_incline(pTHX_ const char *s)
1658 PERL_ARGS_ASSERT_INCLINE;
1660 COPLINE_INC_WITH_HERELINES;
1661 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1662 && s+1 == PL_bufend && *s == ';') {
1663 /* fake newline in string eval */
1664 CopLINE_dec(PL_curcop);
1669 while (SPACE_OR_TAB(*s))
1671 if (strnEQ(s, "line", 4))
1675 if (SPACE_OR_TAB(*s))
1679 while (SPACE_OR_TAB(*s))
1687 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1689 while (SPACE_OR_TAB(*s))
1691 if (*s == '"' && (t = strchr(s+1, '"'))) {
1697 while (!isSPACE(*t))
1701 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1703 if (*e != '\n' && *e != '\0')
1704 return; /* false alarm */
1706 if (!grok_atoUV(n, &uv, &e))
1708 line_num = ((line_t)uv) - 1;
1711 const STRLEN len = t - s;
1713 if (!PL_rsfp && !PL_parser->filtered) {
1714 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1715 * to *{"::_<newfilename"} */
1716 /* However, the long form of evals is only turned on by the
1717 debugger - usually they're "(eval %lu)" */
1718 GV * const cfgv = CopFILEGV(PL_curcop);
1721 STRLEN tmplen2 = len;
1725 if (tmplen2 + 2 <= sizeof smallbuf)
1728 Newx(tmpbuf2, tmplen2 + 2, char);
1733 memcpy(tmpbuf2 + 2, s, tmplen2);
1736 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1738 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1739 /* adjust ${"::_<newfilename"} to store the new file name */
1740 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1741 /* The line number may differ. If that is the case,
1742 alias the saved lines that are in the array.
1743 Otherwise alias the whole array. */
1744 if (CopLINE(PL_curcop) == line_num) {
1745 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1746 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1748 else if (GvAV(cfgv)) {
1749 AV * const av = GvAV(cfgv);
1750 const I32 start = CopLINE(PL_curcop)+1;
1751 I32 items = AvFILLp(av) - start;
1753 AV * const av2 = GvAVn(gv2);
1754 SV **svp = AvARRAY(av) + start;
1755 I32 l = (I32)line_num+1;
1757 av_store(av2, l++, SvREFCNT_inc(*svp++));
1762 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1765 CopFILE_free(PL_curcop);
1766 CopFILE_setn(PL_curcop, s, len);
1768 CopLINE_set(PL_curcop, line_num);
1771 #define skipspace(s) skipspace_flags(s, 0)
1775 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1777 AV *av = CopFILEAVx(PL_curcop);
1780 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1782 sv = *av_fetch(av, 0, 1);
1783 SvUPGRADE(sv, SVt_PVMG);
1785 if (!SvPOK(sv)) sv_setpvs(sv,"");
1787 sv_catsv(sv, orig_sv);
1789 sv_catpvn(sv, buf, len);
1794 if (PL_parser->preambling == NOLINE)
1795 av_store(av, CopLINE(PL_curcop), sv);
1801 * Called to gobble the appropriate amount and type of whitespace.
1802 * Skips comments as well.
1806 S_skipspace_flags(pTHX_ char *s, U32 flags)
1808 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1809 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1810 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1813 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1815 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1816 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1817 LEX_NO_NEXT_CHUNK : 0));
1819 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1820 if (PL_linestart > PL_bufptr)
1821 PL_bufptr = PL_linestart;
1829 * Check the unary operators to ensure there's no ambiguity in how they're
1830 * used. An ambiguous piece of code would be:
1832 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1833 * the +5 is its argument.
1842 if (PL_oldoldbufptr != PL_last_uni)
1844 while (isSPACE(*PL_last_uni))
1847 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1848 s += UTF ? UTF8SKIP(s) : 1;
1849 if ((t = strchr(s, '(')) && t < PL_bufptr)
1852 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1853 "Warning: Use of \"%"UTF8f"\" without parentheses is ambiguous",
1854 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1858 * LOP : macro to build a list operator. Its behaviour has been replaced
1859 * with a subroutine, S_lop() for which LOP is just another name.
1862 #define LOP(f,x) return lop(f,x,s)
1866 * Build a list operator (or something that might be one). The rules:
1867 * - if we have a next token, then it's a list operator (no parens) for
1868 * which the next token has already been parsed; e.g.,
1871 * - if the next thing is an opening paren, then it's a function
1872 * - else it's a list operator
1876 S_lop(pTHX_ I32 f, int x, char *s)
1878 PERL_ARGS_ASSERT_LOP;
1883 PL_last_lop = PL_oldbufptr;
1884 PL_last_lop_op = (OPCODE)f;
1889 return REPORT(FUNC);
1892 return REPORT(FUNC);
1895 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1896 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1897 return REPORT(LSTOP);
1903 * When the lexer realizes it knows the next token (for instance,
1904 * it is reordering tokens for the parser) then it can call S_force_next
1905 * to know what token to return the next time the lexer is called. Caller
1906 * will need to set PL_nextval[] and possibly PL_expect to ensure
1907 * the lexer handles the token correctly.
1911 S_force_next(pTHX_ I32 type)
1915 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1916 tokereport(type, &NEXTVAL_NEXTTOKE);
1919 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1920 PL_nexttype[PL_nexttoke] = type;
1922 if (PL_lex_state != LEX_KNOWNEXT) {
1923 PL_lex_defer = PL_lex_state;
1924 PL_lex_state = LEX_KNOWNEXT;
1931 * This subroutine handles postfix deref syntax after the arrow has already
1932 * been emitted. @* $* etc. are emitted as two separate token right here.
1933 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1934 * only the first, leaving yylex to find the next.
1938 S_postderef(pTHX_ int const funny, char const next)
1940 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1941 assert(strchr("*[{", next));
1943 PL_expect = XOPERATOR;
1944 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1945 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1946 PL_lex_state = LEX_INTERPEND;
1947 force_next(POSTJOIN);
1953 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1954 && !PL_lex_brackets)
1956 PL_expect = XOPERATOR;
1965 int yyc = PL_parser->yychar;
1966 if (yyc != YYEMPTY) {
1968 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1969 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1970 PL_lex_allbrackets--;
1972 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1973 } else if (yyc == '('/*)*/) {
1974 PL_lex_allbrackets--;
1979 PL_parser->yychar = YYEMPTY;
1984 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1986 SV * const sv = newSVpvn_utf8(start, len,
1989 && !is_invariant_string((const U8*)start, len)
1990 && is_utf8_string((const U8*)start, len));
1996 * When the lexer knows the next thing is a word (for instance, it has
1997 * just seen -> and it knows that the next char is a word char, then
1998 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2002 * char *start : buffer position (must be within PL_linestr)
2003 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2004 * int check_keyword : if true, Perl checks to make sure the word isn't
2005 * a keyword (do this if the word is a label, e.g. goto FOO)
2006 * int allow_pack : if true, : characters will also be allowed (require,
2007 * use, etc. do this)
2011 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2016 PERL_ARGS_ASSERT_FORCE_WORD;
2018 start = skipspace(start);
2020 if (isIDFIRST_lazy_if(s,UTF)
2021 || (allow_pack && *s == ':') )
2023 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2024 if (check_keyword) {
2025 char *s2 = PL_tokenbuf;
2027 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2029 if (keyword(s2, len2, 0))
2032 if (token == METHOD) {
2037 PL_expect = XOPERATOR;
2040 NEXTVAL_NEXTTOKE.opval
2041 = (OP*)newSVOP(OP_CONST,0,
2042 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2043 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2051 * Called when the lexer wants $foo *foo &foo etc, but the program
2052 * text only contains the "foo" portion. The first argument is a pointer
2053 * to the "foo", and the second argument is the type symbol to prefix.
2054 * Forces the next token to be a "WORD".
2055 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2059 S_force_ident(pTHX_ const char *s, int kind)
2061 PERL_ARGS_ASSERT_FORCE_IDENT;
2064 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2065 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2066 UTF ? SVf_UTF8 : 0));
2067 NEXTVAL_NEXTTOKE.opval = o;
2070 o->op_private = OPpCONST_ENTERED;
2071 /* XXX see note in pp_entereval() for why we forgo typo
2072 warnings if the symbol must be introduced in an eval.
2074 gv_fetchpvn_flags(s, len,
2075 (PL_in_eval ? GV_ADDMULTI
2076 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2077 kind == '$' ? SVt_PV :
2078 kind == '@' ? SVt_PVAV :
2079 kind == '%' ? SVt_PVHV :
2087 S_force_ident_maybe_lex(pTHX_ char pit)
2089 NEXTVAL_NEXTTOKE.ival = pit;
2094 Perl_str_to_version(pTHX_ SV *sv)
2099 const char *start = SvPV_const(sv,len);
2100 const char * const end = start + len;
2101 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2103 PERL_ARGS_ASSERT_STR_TO_VERSION;
2105 while (start < end) {
2109 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2114 retval += ((NV)n)/nshift;
2123 * Forces the next token to be a version number.
2124 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2125 * and if "guessing" is TRUE, then no new token is created (and the caller
2126 * must use an alternative parsing method).
2130 S_force_version(pTHX_ char *s, int guessing)
2135 PERL_ARGS_ASSERT_FORCE_VERSION;
2143 while (isDIGIT(*d) || *d == '_' || *d == '.')
2145 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2147 s = scan_num(s, &pl_yylval);
2148 version = pl_yylval.opval;
2149 ver = cSVOPx(version)->op_sv;
2150 if (SvPOK(ver) && !SvNIOK(ver)) {
2151 SvUPGRADE(ver, SVt_PVNV);
2152 SvNV_set(ver, str_to_version(ver));
2153 SvNOK_on(ver); /* hint that it is a version */
2156 else if (guessing) {
2161 /* NOTE: The parser sees the package name and the VERSION swapped */
2162 NEXTVAL_NEXTTOKE.opval = version;
2169 * S_force_strict_version
2170 * Forces the next token to be a version number using strict syntax rules.
2174 S_force_strict_version(pTHX_ char *s)
2177 const char *errstr = NULL;
2179 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2181 while (isSPACE(*s)) /* leading whitespace */
2184 if (is_STRICT_VERSION(s,&errstr)) {
2186 s = (char *)scan_version(s, ver, 0);
2187 version = newSVOP(OP_CONST, 0, ver);
2189 else if ((*s != ';' && *s != '{' && *s != '}' )
2190 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2194 yyerror(errstr); /* version required */
2198 /* NOTE: The parser sees the package name and the VERSION swapped */
2199 NEXTVAL_NEXTTOKE.opval = version;
2207 * Tokenize a quoted string passed in as an SV. It finds the next
2208 * chunk, up to end of string or a backslash. It may make a new
2209 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2214 S_tokeq(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_TOKEQ;
2225 assert (!SvIsCOW(sv));
2226 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2230 /* This is relying on the SV being "well formed" with a trailing '\0' */
2231 while (s < send && !(*s == '\\' && s[1] == '\\'))
2236 if ( PL_hints & HINT_NEW_STRING ) {
2237 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2238 SVs_TEMP | SvUTF8(sv));
2242 if (s + 1 < send && (s[1] == '\\'))
2243 s++; /* all that, just for this */
2248 SvCUR_set(sv, d - SvPVX_const(sv));
2250 if ( PL_hints & HINT_NEW_STRING )
2251 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2256 * Now come three functions related to double-quote context,
2257 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2258 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2259 * interact with PL_lex_state, and create fake ( ... ) argument lists
2260 * to handle functions and concatenation.
2264 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2269 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2271 * Pattern matching will set PL_lex_op to the pattern-matching op to
2272 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2274 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2276 * Everything else becomes a FUNC.
2278 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2279 * had an OP_CONST or OP_READLINE). This just sets us up for a
2280 * call to S_sublex_push().
2284 S_sublex_start(pTHX)
2286 const I32 op_type = pl_yylval.ival;
2288 if (op_type == OP_NULL) {
2289 pl_yylval.opval = PL_lex_op;
2293 if (op_type == OP_CONST) {
2294 SV *sv = PL_lex_stuff;
2295 PL_lex_stuff = NULL;
2298 if (SvTYPE(sv) == SVt_PVIV) {
2299 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2301 const char * const p = SvPV_const(sv, len);
2302 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2306 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2310 PL_sublex_info.super_state = PL_lex_state;
2311 PL_sublex_info.sub_inwhat = (U16)op_type;
2312 PL_sublex_info.sub_op = PL_lex_op;
2313 PL_lex_state = LEX_INTERPPUSH;
2317 pl_yylval.opval = PL_lex_op;
2327 * Create a new scope to save the lexing state. The scope will be
2328 * ended in S_sublex_done. Returns a '(', starting the function arguments
2329 * to the uc, lc, etc. found before.
2330 * Sets PL_lex_state to LEX_INTERPCONCAT.
2337 const bool is_heredoc = PL_multi_close == '<';
2340 PL_lex_state = PL_sublex_info.super_state;
2341 SAVEI8(PL_lex_dojoin);
2342 SAVEI32(PL_lex_brackets);
2343 SAVEI32(PL_lex_allbrackets);
2344 SAVEI32(PL_lex_formbrack);
2345 SAVEI8(PL_lex_fakeeof);
2346 SAVEI32(PL_lex_casemods);
2347 SAVEI32(PL_lex_starts);
2348 SAVEI8(PL_lex_state);
2349 SAVEI8(PL_lex_defer);
2350 SAVESPTR(PL_lex_repl);
2351 SAVEVPTR(PL_lex_inpat);
2352 SAVEI16(PL_lex_inwhat);
2355 SAVECOPLINE(PL_curcop);
2356 SAVEI32(PL_multi_end);
2357 SAVEI32(PL_parser->herelines);
2358 PL_parser->herelines = 0;
2360 SAVEI8(PL_multi_close);
2361 SAVEPPTR(PL_bufptr);
2362 SAVEPPTR(PL_bufend);
2363 SAVEPPTR(PL_oldbufptr);
2364 SAVEPPTR(PL_oldoldbufptr);
2365 SAVEPPTR(PL_last_lop);
2366 SAVEPPTR(PL_last_uni);
2367 SAVEPPTR(PL_linestart);
2368 SAVESPTR(PL_linestr);
2369 SAVEGENERICPV(PL_lex_brackstack);
2370 SAVEGENERICPV(PL_lex_casestack);
2371 SAVEGENERICPV(PL_parser->lex_shared);
2372 SAVEBOOL(PL_parser->lex_re_reparsing);
2373 SAVEI32(PL_copline);
2375 /* The here-doc parser needs to be able to peek into outer lexing
2376 scopes to find the body of the here-doc. So we put PL_linestr and
2377 PL_bufptr into lex_shared, to ‘share’ those values.
2379 PL_parser->lex_shared->ls_linestr = PL_linestr;
2380 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2382 PL_linestr = PL_lex_stuff;
2383 PL_lex_repl = PL_sublex_info.repl;
2384 PL_lex_stuff = NULL;
2385 PL_sublex_info.repl = NULL;
2387 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2388 set for an inner quote-like operator and then an error causes scope-
2389 popping. We must not have a PL_lex_stuff value left dangling, as
2390 that breaks assumptions elsewhere. See bug #123617. */
2391 SAVEGENERICSV(PL_lex_stuff);
2392 SAVEGENERICSV(PL_sublex_info.repl);
2394 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2395 = SvPVX(PL_linestr);
2396 PL_bufend += SvCUR(PL_linestr);
2397 PL_last_lop = PL_last_uni = NULL;
2398 SAVEFREESV(PL_linestr);
2399 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2401 PL_lex_dojoin = FALSE;
2402 PL_lex_brackets = PL_lex_formbrack = 0;
2403 PL_lex_allbrackets = 0;
2404 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2405 Newx(PL_lex_brackstack, 120, char);
2406 Newx(PL_lex_casestack, 12, char);
2407 PL_lex_casemods = 0;
2408 *PL_lex_casestack = '\0';
2410 PL_lex_state = LEX_INTERPCONCAT;
2412 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2413 PL_copline = NOLINE;
2415 Newxz(shared, 1, LEXSHARED);
2416 shared->ls_prev = PL_parser->lex_shared;
2417 PL_parser->lex_shared = shared;
2419 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2420 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2421 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2422 PL_lex_inpat = PL_sublex_info.sub_op;
2424 PL_lex_inpat = NULL;
2426 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2427 PL_in_eval &= ~EVAL_RE_REPARSING;
2434 * Restores lexer state after a S_sublex_push.
2440 if (!PL_lex_starts++) {
2441 SV * const sv = newSVpvs("");
2442 if (SvUTF8(PL_linestr))
2444 PL_expect = XOPERATOR;
2445 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2449 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2450 PL_lex_state = LEX_INTERPCASEMOD;
2454 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2455 assert(PL_lex_inwhat != OP_TRANSR);
2457 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2458 PL_linestr = PL_lex_repl;
2460 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2461 PL_bufend += SvCUR(PL_linestr);
2462 PL_last_lop = PL_last_uni = NULL;
2463 PL_lex_dojoin = FALSE;
2464 PL_lex_brackets = 0;
2465 PL_lex_allbrackets = 0;
2466 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2467 PL_lex_casemods = 0;
2468 *PL_lex_casestack = '\0';
2470 if (SvEVALED(PL_lex_repl)) {
2471 PL_lex_state = LEX_INTERPNORMAL;
2473 /* we don't clear PL_lex_repl here, so that we can check later
2474 whether this is an evalled subst; that means we rely on the
2475 logic to ensure sublex_done() is called again only via the
2476 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2479 PL_lex_state = LEX_INTERPCONCAT;
2482 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2483 CopLINE(PL_curcop) +=
2484 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2485 + PL_parser->herelines;
2486 PL_parser->herelines = 0;
2491 const line_t l = CopLINE(PL_curcop);
2493 if (PL_multi_close == '<')
2494 PL_parser->herelines += l - PL_multi_end;
2495 PL_bufend = SvPVX(PL_linestr);
2496 PL_bufend += SvCUR(PL_linestr);
2497 PL_expect = XOPERATOR;
2502 PERL_STATIC_INLINE SV*
2503 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2505 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2506 * interior, hence to the "}". Finds what the name resolves to, returning
2507 * an SV* containing it; NULL if no valid one found */
2509 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2516 const U8* first_bad_char_loc;
2517 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2519 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2524 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2526 &first_bad_char_loc))
2528 /* If warnings are on, this will print a more detailed analysis of what
2529 * is wrong than the error message below */
2530 utf8n_to_uvchr(first_bad_char_loc,
2531 e - ((char *) first_bad_char_loc),
2534 /* We deliberately don't try to print the malformed character, which
2535 * might not print very well; it also may be just the first of many
2536 * malformations, so don't print what comes after it */
2537 yyerror_pv(Perl_form(aTHX_
2538 "Malformed UTF-8 character immediately after '%.*s'",
2539 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2544 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2545 /* include the <}> */
2546 e - backslash_ptr + 1);
2548 SvREFCNT_dec_NN(res);
2552 /* See if the charnames handler is the Perl core's, and if so, we can skip
2553 * the validation needed for a user-supplied one, as Perl's does its own
2555 table = GvHV(PL_hintgv); /* ^H */
2556 cvp = hv_fetchs(table, "charnames", FALSE);
2557 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2558 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2560 const char * const name = HvNAME(stash);
2561 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2562 && strEQ(name, "_charnames")) {
2567 /* Here, it isn't Perl's charname handler. We can't rely on a
2568 * user-supplied handler to validate the input name. For non-ut8 input,
2569 * look to see that the first character is legal. Then loop through the
2570 * rest checking that each is a continuation */
2572 /* This code makes the reasonable assumption that the only Latin1-range
2573 * characters that begin a character name alias are alphabetic, otherwise
2574 * would have to create a isCHARNAME_BEGIN macro */
2577 if (! isALPHAU(*s)) {
2582 if (! isCHARNAME_CONT(*s)) {
2585 if (*s == ' ' && *(s-1) == ' ') {
2588 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2589 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2590 "NO-BREAK SPACE in a charnames "
2591 "alias definition is deprecated");
2597 /* Similarly for utf8. For invariants can check directly; for other
2598 * Latin1, can calculate their code point and check; otherwise use a
2600 if (UTF8_IS_INVARIANT(*s)) {
2601 if (! isALPHAU(*s)) {
2605 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2606 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2612 if (! PL_utf8_charname_begin) {
2613 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2614 PL_utf8_charname_begin = _core_swash_init("utf8",
2615 "_Perl_Charname_Begin",
2617 1, 0, NULL, &flags);
2619 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2626 if (UTF8_IS_INVARIANT(*s)) {
2627 if (! isCHARNAME_CONT(*s)) {
2630 if (*s == ' ' && *(s-1) == ' ') {
2635 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2636 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2640 if (*s == *NBSP_UTF8
2641 && *(s+1) == *(NBSP_UTF8+1)
2642 && ckWARN_d(WARN_DEPRECATED))
2644 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2645 "NO-BREAK SPACE in a charnames "
2646 "alias definition is deprecated");
2651 if (! PL_utf8_charname_continue) {
2652 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2653 PL_utf8_charname_continue = _core_swash_init("utf8",
2654 "_Perl_Charname_Continue",
2656 1, 0, NULL, &flags);
2658 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2665 if (*(s-1) == ' ') {
2668 "charnames alias definitions may not contain trailing "
2669 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2670 (int)(s - backslash_ptr + 1), backslash_ptr,
2671 (int)(e - s + 1), s + 1
2673 UTF ? SVf_UTF8 : 0);
2677 if (SvUTF8(res)) { /* Don't accept malformed input */
2678 const U8* first_bad_char_loc;
2680 const char* const str = SvPV_const(res, len);
2681 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2682 /* If warnings are on, this will print a more detailed analysis of
2683 * what is wrong than the error message below */
2684 utf8n_to_uvchr(first_bad_char_loc,
2685 (char *) first_bad_char_loc - str,
2688 /* We deliberately don't try to print the malformed character,
2689 * which might not print very well; it also may be just the first
2690 * of many malformations, so don't print what comes after it */
2693 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2694 (int) (e - backslash_ptr + 1), backslash_ptr,
2695 (int) ((char *) first_bad_char_loc - str), str
2706 /* The final %.*s makes sure that should the trailing NUL be missing
2707 * that this print won't run off the end of the string */
2710 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2711 (int)(s - backslash_ptr + 1), backslash_ptr,
2712 (int)(e - s + 1), s + 1
2714 UTF ? SVf_UTF8 : 0);
2721 "charnames alias definitions may not contain a sequence of "
2722 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2723 (int)(s - backslash_ptr + 1), backslash_ptr,
2724 (int)(e - s + 1), s + 1
2726 UTF ? SVf_UTF8 : 0);
2733 Extracts the next constant part of a pattern, double-quoted string,
2734 or transliteration. This is terrifying code.
2736 For example, in parsing the double-quoted string "ab\x63$d", it would
2737 stop at the '$' and return an OP_CONST containing 'abc'.
2739 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2740 processing a pattern (PL_lex_inpat is true), a transliteration
2741 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2743 Returns a pointer to the character scanned up to. If this is
2744 advanced from the start pointer supplied (i.e. if anything was
2745 successfully parsed), will leave an OP_CONST for the substring scanned
2746 in pl_yylval. Caller must intuit reason for not parsing further
2747 by looking at the next characters herself.
2751 \N{FOO} => \N{U+hex_for_character_FOO}
2752 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2755 all other \-char, including \N and \N{ apart from \N{ABC}
2758 @ and $ where it appears to be a var, but not for $ as tail anchor
2762 In transliterations:
2763 characters are VERY literal, except for - not at the start or end
2764 of the string, which indicates a range. If the range is in bytes,
2765 scan_const expands the range to the full set of intermediate
2766 characters. If the range is in utf8, the hyphen is replaced with
2767 a certain range mark which will be handled by pmtrans() in op.c.
2769 In double-quoted strings:
2771 double-quoted style: \r and \n
2772 constants: \x31, etc.
2773 deprecated backrefs: \1 (in substitution replacements)
2774 case and quoting: \U \Q \E
2777 scan_const does *not* construct ops to handle interpolated strings.
2778 It stops processing as soon as it finds an embedded $ or @ variable
2779 and leaves it to the caller to work out what's going on.
2781 embedded arrays (whether in pattern or not) could be:
2782 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2784 $ in double-quoted strings must be the symbol of an embedded scalar.
2786 $ in pattern could be $foo or could be tail anchor. Assumption:
2787 it's a tail anchor if $ is the last thing in the string, or if it's
2788 followed by one of "()| \r\n\t"
2790 \1 (backreferences) are turned into $1 in substitutions
2792 The structure of the code is
2793 while (there's a character to process) {
2794 handle transliteration ranges
2795 skip regexp comments /(?#comment)/ and codes /(?{code})/
2796 skip #-initiated comments in //x patterns
2797 check for embedded arrays
2798 check for embedded scalars
2800 deprecate \1 in substitution replacements
2801 handle string-changing backslashes \l \U \Q \E, etc.
2802 switch (what was escaped) {
2803 handle \- in a transliteration (becomes a literal -)
2804 if a pattern and not \N{, go treat as regular character
2805 handle \132 (octal characters)
2806 handle \x15 and \x{1234} (hex characters)
2807 handle \N{name} (named characters, also \N{3,5} in a pattern)
2808 handle \cV (control characters)
2809 handle printf-style backslashes (\f, \r, \n, etc)
2812 } (end if backslash)
2813 handle regular character
2814 } (end while character to read)
2819 S_scan_const(pTHX_ char *start)
2821 char *send = PL_bufend; /* end of the constant */
2822 SV *sv = newSV(send - start); /* sv for the constant. See note below
2824 char *s = start; /* start of the constant */
2825 char *d = SvPVX(sv); /* destination for copies */
2826 bool dorange = FALSE; /* are we in a translit range? */
2827 bool didrange = FALSE; /* did we just finish a range? */
2828 bool in_charclass = FALSE; /* within /[...]/ */
2829 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2830 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2831 UTF8? But, this can show as true
2832 when the source isn't utf8, as for
2833 example when it is entirely composed
2835 SV *res; /* result from charnames */
2837 /* Note on sizing: The scanned constant is placed into sv, which is
2838 * initialized by newSV() assuming one byte of output for every byte of
2839 * input. This routine expects newSV() to allocate an extra byte for a
2840 * trailing NUL, which this routine will append if it gets to the end of
2841 * the input. There may be more bytes of input than output (eg., \N{LATIN
2842 * CAPITAL LETTER A}), or more output than input if the constant ends up
2843 * recoded to utf8, but each time a construct is found that might increase
2844 * the needed size, SvGROW() is called. Its size parameter each time is
2845 * based on the best guess estimate at the time, namely the length used so
2846 * far, plus the length the current construct will occupy, plus room for
2847 * the trailing NUL, plus one byte for every input byte still unscanned */
2849 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2852 UV literal_endpoint = 0;
2853 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2856 PERL_ARGS_ASSERT_SCAN_CONST;
2858 assert(PL_lex_inwhat != OP_TRANSR);
2859 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2860 /* If we are doing a trans and we know we want UTF8 set expectation */
2861 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2862 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2865 /* Protect sv from errors and fatal warnings. */
2866 ENTER_with_name("scan_const");
2869 while (s < send || dorange) {
2871 /* get transliterations out of the way (they're most literal) */
2872 if (PL_lex_inwhat == OP_TRANS) {
2873 /* expand a range A-Z to the full set of characters. AIE! */
2875 I32 i; /* current expanded character */
2876 I32 min; /* first character in range */
2877 I32 max; /* last character in range */
2888 char * const c = (char*)utf8_hop((U8*)d, -1);
2892 *c = (char) ILLEGAL_UTF8_BYTE;
2893 /* mark the range as done, and continue */
2899 i = d - SvPVX_const(sv); /* remember current offset */
2902 SvLEN(sv) + ((has_utf8)
2903 ? (512 - UTF_CONTINUATION_MARK
2906 /* How many two-byte within 0..255: 128 in UTF-8,
2907 * 96 in UTF-8-mod. */
2909 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2911 d = SvPVX(sv) + i; /* refresh d after realloc */
2915 for (j = 0; j <= 1; j++) {
2916 char * const c = (char*)utf8_hop((U8*)d, -1);
2917 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2923 max = (U8)0xff; /* only to \xff */
2924 uvmax = uv; /* \x{100} to uvmax */
2926 d = c; /* eat endpoint chars */
2931 d -= 2; /* eat the first char and the - */
2932 min = (U8)*d; /* first char in range */
2933 max = (U8)d[1]; /* last char in range */
2940 "Invalid range \"%c-%c\" in transliteration operator",
2941 (char)min, (char)max);
2945 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2946 * any subsets of these ranges into individual characters */
2947 if (literal_endpoint == 2
2948 && ((isLOWER_A(min) && isLOWER_A(max))
2949 || (isUPPER_A(min) && isUPPER_A(max))))
2951 for (i = min; i <= max; i++) {
2958 for (i = min; i <= max; i++)
2961 append_utf8_from_native_byte(i, &d);
2969 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2971 *d++ = (char) ILLEGAL_UTF8_BYTE;
2973 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2977 /* mark the range as done, and continue */
2981 literal_endpoint = 0;
2986 /* range begins (ignore - as first or last char) */
2987 else if (*s == '-' && s+1 < send && s != start) {
2989 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2996 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
3006 literal_endpoint = 0;
3007 native_range = TRUE;
3012 /* if we get to any of these else's, we're not doing a
3013 * transliteration. */
3015 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3018 while (s1 >= start && *s1-- == '\\')
3021 in_charclass = TRUE;
3024 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3027 while (s1 >= start && *s1-- == '\\')
3030 in_charclass = FALSE;
3033 /* skip for regexp comments /(?#comment)/, except for the last
3034 * char, which will be done separately.
3035 * Stop on (?{..}) and friends */
3037 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3039 while (s+1 < send && *s != ')')
3042 else if (!PL_lex_casemods
3043 && ( s[2] == '{' /* This should match regcomp.c */
3044 || (s[2] == '?' && s[3] == '{')))
3050 /* likewise skip #-initiated comments in //x patterns */
3054 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3056 while (s+1 < send && *s != '\n')
3060 /* no further processing of single-quoted regex */
3061 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3062 goto default_action;
3064 /* check for embedded arrays
3065 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3067 else if (*s == '@' && s[1]) {
3068 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3070 if (strchr(":'{$", s[1]))
3072 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3073 break; /* in regexp, neither @+ nor @- are interpolated */
3076 /* check for embedded scalars. only stop if we're sure it's a
3079 else if (*s == '$') {
3080 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3082 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3084 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3085 "Possible unintended interpolation of $\\ in regex");
3087 break; /* in regexp, $ might be tail anchor */
3091 /* End of else if chain - OP_TRANS rejoin rest */
3094 if (*s == '\\' && s+1 < send) {
3095 char* e; /* Can be used for ending '}', etc. */
3099 /* warn on \1 - \9 in substitution replacements, but note that \11
3100 * is an octal; and \19 is \1 followed by '9' */
3101 if (PL_lex_inwhat == OP_SUBST
3107 /* diag_listed_as: \%d better written as $%d */
3108 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3113 /* string-change backslash escapes */
3114 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3118 /* In a pattern, process \N, but skip any other backslash escapes.
3119 * This is because we don't want to translate an escape sequence
3120 * into a meta symbol and have the regex compiler use the meta
3121 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3122 * in spite of this, we do have to process \N here while the proper
3123 * charnames handler is in scope. See bugs #56444 and #62056.
3125 * There is a complication because \N in a pattern may also stand
3126 * for 'match a non-nl', and not mean a charname, in which case its
3127 * processing should be deferred to the regex compiler. To be a
3128 * charname it must be followed immediately by a '{', and not look
3129 * like \N followed by a curly quantifier, i.e., not something like
3130 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3132 else if (PL_lex_inpat
3135 || regcurly(s + 1)))
3138 goto default_action;
3143 /* quoted - in transliterations */
3145 if (PL_lex_inwhat == OP_TRANS) {
3152 if ((isALPHANUMERIC(*s)))
3153 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3154 "Unrecognized escape \\%c passed through",
3156 /* default action is to copy the quoted character */
3157 goto default_action;
3160 /* eg. \132 indicates the octal constant 0132 */
3161 case '0': case '1': case '2': case '3':
3162 case '4': case '5': case '6': case '7':
3164 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3166 uv = grok_oct(s, &len, &flags, NULL);
3168 if (len < 3 && s < send && isDIGIT(*s)
3169 && ckWARN(WARN_MISC))
3171 Perl_warner(aTHX_ packWARN(WARN_MISC),
3172 "%s", form_short_octal_warning(s, len));
3175 goto NUM_ESCAPE_INSERT;
3177 /* eg. \o{24} indicates the octal constant \024 */
3182 bool valid = grok_bslash_o(&s, &uv, &error,
3183 TRUE, /* Output warning */
3184 FALSE, /* Not strict */
3185 TRUE, /* Output warnings for
3192 goto NUM_ESCAPE_INSERT;
3195 /* eg. \x24 indicates the hex constant 0x24 */
3200 bool valid = grok_bslash_x(&s, &uv, &error,
3201 TRUE, /* Output warning */
3202 FALSE, /* Not strict */
3203 TRUE, /* Output warnings for
3213 /* Insert oct or hex escaped character. There will always be
3214 * enough room in sv since such escapes will be longer than any
3215 * UTF-8 sequence they can end up as, except if they force us
3216 * to recode the rest of the string into utf8 */
3218 /* Here uv is the ordinal of the next character being added */
3219 if (!UVCHR_IS_INVARIANT(uv)) {
3220 if (!has_utf8 && uv > 255) {
3221 /* Might need to recode whatever we have accumulated so
3222 * far if it contains any chars variant in utf8 or
3225 SvCUR_set(sv, d - SvPVX_const(sv));
3228 /* See Note on sizing above. */
3229 sv_utf8_upgrade_flags_grow(
3231 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3232 /* Above-latin1 in string
3233 * implies no encoding */
3234 |SV_UTF8_NO_ENCODING,
3235 UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
3236 d = SvPVX(sv) + SvCUR(sv);
3241 d = (char*)uvchr_to_utf8((U8*)d, uv);
3242 if (PL_lex_inwhat == OP_TRANS
3243 && PL_sublex_info.sub_op)
3245 PL_sublex_info.sub_op->op_private |=
3246 (PL_lex_repl ? OPpTRANS_FROM_UTF
3250 if (uv > 255 && !dorange)
3251 native_range = FALSE;
3264 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3265 * named character, like \N{LATIN SMALL LETTER A}, or a named
3266 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3267 * GRAVE}. For convenience all three forms are referred to as
3268 * "named characters" below.
3270 * For patterns, \N also can mean to match a non-newline. Code
3271 * before this 'switch' statement should already have handled
3272 * this situation, and hence this code only has to deal with
3273 * the named character cases.
3275 * For non-patterns, the named characters are converted to
3276 * their string equivalents. In patterns, named characters are
3277 * not converted to their ultimate forms for the same reasons
3278 * that other escapes aren't. Instead, they are converted to
3279 * the \N{U+...} form to get the value from the charnames that
3280 * is in effect right now, while preserving the fact that it
3281 * was a named character, so that the regex compiler knows
3284 * The structure of this section of code (besides checking for
3285 * errors and upgrading to utf8) is:
3286 * If the named character is of the form \N{U+...}, pass it
3287 * through if a pattern; otherwise convert the code point
3289 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3290 * if a pattern; otherwise convert to utf8
3292 * Here, 's' points to the 'N'; the test below is guaranteed to
3293 * succeed if we are being called on a pattern, as we already
3294 * know from a test above that the next character is a '{'. A
3295 * non-pattern \N must mean 'named character', which requires
3299 yyerror("Missing braces on \\N{}");
3304 /* If there is no matching '}', it is an error. */
3305 if (! (e = strchr(s, '}'))) {
3306 if (! PL_lex_inpat) {
3307 yyerror("Missing right brace on \\N{}");
3309 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3314 /* Here it looks like a named character */
3316 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3317 s += 2; /* Skip to next char after the 'U+' */
3320 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3321 /* Check the syntax. */
3324 if (!isXDIGIT(*s)) {
3327 "Invalid hexadecimal number in \\N{U+...}"
3335 else if ((*s == '.' || *s == '_')
3341 /* Pass everything through unchanged.
3342 * +1 is for the '}' */
3343 Copy(orig_s, d, e - orig_s + 1, char);
3344 d += e - orig_s + 1;
3346 else { /* Not a pattern: convert the hex to string */
3347 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3348 | PERL_SCAN_SILENT_ILLDIGIT
3349 | PERL_SCAN_DISALLOW_PREFIX;
3351 uv = grok_hex(s, &len, &flags, NULL);
3352 if (len == 0 || (len != (STRLEN)(e - s)))
3355 /* If the destination is not in utf8, unconditionally
3356 * recode it to be so. This is because \N{} implies
3357 * Unicode semantics, and scalars have to be in utf8
3358 * to guarantee those semantics */
3360 SvCUR_set(sv, d - SvPVX_const(sv));
3363 /* See Note on sizing above. */
3364 sv_utf8_upgrade_flags_grow(
3366 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3367 UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
3368 d = SvPVX(sv) + SvCUR(sv);
3372 /* Add the (Unicode) code point to the output. */
3373 if (UNI_IS_INVARIANT(uv)) {
3374 *d++ = (char) LATIN1_TO_NATIVE(uv);
3377 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3381 else /* Here is \N{NAME} but not \N{U+...}. */
3382 if ((res = get_and_check_backslash_N_name(s, e)))
3385 const char *str = SvPV_const(res, len);
3388 if (! len) { /* The name resolved to an empty string */
3389 Copy("\\N{}", d, 4, char);
3393 /* In order to not lose information for the regex
3394 * compiler, pass the result in the specially made
3395 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3396 * the code points in hex of each character
3397 * returned by charnames */
3399 const char *str_end = str + len;
3400 const STRLEN off = d - SvPVX_const(sv);
3402 if (! SvUTF8(res)) {
3403 /* For the non-UTF-8 case, we can determine the
3404 * exact length needed without having to parse
3405 * through the string. Each character takes up
3406 * 2 hex digits plus either a trailing dot or
3408 const char initial_text[] = "\\N{U+";
3409 const STRLEN initial_len = sizeof(initial_text)
3411 d = off + SvGROW(sv, off
3414 /* +1 for trailing NUL */
3417 + (STRLEN)(send - e));
3418 Copy(initial_text, d, initial_len, char);
3420 while (str < str_end) {
3423 my_snprintf(hex_string,
3427 /* The regex compiler is
3428 * expecting Unicode, not
3430 (U8) NATIVE_TO_LATIN1(*str));
3431 PERL_MY_SNPRINTF_POST_GUARD(len,
3432 sizeof(hex_string));
3433 Copy(hex_string, d, 3, char);
3437 d--; /* Below, we will overwrite the final
3438 dot with a right brace */
3441 STRLEN char_length; /* cur char's byte length */
3443 /* and the number of bytes after this is
3444 * translated into hex digits */
3445 STRLEN output_length;
3447 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3448 * for max('U+', '.'); and 1 for NUL */
3449 char hex_string[2 * UTF8_MAXBYTES + 5];
3451 /* Get the first character of the result. */
3452 U32 uv = utf8n_to_uvchr((U8 *) str,
3456 /* Convert first code point to Unicode hex,
3457 * including the boiler plate before it. */
3459 my_snprintf(hex_string, sizeof(hex_string),
3461 (unsigned int) NATIVE_TO_UNI(uv));
3463 /* Make sure there is enough space to hold it */
3464 d = off + SvGROW(sv, off
3466 + (STRLEN)(send - e)
3467 + 2); /* '}' + NUL */
3469 Copy(hex_string, d, output_length, char);
3472 /* For each subsequent character, append dot and
3473 * its Unicode code point in hex */
3474 while ((str += char_length) < str_end) {
3475 const STRLEN off = d - SvPVX_const(sv);
3476 U32 uv = utf8n_to_uvchr((U8 *) str,
3481 my_snprintf(hex_string,
3484 (unsigned int) NATIVE_TO_UNI(uv));
3486 d = off + SvGROW(sv, off
3488 + (STRLEN)(send - e)
3489 + 2); /* '}' + NUL */
3490 Copy(hex_string, d, output_length, char);
3495 *d++ = '}'; /* Done. Add the trailing brace */
3498 else { /* Here, not in a pattern. Convert the name to a
3501 /* If destination is not in utf8, unconditionally
3502 * recode it to be so. This is because \N{} implies
3503 * Unicode semantics, and scalars have to be in utf8
3504 * to guarantee those semantics */
3506 SvCUR_set(sv, d - SvPVX_const(sv));
3509 /* See Note on sizing above. */
3510 sv_utf8_upgrade_flags_grow(sv,
3511 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3512 len + (STRLEN)(send - s) + 1);
3513 d = SvPVX(sv) + SvCUR(sv);
3515 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3517 /* See Note on sizing above. (NOTE: SvCUR() is not
3518 * set correctly here). */
3519 const STRLEN off = d - SvPVX_const(sv);
3520 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3522 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3523 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3524 str = SvPV_const(res, len);
3526 Copy(str, d, len, char);
3532 } /* End \N{NAME} */
3535 native_range = FALSE; /* \N{} is defined to be Unicode */
3537 s = e + 1; /* Point to just after the '}' */
3540 /* \c is a control character */
3544 *d++ = grok_bslash_c(*s++, 1);
3547 yyerror("Missing control char name in \\c");
3551 /* printf-style backslashes, formfeeds, newlines, etc */
3577 } /* end if (backslash) */
3584 /* If we started with encoded form, or already know we want it,
3585 then encode the next character */
3586 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3590 /* One might think that it is wasted effort in the case of the
3591 * source being utf8 (this_utf8 == TRUE) to take the next character
3592 * in the source, convert it to an unsigned value, and then convert
3593 * it back again. But the source has not been validated here. The
3594 * routine that does the conversion checks for errors like
3597 const UV nextuv = (this_utf8)
3598 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3600 const STRLEN need = UVCHR_SKIP(nextuv);
3602 SvCUR_set(sv, d - SvPVX_const(sv));
3605 /* See Note on sizing above. */
3606 sv_utf8_upgrade_flags_grow(sv,
3607 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3608 need + (STRLEN)(send - s) + 1);
3609 d = SvPVX(sv) + SvCUR(sv);
3611 } else if (need > len) {
3612 /* encoded value larger than old, may need extra space (NOTE:
3613 * SvCUR() is not set correctly here). See Note on sizing
3615 const STRLEN off = d - SvPVX_const(sv);
3616 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3620 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3622 if (uv > 255 && !dorange)
3623 native_range = FALSE;
3629 } /* while loop to process each character */
3631 /* terminate the string and set up the sv */
3633 SvCUR_set(sv, d - SvPVX_const(sv));
3634 if (SvCUR(sv) >= SvLEN(sv))
3635 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3636 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3639 if (IN_ENCODING && !has_utf8) {
3640 sv_recode_to_utf8(sv, _get_encoding());
3646 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3647 PL_sublex_info.sub_op->op_private |=
3648 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3652 /* shrink the sv if we allocated more than we used */
3653 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3654 SvPV_shrink_to_cur(sv);
3657 /* return the substring (via pl_yylval) only if we parsed anything */
3660 for (; s2 < s; s2++) {
3662 COPLINE_INC_WITH_HERELINES;
3664 SvREFCNT_inc_simple_void_NN(sv);
3665 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3666 && ! PL_parser->lex_re_reparsing)
3668 const char *const key = PL_lex_inpat ? "qr" : "q";
3669 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3673 if (PL_lex_inwhat == OP_TRANS) {
3676 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3679 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3687 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3690 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3692 LEAVE_with_name("scan_const");
3697 * Returns TRUE if there's more to the expression (e.g., a subscript),
3700 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3702 * ->[ and ->{ return TRUE
3703 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3704 * { and [ outside a pattern are always subscripts, so return TRUE
3705 * if we're outside a pattern and it's not { or [, then return FALSE
3706 * if we're in a pattern and the first char is a {
3707 * {4,5} (any digits around the comma) returns FALSE
3708 * if we're in a pattern and the first char is a [
3710 * [SOMETHING] has a funky algorithm to decide whether it's a
3711 * character class or not. It has to deal with things like
3712 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3713 * anything else returns TRUE
3716 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3719 S_intuit_more(pTHX_ char *s)
3721 PERL_ARGS_ASSERT_INTUIT_MORE;
3723 if (PL_lex_brackets)
3725 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3727 if (*s == '-' && s[1] == '>'
3728 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3729 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3730 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3732 if (*s != '{' && *s != '[')
3737 /* In a pattern, so maybe we have {n,m}. */
3745 /* On the other hand, maybe we have a character class */
3748 if (*s == ']' || *s == '^')
3751 /* this is terrifying, and it works */
3754 const char * const send = strchr(s,']');
3755 unsigned char un_char, last_un_char;
3756 char tmpbuf[sizeof PL_tokenbuf * 4];
3758 if (!send) /* has to be an expression */
3760 weight = 2; /* let's weigh the evidence */
3764 else if (isDIGIT(*s)) {
3766 if (isDIGIT(s[1]) && s[2] == ']')
3772 Zero(seen,256,char);
3774 for (; s < send; s++) {
3775 last_un_char = un_char;
3776 un_char = (unsigned char)*s;
3781 weight -= seen[un_char] * 10;
3782 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3784 char *tmp = PL_bufend;
3785 PL_bufend = (char*)send;
3786 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3788 len = (int)strlen(tmpbuf);
3789 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3790 UTF ? SVf_UTF8 : 0, SVt_PV))
3797 && strchr("[#!%*<>()-=",s[1]))
3799 if (/*{*/ strchr("])} =",s[2]))
3808 if (strchr("wds]",s[1]))
3810 else if (seen[(U8)'\''] || seen[(U8)'"'])
3812 else if (strchr("rnftbxcav",s[1]))
3814 else if (isDIGIT(s[1])) {
3816 while (s[1] && isDIGIT(s[1]))
3826 if (strchr("aA01! ",last_un_char))
3828 if (strchr("zZ79~",s[1]))
3830 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3831 weight -= 5; /* cope with negative subscript */
3834 if (!isWORDCHAR(last_un_char)
3835 && !(last_un_char == '$' || last_un_char == '@'
3836 || last_un_char == '&')
3837 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3841 if (keyword(d, s - d, 0))
3844 if (un_char == last_un_char + 1)
3846 weight -= seen[un_char];
3851 if (weight >= 0) /* probably a character class */
3861 * Does all the checking to disambiguate
3863 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3864 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3866 * First argument is the stuff after the first token, e.g. "bar".
3868 * Not a method if foo is a filehandle.
3869 * Not a method if foo is a subroutine prototyped to take a filehandle.
3870 * Not a method if it's really "Foo $bar"
3871 * Method if it's "foo $bar"
3872 * Not a method if it's really "print foo $bar"
3873 * Method if it's really "foo package::" (interpreted as package->foo)
3874 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3875 * Not a method if bar is a filehandle or package, but is quoted with
3880 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3882 char *s = start + (*start == '$');
3883 char tmpbuf[sizeof PL_tokenbuf];
3886 /* Mustn't actually add anything to a symbol table.
3887 But also don't want to "initialise" any placeholder
3888 constants that might already be there into full
3889 blown PVGVs with attached PVCV. */
3891 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3893 PERL_ARGS_ASSERT_INTUIT_METHOD;
3895 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3897 if (cv && SvPOK(cv)) {
3898 const char *proto = CvPROTO(cv);
3900 while (*proto && (isSPACE(*proto) || *proto == ';'))
3907 if (*start == '$') {
3908 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
3909 || isUPPER(*PL_tokenbuf))
3914 return *s == '(' ? FUNCMETH : METHOD;
3917 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3918 /* start is the beginning of the possible filehandle/object,
3919 * and s is the end of it
3920 * tmpbuf is a copy of it (but with single quotes as double colons)
3923 if (!keyword(tmpbuf, len, 0)) {
3924 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3929 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3930 if (indirgv && GvCVu(indirgv))
3932 /* filehandle or package name makes it a method */
3933 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3935 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3936 return 0; /* no assumptions -- "=>" quotes bareword */
3938 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3939 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3940 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3944 return *s == '(' ? FUNCMETH : METHOD;
3950 /* Encoded script support. filter_add() effectively inserts a
3951 * 'pre-processing' function into the current source input stream.
3952 * Note that the filter function only applies to the current source file
3953 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3955 * The datasv parameter (which may be NULL) can be used to pass
3956 * private data to this instance of the filter. The filter function
3957 * can recover the SV using the FILTER_DATA macro and use it to
3958 * store private buffers and state information.
3960 * The supplied datasv parameter is upgraded to a PVIO type
3961 * and the IoDIRP/IoANY field is used to store the function pointer,
3962 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3963 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3964 * private use must be set using malloc'd pointers.
3968 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3976 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3977 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3979 if (!PL_rsfp_filters)
3980 PL_rsfp_filters = newAV();
3983 SvUPGRADE(datasv, SVt_PVIO);
3984 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3985 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3986 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3987 FPTR2DPTR(void *, IoANY(datasv)),
3988 SvPV_nolen(datasv)));
3989 av_unshift(PL_rsfp_filters, 1);
3990 av_store(PL_rsfp_filters, 0, datasv) ;
3992 !PL_parser->filtered
3993 && PL_parser->lex_flags & LEX_EVALBYTES
3994 && PL_bufptr < PL_bufend
3996 const char *s = PL_bufptr;
3997 while (s < PL_bufend) {
3999 SV *linestr = PL_parser->linestr;
4000 char *buf = SvPVX(linestr);
4001 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4002 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4003 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4004 STRLEN const linestart_pos = PL_parser->linestart - buf;
4005 STRLEN const last_uni_pos =
4006 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4007 STRLEN const last_lop_pos =
4008 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4009 av_push(PL_rsfp_filters, linestr);
4010 PL_parser->linestr =
4011 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4012 buf = SvPVX(PL_parser->linestr);
4013 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4014 PL_parser->bufptr = buf + bufptr_pos;
4015 PL_parser->oldbufptr = buf + oldbufptr_pos;
4016 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4017 PL_parser->linestart = buf + linestart_pos;
4018 if (PL_parser->last_uni)
4019 PL_parser->last_uni = buf + last_uni_pos;
4020 if (PL_parser->last_lop)
4021 PL_parser->last_lop = buf + last_lop_pos;
4022 SvLEN(linestr) = SvCUR(linestr);
4023 SvCUR(linestr) = s-SvPVX(linestr);
4024 PL_parser->filtered = 1;
4034 /* Delete most recently added instance of this filter function. */
4036 Perl_filter_del(pTHX_ filter_t funcp)
4040 PERL_ARGS_ASSERT_FILTER_DEL;
4043 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4044 FPTR2DPTR(void*, funcp)));
4046 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4048 /* if filter is on top of stack (usual case) just pop it off */
4049 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4050 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4051 sv_free(av_pop(PL_rsfp_filters));
4055 /* we need to search for the correct entry and clear it */
4056 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4060 /* Invoke the idxth filter function for the current rsfp. */
4061 /* maxlen 0 = read one text line */
4063 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4067 /* This API is bad. It should have been using unsigned int for maxlen.
4068 Not sure if we want to change the API, but if not we should sanity
4069 check the value here. */
4070 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4072 PERL_ARGS_ASSERT_FILTER_READ;
4074 if (!PL_parser || !PL_rsfp_filters)
4076 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4077 /* Provide a default input filter to make life easy. */
4078 /* Note that we append to the line. This is handy. */
4079 DEBUG_P(PerlIO_printf(Perl_debug_log,
4080 "filter_read %d: from rsfp\n", idx));
4081 if (correct_length) {
4084 const int old_len = SvCUR(buf_sv);
4086 /* ensure buf_sv is large enough */
4087 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4088 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4089 correct_length)) <= 0) {
4090 if (PerlIO_error(PL_rsfp))
4091 return -1; /* error */
4093 return 0 ; /* end of file */
4095 SvCUR_set(buf_sv, old_len + len) ;
4096 SvPVX(buf_sv)[old_len + len] = '\0';
4099 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4100 if (PerlIO_error(PL_rsfp))
4101 return -1; /* error */
4103 return 0 ; /* end of file */
4106 return SvCUR(buf_sv);
4108 /* Skip this filter slot if filter has been deleted */
4109 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4110 DEBUG_P(PerlIO_printf(Perl_debug_log,
4111 "filter_read %d: skipped (filter deleted)\n",
4113 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4115 if (SvTYPE(datasv) != SVt_PVIO) {
4116 if (correct_length) {
4118 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4119 if (!remainder) return 0; /* eof */
4120 if (correct_length > remainder) correct_length = remainder;
4121 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4122 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4125 const char *s = SvEND(datasv);
4126 const char *send = SvPVX(datasv) + SvLEN(datasv);
4134 if (s == send) return 0; /* eof */
4135 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4136 SvCUR_set(datasv, s-SvPVX(datasv));
4138 return SvCUR(buf_sv);
4140 /* Get function pointer hidden within datasv */
4141 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4142 DEBUG_P(PerlIO_printf(Perl_debug_log,
4143 "filter_read %d: via function %p (%s)\n",
4144 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4145 /* Call function. The function is expected to */
4146 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4147 /* Return: <0:error, =0:eof, >0:not eof */
4148 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4152 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4154 PERL_ARGS_ASSERT_FILTER_GETS;
4156 #ifdef PERL_CR_FILTER
4157 if (!PL_rsfp_filters) {
4158 filter_add(S_cr_textfilter,NULL);
4161 if (PL_rsfp_filters) {
4163 SvCUR_set(sv, 0); /* start with empty line */
4164 if (FILTER_READ(0, sv, 0) > 0)
4165 return ( SvPVX(sv) ) ;
4170 return (sv_gets(sv, PL_rsfp, append));
4174 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4178 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4180 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4184 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4185 && (gv = gv_fetchpvn_flags(pkgname,
4187 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4189 return GvHV(gv); /* Foo:: */
4192 /* use constant CLASS => 'MyClass' */
4193 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4194 if (gv && GvCV(gv)) {
4195 SV * const sv = cv_const_sv(GvCV(gv));
4197 return gv_stashsv(sv, 0);
4200 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4205 S_tokenize_use(pTHX_ int is_use, char *s) {
4206 PERL_ARGS_ASSERT_TOKENIZE_USE;
4208 if (PL_expect != XSTATE)
4209 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4210 is_use ? "use" : "no"));
4213 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4214 s = force_version(s, TRUE);
4215 if (*s == ';' || *s == '}'
4216 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4217 NEXTVAL_NEXTTOKE.opval = NULL;
4220 else if (*s == 'v') {
4221 s = force_word(s,WORD,FALSE,TRUE);
4222 s = force_version(s, FALSE);
4226 s = force_word(s,WORD,FALSE,TRUE);
4227 s = force_version(s, FALSE);
4229 pl_yylval.ival = is_use;
4233 static const char* const exp_name[] =
4234 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4235 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4240 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4242 S_word_takes_any_delimeter(char *p, STRLEN len)
4244 return (len == 1 && strchr("msyq", p[0]))
4246 && ((p[0] == 't' && p[1] == 'r')
4247 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4251 S_check_scalar_slice(pTHX_ char *s)
4254 while (*s == ' ' || *s == '\t') s++;
4255 if (*s == 'q' && s[1] == 'w'
4256 && !isWORDCHAR_lazy_if(s+2,UTF))
4258 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4259 s += UTF ? UTF8SKIP(s) : 1;
4260 if (*s == '}' || *s == ']')
4261 pl_yylval.ival = OPpSLICEWARNING;
4267 Works out what to call the token just pulled out of the input
4268 stream. The yacc parser takes care of taking the ops we return and
4269 stitching them into a tree.
4272 The type of the next token
4275 Switch based on the current state:
4276 - if we already built the token before, use it
4277 - if we have a case modifier in a string, deal with that
4278 - handle other cases of interpolation inside a string
4279 - scan the next line if we are inside a format
4280 In the normal state switch on the next character:
4282 if alphabetic, go to key lookup
4283 unrecoginized character - croak
4284 - 0/4/26: handle end-of-line or EOF
4285 - cases for whitespace
4286 - \n and #: handle comments and line numbers
4287 - various operators, brackets and sigils
4290 - 'v': vstrings (or go to key lookup)
4291 - 'x' repetition operator (or go to key lookup)
4292 - other ASCII alphanumerics (key lookup begins here):
4295 scan built-in keyword (but do nothing with it yet)
4296 check for statement label
4297 check for lexical subs
4298 goto just_a_word if there is one
4299 see whether built-in keyword is overridden
4300 switch on keyword number:
4301 - default: just_a_word:
4302 not a built-in keyword; handle bareword lookup
4303 disambiguate between method and sub call
4304 fall back to bareword
4305 - cases for built-in keywords
4313 char *s = PL_bufptr;
4317 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4321 /* orig_keyword, gvp, and gv are initialized here because
4322 * jump to the label just_a_word_zero can bypass their
4323 * initialization later. */
4324 I32 orig_keyword = 0;
4329 SV* tmp = newSVpvs("");
4330 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4331 (IV)CopLINE(PL_curcop),
4332 lex_state_names[PL_lex_state],
4333 exp_name[PL_expect],
4334 pv_display(tmp, s, strlen(s), 0, 60));
4338 /* when we've already built the next token, just pull it out of the queue */
4341 pl_yylval = PL_nextval[PL_nexttoke];
4343 PL_lex_state = PL_lex_defer;
4344 PL_lex_defer = LEX_NORMAL;
4348 next_type = PL_nexttype[PL_nexttoke];
4349 if (next_type & (7<<24)) {
4350 if (next_type & (1<<24)) {
4351 if (PL_lex_brackets > 100)
4352 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4353 PL_lex_brackstack[PL_lex_brackets++] =
4354 (char) ((next_type >> 16) & 0xff);
4356 if (next_type & (2<<24))
4357 PL_lex_allbrackets++;
4358 if (next_type & (4<<24))
4359 PL_lex_allbrackets--;
4360 next_type &= 0xffff;
4362 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4366 switch (PL_lex_state) {
4368 case LEX_INTERPNORMAL:
4371 /* interpolated case modifiers like \L \U, including \Q and \E.
4372 when we get here, PL_bufptr is at the \
4374 case LEX_INTERPCASEMOD:
4376 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4378 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4379 PL_bufptr, PL_bufend, *PL_bufptr);
4381 /* handle \E or end of string */
4382 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4384 if (PL_lex_casemods) {
4385 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4386 PL_lex_casestack[PL_lex_casemods] = '\0';
4388 if (PL_bufptr != PL_bufend
4389 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4390 || oldmod == 'F')) {
4392 PL_lex_state = LEX_INTERPCONCAT;
4394 PL_lex_allbrackets--;
4397 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4398 /* Got an unpaired \E */
4399 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4400 "Useless use of \\E");
4402 if (PL_bufptr != PL_bufend)
4404 PL_lex_state = LEX_INTERPCONCAT;
4408 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4409 "### Saw case modifier\n"); });
4411 if (s[1] == '\\' && s[2] == 'E') {
4413 PL_lex_state = LEX_INTERPCONCAT;
4418 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4419 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4420 if ((*s == 'L' || *s == 'U' || *s == 'F')
4421 && (strchr(PL_lex_casestack, 'L')
4422 || strchr(PL_lex_casestack, 'U')
4423 || strchr(PL_lex_casestack, 'F')))
4425 PL_lex_casestack[--PL_lex_casemods] = '\0';
4426 PL_lex_allbrackets--;
4429 if (PL_lex_casemods > 10)
4430 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4431 PL_lex_casestack[PL_lex_casemods++] = *s;
4432 PL_lex_casestack[PL_lex_casemods] = '\0';
4433 PL_lex_state = LEX_INTERPCONCAT;
4434 NEXTVAL_NEXTTOKE.ival = 0;
4435 force_next((2<<24)|'(');
4437 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4439 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4441 NEXTVAL_NEXTTOKE.ival = OP_LC;
4443 NEXTVAL_NEXTTOKE.ival = OP_UC;
4445 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4447 NEXTVAL_NEXTTOKE.ival = OP_FC;
4449 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4453 if (PL_lex_starts) {
4456 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4457 if (PL_lex_casemods == 1 && PL_lex_inpat)
4460 AopNOASSIGN(OP_CONCAT);
4466 case LEX_INTERPPUSH:
4467 return REPORT(sublex_push());
4469 case LEX_INTERPSTART:
4470 if (PL_bufptr == PL_bufend)
4471 return REPORT(sublex_done());
4472 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4473 "### Interpolated variable\n"); });
4475 /* for /@a/, we leave the joining for the regex engine to do
4476 * (unless we're within \Q etc) */
4477 PL_lex_dojoin = (*PL_bufptr == '@'
4478 && (!PL_lex_inpat || PL_lex_casemods));
4479 PL_lex_state = LEX_INTERPNORMAL;
4480 if (PL_lex_dojoin) {
4481 NEXTVAL_NEXTTOKE.ival = 0;
4483 force_ident("\"", '$');
4484 NEXTVAL_NEXTTOKE.ival = 0;
4486 NEXTVAL_NEXTTOKE.ival = 0;
4487 force_next((2<<24)|'(');
4488 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4491 /* Convert (?{...}) and friends to 'do {...}' */
4492 if (PL_lex_inpat && *PL_bufptr == '(') {
4493 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4495 if (*PL_bufptr != '{')
4497 PL_expect = XTERMBLOCK;
4501 if (PL_lex_starts++) {
4503 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4504 if (!PL_lex_casemods && PL_lex_inpat)
4507 AopNOASSIGN(OP_CONCAT);
4511 case LEX_INTERPENDMAYBE:
4512 if (intuit_more(PL_bufptr)) {
4513 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4519 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4520 XXX This hack can be removed if we stop setting PL_lex_state to
4521 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4522 if (UNLIKELY(!PL_lex_inwhat)) {
4523 PL_lex_state = LEX_NORMAL;
4527 if (PL_lex_dojoin) {
4528 const U8 dojoin_was = PL_lex_dojoin;
4529 PL_lex_dojoin = FALSE;
4530 PL_lex_state = LEX_INTERPCONCAT;
4531 PL_lex_allbrackets--;
4532 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4534 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4535 && SvEVALED(PL_lex_repl))
4537 if (PL_bufptr != PL_bufend)
4538 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4541 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4542 re_eval_str. If the here-doc body’s length equals the previous
4543 value of re_eval_start, re_eval_start will now be null. So
4544 check re_eval_str as well. */
4545 if (PL_parser->lex_shared->re_eval_start
4546 || PL_parser->lex_shared->re_eval_str) {
4548 if (*PL_bufptr != ')')
4549 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4551 /* having compiled a (?{..}) expression, return the original
4552 * text too, as a const */
4553 if (PL_parser->lex_shared->re_eval_str) {
4554 sv = PL_parser->lex_shared->re_eval_str;
4555 PL_parser->lex_shared->re_eval_str = NULL;
4557 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4558 SvPV_shrink_to_cur(sv);
4560 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4561 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4562 NEXTVAL_NEXTTOKE.opval =
4563 (OP*)newSVOP(OP_CONST, 0,
4566 PL_parser->lex_shared->re_eval_start = NULL;
4572 case LEX_INTERPCONCAT:
4574 if (PL_lex_brackets)
4575 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4576 (long) PL_lex_brackets);
4578 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4579 XXX This hack can be removed if we stop setting PL_lex_state to
4581 if (UNLIKELY(!PL_lex_inwhat)) {
4582 PL_lex_state = LEX_NORMAL;
4586 if (PL_bufptr == PL_bufend)
4587 return REPORT(sublex_done());
4589 /* m'foo' still needs to be parsed for possible (?{...}) */
4590 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4591 SV *sv = newSVsv(PL_linestr);
4593 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4597 s = scan_const(PL_bufptr);
4599 PL_lex_state = LEX_INTERPCASEMOD;
4601 PL_lex_state = LEX_INTERPSTART;
4604 if (s != PL_bufptr) {
4605 NEXTVAL_NEXTTOKE = pl_yylval;
4608 if (PL_lex_starts++) {
4609 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4610 if (!PL_lex_casemods && PL_lex_inpat)
4613 AopNOASSIGN(OP_CONCAT);
4623 s = scan_formline(PL_bufptr);
4624 if (!PL_lex_formbrack)
4633 /* We really do *not* want PL_linestr ever becoming a COW. */
4634 assert (!SvIsCOW(PL_linestr));
4636 PL_oldoldbufptr = PL_oldbufptr;
4638 PL_parser->saw_infix_sigil = 0;
4643 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4646 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4647 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4649 SVs_TEMP | SVf_UTF8),
4650 10, UNI_DISPLAY_ISPRINT)
4651 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4652 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4653 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4654 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4658 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4659 UTF8fARG(UTF, (s - d), d),
4664 goto fake_eof; /* emulate EOF on ^D or ^Z */
4666 if ((!PL_rsfp || PL_lex_inwhat)
4667 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4671 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
4673 yyerror((const char *)
4675 ? "Format not terminated"
4676 : "Missing right curly or square bracket"));
4678 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4679 "### Tokener got EOF\n");
4683 if (s++ < PL_bufend)
4684 goto retry; /* ignore stray nulls */
4687 if (!PL_in_eval && !PL_preambled) {
4688 PL_preambled = TRUE;
4690 /* Generate a string of Perl code to load the debugger.
4691 * If PERL5DB is set, it will return the contents of that,
4692 * otherwise a compile-time require of perl5db.pl. */
4694 const char * const pdb = PerlEnv_getenv("PERL5DB");
4697 sv_setpv(PL_linestr, pdb);
4698 sv_catpvs(PL_linestr,";");
4700 SETERRNO(0,SS_NORMAL);
4701 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4703 PL_parser->preambling = CopLINE(PL_curcop);
4705 sv_setpvs(PL_linestr,"");
4706 if (PL_preambleav) {
4707 SV **svp = AvARRAY(PL_preambleav);
4708 SV **const end = svp + AvFILLp(PL_preambleav);
4710 sv_catsv(PL_linestr, *svp);
4712 sv_catpvs(PL_linestr, ";");
4714 sv_free(MUTABLE_SV(PL_preambleav));
4715 PL_preambleav = NULL;
4718 sv_catpvs(PL_linestr,
4719 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4720 if (PL_minus_n || PL_minus_p) {
4721 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4723 sv_catpvs(PL_linestr,"chomp;");
4726 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4727 || *PL_splitstr == '"')
4728 && strchr(PL_splitstr + 1, *PL_splitstr))
4729 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4731 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4732 bytes can be used as quoting characters. :-) */
4733 const char *splits = PL_splitstr;
4734 sv_catpvs(PL_linestr, "our @F=split(q\0");
4737 if (*splits == '\\')
4738 sv_catpvn(PL_linestr, splits, 1);
4739 sv_catpvn(PL_linestr, splits, 1);
4740 } while (*splits++);
4741 /* This loop will embed the trailing NUL of
4742 PL_linestr as the last thing it does before
4744 sv_catpvs(PL_linestr, ");");
4748 sv_catpvs(PL_linestr,"our @F=split(' ');");
4751 sv_catpvs(PL_linestr, "\n");
4752 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4753 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4754 PL_last_lop = PL_last_uni = NULL;
4755 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4756 update_debugger_info(PL_linestr, NULL, 0);
4761 bof = PL_rsfp ? TRUE : FALSE;
4764 fake_eof = LEX_FAKE_EOF;
4766 PL_bufptr = PL_bufend;
4767 COPLINE_INC_WITH_HERELINES;
4768 if (!lex_next_chunk(fake_eof)) {
4769 CopLINE_dec(PL_curcop);
4771 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4773 CopLINE_dec(PL_curcop);
4775 /* If it looks like the start of a BOM or raw UTF-16,
4776 * check if it in fact is. */
4779 || *(U8*)s == BOM_UTF8_FIRST_BYTE
4783 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4784 bof = (offset == (Off_t)SvCUR(PL_linestr));
4785 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4786 /* offset may include swallowed CR */
4788 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4791 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4792 s = swallow_bom((U8*)s);
4795 if (PL_parser->in_pod) {
4796 /* Incest with pod. */
4797 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4798 sv_setpvs(PL_linestr, "");
4799 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4800 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4801 PL_last_lop = PL_last_uni = NULL;
4802 PL_parser->in_pod = 0;
4805 if (PL_rsfp || PL_parser->filtered)
4807 } while (PL_parser->in_pod);
4808 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4809 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4810 PL_last_lop = PL_last_uni = NULL;
4811 if (CopLINE(PL_curcop) == 1) {
4812 while (s < PL_bufend && isSPACE(*s))
4814 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4818 if (*s == '#' && *(s+1) == '!')
4820 #ifdef ALTERNATE_SHEBANG
4822 static char const as[] = ALTERNATE_SHEBANG;
4823 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4824 d = s + (sizeof(as) - 1);
4826 #endif /* ALTERNATE_SHEBANG */
4835 while (*d && !isSPACE(*d))
4839 #ifdef ARG_ZERO_IS_SCRIPT
4840 if (ipathend > ipath) {
4842 * HP-UX (at least) sets argv[0] to the script name,
4843 * which makes $^X incorrect. And Digital UNIX and Linux,
4844 * at least, set argv[0] to the basename of the Perl
4845 * interpreter. So, having found "#!", we'll set it right.
4847 SV* copfilesv = CopFILESV(PL_curcop);
4850 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4852 assert(SvPOK(x) || SvGMAGICAL(x));
4853 if (sv_eq(x, copfilesv)) {
4854 sv_setpvn(x, ipath, ipathend - ipath);
4860 const char *bstart = SvPV_const(copfilesv, blen);
4861 const char * const lstart = SvPV_const(x, llen);
4863 bstart += blen - llen;
4864 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4865 sv_setpvn(x, ipath, ipathend - ipath);
4872 /* Anything to do if no copfilesv? */
4874 TAINT_NOT; /* $^X is always tainted, but that's OK */
4876 #endif /* ARG_ZERO_IS_SCRIPT */
4881 d = instr(s,"perl -");
4883 d = instr(s,"perl");
4884 if (d && d[4] == '6')
4887 /* avoid getting into infinite loops when shebang
4888 * line contains "Perl" rather than "perl" */
4890 for (d = ipathend-4; d >= ipath; --d) {
4891 if (isALPHA_FOLD_EQ(*d, 'p')
4892 && !ibcmp(d, "perl", 4))
4902 #ifdef ALTERNATE_SHEBANG
4904 * If the ALTERNATE_SHEBANG on this system starts with a
4905 * character that can be part of a Perl expression, then if
4906 * we see it but not "perl", we're probably looking at the
4907 * start of Perl code, not a request to hand off to some
4908 * other interpreter. Similarly, if "perl" is there, but
4909 * not in the first 'word' of the line, we assume the line
4910 * contains the start of the Perl program.
4912 if (d && *s != '#') {
4913 const char *c = ipath;
4914 while (*c && !strchr("; \t\r\n\f\v#", *c))
4917 d = NULL; /* "perl" not in first word; ignore */
4919 *s = '#'; /* Don't try to parse shebang line */
4921 #endif /* ALTERNATE_SHEBANG */
4926 && !instr(s,"indir")
4927 && instr(PL_origargv[0],"perl"))
4934 while (s < PL_bufend && isSPACE(*s))
4936 if (s < PL_bufend) {
4937 Newx(newargv,PL_origargc+3,char*);
4939 while (s < PL_bufend && !isSPACE(*s))
4942 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4945 newargv = PL_origargv;
4948 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4950 Perl_croak(aTHX_ "Can't exec %s", ipath);
4953 while (*d && !isSPACE(*d))
4955 while (SPACE_OR_TAB(*d))
4959 const bool switches_done = PL_doswitches;
4960 const U32 oldpdb = PL_perldb;
4961 const bool oldn = PL_minus_n;
4962 const bool oldp = PL_minus_p;
4966 bool baduni = FALSE;
4968 const char *d2 = d1 + 1;
4969 if (parse_unicode_opts((const char **)&d2)
4973 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4974 const char * const m = d1;
4975 while (*d1 && !isSPACE(*d1))
4977 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4980 d1 = moreswitches(d1);
4982 if (PL_doswitches && !switches_done) {
4983 int argc = PL_origargc;
4984 char **argv = PL_origargv;
4987 } while (argc && argv[0][0] == '-' && argv[0][1]);
4988 init_argv_symbols(argc,argv);
4990 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
4991 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4992 /* if we have already added "LINE: while (<>) {",
4993 we must not do it again */
4995 sv_setpvs(PL_linestr, "");
4996 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4997 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4998 PL_last_lop = PL_last_uni = NULL;
4999 PL_preambled = FALSE;
5000 if (PERLDB_LINE_OR_SAVESRC)
5001 (void)gv_fetchfile(PL_origfilename);
5008 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5009 PL_lex_state = LEX_FORMLINE;
5010 force_next(FORMRBRACK);
5015 #ifdef PERL_STRICT_CR
5016 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5018 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5020 case ' ': case '\t': case '\f': case '\v':
5025 if (PL_lex_state != LEX_NORMAL
5026 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5028 const bool in_comment = *s == '#';
5029 if (*s == '#' && s == PL_linestart && PL_in_eval
5030 && !PL_rsfp && !PL_parser->filtered) {
5031 /* handle eval qq[#line 1 "foo"\n ...] */
5032 CopLINE_dec(PL_curcop);
5036 while (d < PL_bufend && *d != '\n')
5040 else if (d > PL_bufend)
5041 /* Found by Ilya: feed random input to Perl. */
5042 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5045 if (in_comment && d == PL_bufend
5046 && PL_lex_state == LEX_INTERPNORMAL
5047 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5048 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5051 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5052 PL_lex_state = LEX_FORMLINE;
5053 force_next(FORMRBRACK);
5058 while (s < PL_bufend && *s != '\n')
5066 else if (s > PL_bufend)
5067 /* Found by Ilya: feed random input to Perl. */
5068 Perl_croak(aTHX_ "panic: input overflow");
5072 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5080 while (s < PL_bufend && SPACE_OR_TAB(*s))
5083 if (strnEQ(s,"=>",2)) {
5084 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5085 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5086 OPERATOR('-'); /* unary minus */
5089 case 'r': ftst = OP_FTEREAD; break;
5090 case 'w': ftst = OP_FTEWRITE; break;
5091 case 'x': ftst = OP_FTEEXEC; break;
5092 case 'o': ftst = OP_FTEOWNED; break;
5093 case 'R': ftst = OP_FTRREAD; break;
5094 case 'W': ftst = OP_FTRWRITE; break;
5095 case 'X': ftst = OP_FTREXEC; break;
5096 case 'O': ftst = OP_FTROWNED; break;
5097 case 'e': ftst = OP_FTIS; break;
5098 case 'z': ftst = OP_FTZERO; break;
5099 case 's': ftst = OP_FTSIZE; break;
5100 case 'f': ftst = OP_FTFILE; break;
5101 case 'd': ftst = OP_FTDIR; break;
5102 case 'l': ftst = OP_FTLINK; break;
5103 case 'p': ftst = OP_FTPIPE; break;
5104 case 'S': ftst = OP_FTSOCK; break;
5105 case 'u': ftst = OP_FTSUID; break;
5106 case 'g': ftst = OP_FTSGID; break;
5107 case 'k': ftst = OP_FTSVTX; break;
5108 case 'b': ftst = OP_FTBLK; break;
5109 case 'c': ftst = OP_FTCHR; break;
5110 case 't': ftst = OP_FTTTY; break;
5111 case 'T': ftst = OP_FTTEXT; break;
5112 case 'B': ftst = OP_FTBINARY; break;
5113 case 'M': case 'A': case 'C':
5114 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5116 case 'M': ftst = OP_FTMTIME; break;
5117 case 'A': ftst = OP_FTATIME; break;
5118 case 'C': ftst = OP_FTCTIME; break;
5126 PL_last_uni = PL_oldbufptr;
5127 PL_last_lop_op = (OPCODE)ftst;
5128 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5129 "### Saw file test %c\n", (int)tmp);
5134 /* Assume it was a minus followed by a one-letter named
5135 * subroutine call (or a -bareword), then. */
5136 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5137 "### '-%c' looked like a file test but was not\n",
5144 const char tmp = *s++;
5147 if (PL_expect == XOPERATOR)
5152 else if (*s == '>') {
5155 if (((*s == '$' || *s == '&') && s[1] == '*')
5156 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5157 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5158 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5161 PL_expect = XPOSTDEREF;
5164 if (isIDFIRST_lazy_if(s,UTF)) {
5165 s = force_word(s,METHOD,FALSE,TRUE);
5173 if (PL_expect == XOPERATOR) {
5175 && !PL_lex_allbrackets
5176 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5184 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5186 OPERATOR('-'); /* unary minus */
5192 const char tmp = *s++;
5195 if (PL_expect == XOPERATOR)
5200 if (PL_expect == XOPERATOR) {
5202 && !PL_lex_allbrackets
5203 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5211 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5218 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5219 if (PL_expect != XOPERATOR) {
5220 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5221 PL_expect = XOPERATOR;
5222 force_ident(PL_tokenbuf, '*');
5230 if (*s == '=' && !PL_lex_allbrackets
5231 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5239 && !PL_lex_allbrackets
5240 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5245 PL_parser->saw_infix_sigil = 1;
5250 if (PL_expect == XOPERATOR) {
5252 && !PL_lex_allbrackets
5253 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5258 PL_parser->saw_infix_sigil = 1;
5261 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5262 PL_tokenbuf[0] = '%';
5263 s = scan_ident(s, PL_tokenbuf + 1,
5264 sizeof PL_tokenbuf - 1, FALSE);
5266 if (!PL_tokenbuf[1]) {
5269 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5271 PL_tokenbuf[0] = '@';
5273 PL_expect = XOPERATOR;
5274 force_ident_maybe_lex('%');
5279 bof = FEATURE_BITWISE_IS_ENABLED;
5280 if (bof && s[1] == '.')
5282 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5283 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5289 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5291 if (PL_lex_brackets > 100)
5292 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5293 PL_lex_brackstack[PL_lex_brackets++] = 0;
5294 PL_lex_allbrackets++;
5296 const char tmp = *s++;
5301 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5303 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5306 Perl_ck_warner_d(aTHX_
5307 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5308 "Smartmatch is experimental");
5312 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5314 BCop(OP_SCOMPLEMENT);
5316 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5318 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5325 goto just_a_word_zero_gv;
5331 switch (PL_expect) {
5333 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5335 PL_bufptr = s; /* update in case we back off */
5338 "Use of := for an empty attribute list is not allowed");
5345 PL_expect = XTERMBLOCK;
5349 while (isIDFIRST_lazy_if(s,UTF)) {
5352 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5353 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5354 if (tmp < 0) tmp = -tmp;
5369 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5371 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5372 COPLINE_SET_FROM_MULTI_END;
5374 /* MUST advance bufptr here to avoid bogus
5375 "at end of line" context messages from yyerror().
5377 PL_bufptr = s + len;
5378 yyerror("Unterminated attribute parameter in attribute list");
5382 return REPORT(0); /* EOF indicator */
5386 sv_catsv(sv, PL_lex_stuff);
5387 attrs = op_append_elem(OP_LIST, attrs,
5388 newSVOP(OP_CONST, 0, sv));
5389 SvREFCNT_dec_NN(PL_lex_stuff);
5390 PL_lex_stuff = NULL;
5393 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5395 if (PL_in_my == KEY_our) {
5396 deprecate(":unique");
5399 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5402 /* NOTE: any CV attrs applied here need to be part of
5403 the CVf_BUILTIN_ATTRS define in cv.h! */
5404 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5406 CvLVALUE_on(PL_compcv);
5408 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5410 deprecate(":locked");
5412 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5414 CvMETHOD_on(PL_compcv);
5416 else if (!PL_in_my && len == 5
5417 && strnEQ(SvPVX(sv), "const", len))
5420 Perl_ck_warner_d(aTHX_
5421 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5422 ":const is experimental"
5424 CvANONCONST_on(PL_compcv);
5425 if (!CvANON(PL_compcv))
5426 yyerror(":const is not permitted on named "
5429 /* After we've set the flags, it could be argued that
5430 we don't need to do the attributes.pm-based setting
5431 process, and shouldn't bother appending recognized
5432 flags. To experiment with that, uncomment the
5433 following "else". (Note that's already been
5434 uncommented. That keeps the above-applied built-in
5435 attributes from being intercepted (and possibly
5436 rejected) by a package's attribute routines, but is
5437 justified by the performance win for the common case
5438 of applying only built-in attributes.) */
5440 attrs = op_append_elem(OP_LIST, attrs,
5441 newSVOP(OP_CONST, 0,
5445 if (*s == ':' && s[1] != ':')
5448 break; /* require real whitespace or :'s */
5449 /* XXX losing whitespace on sequential attributes here */
5454 && !(PL_expect == XOPERATOR
5455 ? (*s == '=' || *s == ')')
5456 : (*s == '{' || *s == '(')))
5458 const char q = ((*s == '\'') ? '"' : '\'');
5459 /* If here for an expression, and parsed no attrs, back
5461 if (PL_expect == XOPERATOR && !attrs) {
5465 /* MUST advance bufptr here to avoid bogus "at end of line"
5466 context messages from yyerror().
5469 yyerror( (const char *)
5471 ? Perl_form(aTHX_ "Invalid separator character "
5472 "%c%c%c in attribute list", q, *s, q)
5473 : "Unterminated attribute list" ) );
5481 NEXTVAL_NEXTTOKE.opval = attrs;
5487 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5491 PL_lex_allbrackets--;
5495 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5496 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5500 PL_lex_allbrackets++;
5503 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5510 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5513 PL_lex_allbrackets--;
5519 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5522 if (PL_lex_brackets <= 0)
5523 /* diag_listed_as: Unmatched right %s bracket */
5524 yyerror("Unmatched right square bracket");
5527 PL_lex_allbrackets--;
5528 if (PL_lex_state == LEX_INTERPNORMAL) {
5529 if (PL_lex_brackets == 0) {
5530 if (*s == '-' && s[1] == '>')
5531 PL_lex_state = LEX_INTERPENDMAYBE;
5532 else if (*s != '[' && *s != '{')
5533 PL_lex_state = LEX_INTERPEND;
5540 if (PL_lex_brackets > 100) {
5541 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5543 switch (PL_expect) {
5546 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5547 PL_lex_allbrackets++;
5548 OPERATOR(HASHBRACK);
5550 while (s < PL_bufend && SPACE_OR_TAB(*s))
5553 PL_tokenbuf[0] = '\0';
5554 if (d < PL_bufend && *d == '-') {
5555 PL_tokenbuf[0] = '-';
5557 while (d < PL_bufend && SPACE_OR_TAB(*d))
5560 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5561 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5563 while (d < PL_bufend && SPACE_OR_TAB(*d))
5566 const char minus = (PL_tokenbuf[0] == '-');
5567 s = force_word(s + minus, WORD, FALSE, TRUE);
5575 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5576 PL_lex_allbrackets++;
5581 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5582 PL_lex_allbrackets++;
5586 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5587 PL_lex_allbrackets++;
5592 if (PL_oldoldbufptr == PL_last_lop)
5593 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5595 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5596 PL_lex_allbrackets++;
5599 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5601 /* This hack is to get the ${} in the message. */
5603 yyerror("syntax error");
5606 OPERATOR(HASHBRACK);
5608 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5609 /* ${...} or @{...} etc., but not print {...}
5610 * Skip the disambiguation and treat this as a block.
5612 goto block_expectation;
5614 /* This hack serves to disambiguate a pair of curlies
5615 * as being a block or an anon hash. Normally, expectation
5616 * determines that, but in cases where we're not in a
5617 * position to expect anything in particular (like inside
5618 * eval"") we have to resolve the ambiguity. This code
5619 * covers the case where the first term in the curlies is a
5620 * quoted string. Most other cases need to be explicitly
5621 * disambiguated by prepending a "+" before the opening
5622 * curly in order to force resolution as an anon hash.
5624 * XXX should probably propagate the outer expectation
5625 * into eval"" to rely less on this hack, but that could
5626 * potentially break current behavior of eval"".
5630 if (*s == '\'' || *s == '"' || *s == '`') {
5631 /* common case: get past first string, handling escapes */
5632 for (t++; t < PL_bufend && *t != *s;)
5637 else if (*s == 'q') {
5640 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5641 && !isWORDCHAR(*t))))
5643 /* skip q//-like construct */
5645 char open, close, term;
5648 while (t < PL_bufend && isSPACE(*t))
5650 /* check for q => */
5651 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5652 OPERATOR(HASHBRACK);
5656 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5660 for (t++; t < PL_bufend; t++) {
5661 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5663 else if (*t == open)
5667 for (t++; t < PL_bufend; t++) {
5668 if (*t == '\\' && t+1 < PL_bufend)
5670 else if (*t == close && --brackets <= 0)
5672 else if (*t == open)
5679 /* skip plain q word */
5680 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5683 else if (isWORDCHAR_lazy_if(t,UTF)) {
5685 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5688 while (t < PL_bufend && isSPACE(*t))
5690 /* if comma follows first term, call it an anon hash */
5691 /* XXX it could be a comma expression with loop modifiers */
5692 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5693 || (*t == '=' && t[1] == '>')))
5694 OPERATOR(HASHBRACK);
5695 if (PL_expect == XREF)
5698 /* If there is an opening brace or 'sub:', treat it
5699 as a term to make ${{...}}{k} and &{sub:attr...}
5700 dwim. Otherwise, treat it as a statement, so
5701 map {no strict; ...} works.
5708 if (strnEQ(s, "sub", 3)) {
5719 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5725 pl_yylval.ival = CopLINE(PL_curcop);
5726 PL_copline = NOLINE; /* invalidate current command line number */
5727 TOKEN(formbrack ? '=' : '{');
5729 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5733 if (PL_lex_brackets <= 0)
5734 /* diag_listed_as: Unmatched right %s bracket */
5735 yyerror("Unmatched right curly bracket");
5737 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5738 PL_lex_allbrackets--;
5739 if (PL_lex_state == LEX_INTERPNORMAL) {
5740 if (PL_lex_brackets == 0) {
5741 if (PL_expect & XFAKEBRACK) {
5742 PL_expect &= XENUMMASK;
5743 PL_lex_state = LEX_INTERPEND;
5745 return yylex(); /* ignore fake brackets */
5747 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5748 && SvEVALED(PL_lex_repl))
5749 PL_lex_state = LEX_INTERPEND;
5750 else if (*s == '-' && s[1] == '>')
5751 PL_lex_state = LEX_INTERPENDMAYBE;
5752 else if (*s != '[' && *s != '{')
5753 PL_lex_state = LEX_INTERPEND;
5756 if (PL_expect & XFAKEBRACK) {
5757 PL_expect &= XENUMMASK;
5759 return yylex(); /* ignore fake brackets */
5761 force_next(formbrack ? '.' : '}');
5762 if (formbrack) LEAVE;
5763 if (formbrack == 2) { /* means . where arguments were expected */
5769 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5772 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5773 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5780 if (PL_expect == XOPERATOR) {
5781 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5782 && isIDFIRST_lazy_if(s,UTF))
5784 CopLINE_dec(PL_curcop);
5785 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5786 CopLINE_inc(PL_curcop);
5789 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5791 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5792 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5798 PL_parser->saw_infix_sigil = 1;
5799 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5805 PL_tokenbuf[0] = '&';
5806 s = scan_ident(s - 1, PL_tokenbuf + 1,
5807 sizeof PL_tokenbuf - 1, TRUE);
5808 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5809 if (PL_tokenbuf[1]) {
5810 force_ident_maybe_lex('&');
5819 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5820 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5828 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5830 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5831 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5835 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
5839 const char tmp = *s++;
5841 if (!PL_lex_allbrackets
5842 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5850 if (!PL_lex_allbrackets
5851 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5860 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5861 && strchr("+-*/%.^&|<",tmp))
5862 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5863 "Reversed %c= operator",(int)tmp);
5865 if (PL_expect == XSTATE
5867 && (s == PL_linestart+1 || s[-2] == '\n') )
5869 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5870 || PL_lex_state != LEX_NORMAL) {
5875 if (strnEQ(s,"=cut",4)) {
5889 PL_parser->in_pod = 1;
5893 if (PL_expect == XBLOCK) {
5895 #ifdef PERL_STRICT_CR
5896 while (SPACE_OR_TAB(*t))
5898 while (SPACE_OR_TAB(*t) || *t == '\r')
5901 if (*t == '\n' || *t == '#') {
5904 SAVEI8(PL_parser->form_lex_state);
5905 SAVEI32(PL_lex_formbrack);
5906 PL_parser->form_lex_state = PL_lex_state;
5907 PL_lex_formbrack = PL_lex_brackets + 1;
5911 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5920 const char tmp = *s++;
5922 /* was this !=~ where !~ was meant?
5923 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5925 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5926 const char *t = s+1;
5928 while (t < PL_bufend && isSPACE(*t))
5931 if (*t == '/' || *t == '?'
5932 || ((*t == 'm' || *t == 's' || *t == 'y')
5933 && !isWORDCHAR(t[1]))
5934 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5935 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5936 "!=~ should be !~");
5938 if (!PL_lex_allbrackets
5939 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5952 if (PL_expect != XOPERATOR) {
5953 if (s[1] != '<' && !strchr(s,'>'))
5955 if (s[1] == '<' && s[2] != '>')
5956 s = scan_heredoc(s);
5958 s = scan_inputsymbol(s);
5959 PL_expect = XOPERATOR;
5960 TOKEN(sublex_start());
5966 if (*s == '=' && !PL_lex_allbrackets
5967 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5972 SHop(OP_LEFT_SHIFT);
5977 if (!PL_lex_allbrackets
5978 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5986 if (!PL_lex_allbrackets
5987 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5996 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6004 const char tmp = *s++;
6006 if (*s == '=' && !PL_lex_allbrackets
6007 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6012 SHop(OP_RIGHT_SHIFT);
6014 else if (tmp == '=') {
6015 if (!PL_lex_allbrackets
6016 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6025 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6034 if (PL_expect == XOPERATOR) {
6035 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6036 return deprecate_commaless_var_list();
6039 else if (PL_expect == XPOSTDEREF) {
6042 POSTDEREF(DOLSHARP);
6047 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6048 PL_tokenbuf[0] = '@';
6049 s = scan_ident(s + 1, PL_tokenbuf + 1,
6050 sizeof PL_tokenbuf - 1, FALSE);
6051 if (PL_expect == XOPERATOR) {
6053 if (PL_bufptr > s) {
6055 PL_bufptr = PL_oldbufptr;
6057 no_op("Array length", d);
6059 if (!PL_tokenbuf[1])
6061 PL_expect = XOPERATOR;
6062 force_ident_maybe_lex('#');
6066 PL_tokenbuf[0] = '$';
6067 s = scan_ident(s, PL_tokenbuf + 1,
6068 sizeof PL_tokenbuf - 1, FALSE);
6069 if (PL_expect == XOPERATOR) {
6071 if (PL_bufptr > s) {
6073 PL_bufptr = PL_oldbufptr;
6077 if (!PL_tokenbuf[1]) {
6079 yyerror("Final $ should be \\$ or $name");
6085 const char tmp = *s;
6086 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6089 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6090 && intuit_more(s)) {
6092 PL_tokenbuf[0] = '@';
6093 if (ckWARN(WARN_SYNTAX)) {
6096 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6097 t += UTF ? UTF8SKIP(t) : 1;
6099 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6100 while (t < PL_bufend && *t != ']')
6102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6103 "Multidimensional syntax %"UTF8f" not supported",
6104 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6108 else if (*s == '{') {
6110 PL_tokenbuf[0] = '%';
6111 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6112 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6114 char tmpbuf[sizeof PL_tokenbuf];
6117 } while (isSPACE(*t));
6118 if (isIDFIRST_lazy_if(t,UTF)) {
6120 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6125 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6126 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6127 "You need to quote \"%"UTF8f"\"",
6128 UTF8fARG(UTF, len, tmpbuf));
6134 PL_expect = XOPERATOR;
6135 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6136 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6137 if (!islop || PL_last_lop_op == OP_GREPSTART)
6138 PL_expect = XOPERATOR;
6139 else if (strchr("$@\"'`q", *s))
6140 PL_expect = XTERM; /* e.g. print $fh "foo" */
6141 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6142 PL_expect = XTERM; /* e.g. print $fh &sub */
6143 else if (isIDFIRST_lazy_if(s,UTF)) {
6144 char tmpbuf[sizeof PL_tokenbuf];
6146 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6147 if ((t2 = keyword(tmpbuf, len, 0))) {
6148 /* binary operators exclude handle interpretations */
6160 PL_expect = XTERM; /* e.g. print $fh length() */
6165 PL_expect = XTERM; /* e.g. print $fh subr() */
6168 else if (isDIGIT(*s))
6169 PL_expect = XTERM; /* e.g. print $fh 3 */
6170 else if (*s == '.' && isDIGIT(s[1]))
6171 PL_expect = XTERM; /* e.g. print $fh .3 */
6172 else if ((*s == '?' || *s == '-' || *s == '+')
6173 && !isSPACE(s[1]) && s[1] != '=')
6174 PL_expect = XTERM; /* e.g. print $fh -1 */
6175 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6177 PL_expect = XTERM; /* e.g. print $fh /.../
6178 XXX except DORDOR operator
6180 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6182 PL_expect = XTERM; /* print $fh <<"EOF" */
6185 force_ident_maybe_lex('$');
6189 if (PL_expect == XOPERATOR)
6191 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6192 PL_tokenbuf[0] = '@';
6193 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6195 if (!PL_tokenbuf[1]) {
6198 if (PL_lex_state == LEX_NORMAL)
6200 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6202 PL_tokenbuf[0] = '%';
6204 /* Warn about @ where they meant $. */
6205 if (*s == '[' || *s == '{') {
6206 if (ckWARN(WARN_SYNTAX)) {
6207 S_check_scalar_slice(aTHX_ s);
6211 PL_expect = XOPERATOR;
6212 force_ident_maybe_lex('@');
6215 case '/': /* may be division, defined-or, or pattern */
6216 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6217 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6218 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6223 else if (PL_expect == XOPERATOR) {
6225 if (*s == '=' && !PL_lex_allbrackets
6226 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6234 /* Disable warning on "study /blah/" */
6235 if (PL_oldoldbufptr == PL_last_uni
6236 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6237 || memNE(PL_last_uni, "study", 5)
6238 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6241 s = scan_pat(s,OP_MATCH);
6242 TERM(sublex_start());
6245 case '?': /* conditional */
6247 if (!PL_lex_allbrackets
6248 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6253 PL_lex_allbrackets++;
6257 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6258 #ifdef PERL_STRICT_CR
6261 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6263 && (s == PL_linestart || s[-1] == '\n') )
6266 formbrack = 2; /* dot seen where arguments expected */
6269 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6273 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6276 if (!PL_lex_allbrackets
6277 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6285 pl_yylval.ival = OPf_SPECIAL;
6291 if (*s == '=' && !PL_lex_allbrackets
6292 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6300 case '0': case '1': case '2': case '3': case '4':
6301 case '5': case '6': case '7': case '8': case '9':
6302 s = scan_num(s, &pl_yylval);
6303 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6304 if (PL_expect == XOPERATOR)
6309 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6312 COPLINE_SET_FROM_MULTI_END;
6313 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6314 if (PL_expect == XOPERATOR) {
6315 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6316 return deprecate_commaless_var_list();
6321 pl_yylval.ival = OP_CONST;
6322 TERM(sublex_start());
6325 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6328 printbuf("### Saw string before %s\n", s);
6330 PerlIO_printf(Perl_debug_log,
6331 "### Saw unterminated string\n");
6333 if (PL_expect == XOPERATOR) {
6334 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6335 return deprecate_commaless_var_list();
6342 pl_yylval.ival = OP_CONST;
6343 /* FIXME. I think that this can be const if char *d is replaced by
6344 more localised variables. */
6345 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6346 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6347 pl_yylval.ival = OP_STRINGIFY;
6351 if (pl_yylval.ival == OP_CONST)
6352 COPLINE_SET_FROM_MULTI_END;
6353 TERM(sublex_start());
6356 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6359 printbuf("### Saw backtick string before %s\n", s);
6361 PerlIO_printf(Perl_debug_log,
6362 "### Saw unterminated backtick string\n");
6364 if (PL_expect == XOPERATOR)
6365 no_op("Backticks",s);
6368 pl_yylval.ival = OP_BACKTICK;
6369 TERM(sublex_start());
6373 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6375 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6377 if (PL_expect == XOPERATOR)
6378 no_op("Backslash",s);
6382 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6383 char *start = s + 2;
6384 while (isDIGIT(*start) || *start == '_')
6386 if (*start == '.' && isDIGIT(start[1])) {
6387 s = scan_num(s, &pl_yylval);
6390 else if ((*start == ':' && start[1] == ':')
6391 || (PL_expect == XSTATE && *start == ':'))
6393 else if (PL_expect == XSTATE) {
6395 while (d < PL_bufend && isSPACE(*d)) d++;
6396 if (*d == ':') goto keylookup;
6398 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6399 if (!isALPHA(*start) && (PL_expect == XTERM
6400 || PL_expect == XREF || PL_expect == XSTATE
6401 || PL_expect == XTERMORDORDOR)) {
6402 GV *const gv = gv_fetchpvn_flags(s, start - s,
6403 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6405 s = scan_num(s, &pl_yylval);
6412 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6465 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6467 /* Some keywords can be followed by any delimiter, including ':' */
6468 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6470 /* x::* is just a word, unless x is "CORE" */
6471 if (!anydelim && *s == ':' && s[1] == ':') {
6472 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6477 while (d < PL_bufend && isSPACE(*d))
6478 d++; /* no comments skipped here, or s### is misparsed */
6480 /* Is this a word before a => operator? */
6481 if (*d == '=' && d[1] == '>') {
6485 = (OP*)newSVOP(OP_CONST, 0,
6486 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6487 pl_yylval.opval->op_private = OPpCONST_BARE;
6491 /* Check for plugged-in keyword */
6495 char *saved_bufptr = PL_bufptr;
6497 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6499 if (result == KEYWORD_PLUGIN_DECLINE) {
6500 /* not a plugged-in keyword */
6501 PL_bufptr = saved_bufptr;
6502 } else if (result == KEYWORD_PLUGIN_STMT) {
6503 pl_yylval.opval = o;
6505 if (!PL_nexttoke) PL_expect = XSTATE;
6506 return REPORT(PLUGSTMT);
6507 } else if (result == KEYWORD_PLUGIN_EXPR) {
6508 pl_yylval.opval = o;
6510 if (!PL_nexttoke) PL_expect = XOPERATOR;
6511 return REPORT(PLUGEXPR);
6513 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6518 /* Check for built-in keyword */
6519 tmp = keyword(PL_tokenbuf, len, 0);
6521 /* Is this a label? */
6522 if (!anydelim && PL_expect == XSTATE
6523 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6525 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6526 pl_yylval.pval[len] = '\0';
6527 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6532 /* Check for lexical sub */
6533 if (PL_expect != XOPERATOR) {
6534 char tmpbuf[sizeof PL_tokenbuf + 1];
6536 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6537 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6538 if (off != NOT_IN_PAD) {
6539 assert(off); /* we assume this is boolean-true below */
6540 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6541 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6542 HEK * const stashname = HvNAME_HEK(stash);
6543 sv = newSVhek(stashname);
6544 sv_catpvs(sv, "::");
6545 sv_catpvn_flags(sv, PL_tokenbuf, len,
6546 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6547 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6557 rv2cv_op = newOP(OP_PADANY, 0);
6558 rv2cv_op->op_targ = off;
6559 cv = find_lexical_cv(off);
6567 if (tmp < 0) { /* second-class keyword? */
6568 GV *ogv = NULL; /* override (winner) */
6569 GV *hgv = NULL; /* hidden (loser) */
6570 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6572 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6573 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6575 && (cv = GvCVu(gv)))
6577 if (GvIMPORTED_CV(gv))
6579 else if (! CvMETHOD(cv))
6583 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6586 && (isGV_with_GP(gv)
6587 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6588 : SvPCS_IMPORTED(gv)
6589 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6597 tmp = 0; /* overridden by import or by GLOBAL */
6600 && -tmp==KEY_lock /* XXX generalizable kludge */
6603 tmp = 0; /* any sub overrides "weak" keyword */
6605 else { /* no override */
6607 if (tmp == KEY_dump) {
6608 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6609 "dump() better written as CORE::dump()");
6613 if (hgv && tmp != KEY_x) /* never ambiguous */
6614 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6615 "Ambiguous call resolved as CORE::%s(), "
6616 "qualify as such or use &",
6621 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6622 && (!anydelim || *s != '#')) {
6623 /* no override, and not s### either; skipspace is safe here
6624 * check for => on following line */
6626 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6627 STRLEN soff = s - SvPVX(PL_linestr);
6628 s = skipspace_flags(s, LEX_NO_INCLINE);
6629 arrow = *s == '=' && s[1] == '>';
6630 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6631 s = SvPVX(PL_linestr) + soff;
6639 default: /* not a keyword */
6640 /* Trade off - by using this evil construction we can pull the
6641 variable gv into the block labelled keylookup. If not, then
6642 we have to give it function scope so that the goto from the
6643 earlier ':' case doesn't bypass the initialisation. */
6645 just_a_word_zero_gv:
6657 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6661 /* Get the rest if it looks like a package qualifier */
6663 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6665 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6668 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6669 UTF8fARG(UTF, len, PL_tokenbuf),
6670 *s == '\'' ? "'" : "::");
6675 if (PL_expect == XOPERATOR) {
6676 if (PL_bufptr == PL_linestart) {
6677 CopLINE_dec(PL_curcop);
6678 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6679 CopLINE_inc(PL_curcop);
6682 no_op("Bareword",s);
6685 /* See if the name is "Foo::",
6686 in which case Foo is a bareword
6687 (and a package name). */
6690 && PL_tokenbuf[len - 2] == ':'
6691 && PL_tokenbuf[len - 1] == ':')
6693 if (ckWARN(WARN_BAREWORD)
6694 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6695 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6696 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6697 UTF8fARG(UTF, len, PL_tokenbuf));
6699 PL_tokenbuf[len] = '\0';
6708 /* if we saw a global override before, get the right name */
6711 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6714 SV * const tmp_sv = sv;
6715 sv = newSVpvs("CORE::GLOBAL::");
6716 sv_catsv(sv, tmp_sv);
6717 SvREFCNT_dec(tmp_sv);
6721 /* Presume this is going to be a bareword of some sort. */
6723 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6724 pl_yylval.opval->op_private = OPpCONST_BARE;
6726 /* And if "Foo::", then that's what it certainly is. */
6732 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6733 const_op->op_private = OPpCONST_BARE;
6735 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6739 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6742 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6745 /* Use this var to track whether intuit_method has been
6746 called. intuit_method returns 0 or > 255. */
6749 /* See if it's the indirect object for a list operator. */
6752 && PL_oldoldbufptr < PL_bufptr
6753 && (PL_oldoldbufptr == PL_last_lop
6754 || PL_oldoldbufptr == PL_last_uni)
6755 && /* NO SKIPSPACE BEFORE HERE! */
6757 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
6760 bool immediate_paren = *s == '(';
6762 /* (Now we can afford to cross potential line boundary.) */
6765 /* Two barewords in a row may indicate method call. */
6767 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$')
6768 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
6773 /* If not a declared subroutine, it's an indirect object. */
6774 /* (But it's an indir obj regardless for sort.) */
6775 /* Also, if "_" follows a filetest operator, it's a bareword */
6778 ( !immediate_paren && (PL_last_lop_op == OP_SORT
6780 && (PL_last_lop_op != OP_MAPSTART
6781 && PL_last_lop_op != OP_GREPSTART))))
6782 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6783 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
6787 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6792 PL_expect = XOPERATOR;
6795 /* Is this a word before a => operator? */
6796 if (*s == '=' && s[1] == '>' && !pkgname) {
6799 if (gvp || (lex && !off)) {
6800 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6801 /* This is our own scalar, created a few lines
6802 above, so this is safe. */
6804 sv_setpv(sv, PL_tokenbuf);
6805 if (UTF && !IN_BYTES
6806 && is_utf8_string((U8*)PL_tokenbuf, len))
6813 /* If followed by a paren, it's certainly a subroutine. */
6818 while (SPACE_OR_TAB(*d))
6820 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6825 NEXTVAL_NEXTTOKE.opval =
6826 off ? rv2cv_op : pl_yylval.opval;
6828 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6829 else op_free(rv2cv_op), force_next(WORD);
6834 /* If followed by var or block, call it a method (unless sub) */
6836 if ((*s == '$' || *s == '{') && !cv) {
6838 PL_last_lop = PL_oldbufptr;
6839 PL_last_lop_op = OP_METHOD;
6840 if (!PL_lex_allbrackets
6841 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6843 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6845 PL_expect = XBLOCKTERM;
6847 return REPORT(METHOD);
6850 /* If followed by a bareword, see if it looks like indir obj. */
6852 if (tmp == 1 && !orig_keyword
6853 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6854 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6857 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6859 sv_setpvn(sv, PL_tokenbuf, len);
6860 if (UTF && !IN_BYTES
6861 && is_utf8_string((U8*)PL_tokenbuf, len))
6863 else SvUTF8_off(sv);
6866 if (tmp == METHOD && !PL_lex_allbrackets
6867 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6869 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6874 /* Not a method, so call it a subroutine (if defined) */
6877 /* Check for a constant sub */
6878 if ((sv = cv_const_sv_or_av(cv))) {
6881 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6882 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6883 if (SvTYPE(sv) == SVt_PVAV)
6884 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6887 pl_yylval.opval->op_private = 0;
6888 pl_yylval.opval->op_folded = 1;
6889 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6894 op_free(pl_yylval.opval);
6896 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6897 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6898 PL_last_lop = PL_oldbufptr;
6899 PL_last_lop_op = OP_ENTERSUB;
6900 /* Is there a prototype? */
6904 STRLEN protolen = CvPROTOLEN(cv);
6905 const char *proto = CvPROTO(cv);
6907 proto = S_strip_spaces(aTHX_ proto, &protolen);
6910 if ((optional = *proto == ';'))
6913 while (*proto == ';');
6917 *proto == '$' || *proto == '_'
6918 || *proto == '*' || *proto == '+'
6923 *proto == '\\' && proto[1] && proto[2] == '\0'
6926 UNIPROTO(UNIOPSUB,optional);
6927 if (*proto == '\\' && proto[1] == '[') {
6928 const char *p = proto + 2;
6929 while(*p && *p != ']')
6931 if(*p == ']' && !p[1])
6932 UNIPROTO(UNIOPSUB,optional);
6934 if (*proto == '&' && *s == '{') {
6936 sv_setpvs(PL_subname, "__ANON__");
6938 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6939 if (!PL_lex_allbrackets
6940 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6942 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6947 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6949 force_next(off ? PRIVATEREF : WORD);
6950 if (!PL_lex_allbrackets
6951 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6953 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6958 /* Call it a bare word */
6960 if (PL_hints & HINT_STRICT_SUBS)
6961 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6964 /* after "print" and similar functions (corresponding to
6965 * "F? L" in opcode.pl), whatever wasn't already parsed as
6966 * a filehandle should be subject to "strict subs".
6967 * Likewise for the optional indirect-object argument to system
6968 * or exec, which can't be a bareword */
6969 if ((PL_last_lop_op == OP_PRINT
6970 || PL_last_lop_op == OP_PRTF
6971 || PL_last_lop_op == OP_SAY
6972 || PL_last_lop_op == OP_SYSTEM
6973 || PL_last_lop_op == OP_EXEC)
6974 && (PL_hints & HINT_STRICT_SUBS))
6975 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6976 if (lastchar != '-') {
6977 if (ckWARN(WARN_RESERVED)) {
6981 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6983 /* PL_warn_reserved is constant */
6984 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6985 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6995 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6996 && saw_infix_sigil) {
6997 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6998 "Operator or semicolon missing before %c%"UTF8f,
7000 UTF8fARG(UTF, strlen(PL_tokenbuf),
7002 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7003 "Ambiguous use of %c resolved as operator %c",
7004 lastchar, lastchar);
7011 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7016 (OP*)newSVOP(OP_CONST, 0,
7017 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7020 case KEY___PACKAGE__:
7022 (OP*)newSVOP(OP_CONST, 0,
7024 ? newSVhek(HvNAME_HEK(PL_curstash))
7031 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7032 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7035 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7037 gv_init(gv,stash,"DATA",4,0);
7040 GvIOp(gv) = newIO();
7041 IoIFP(GvIOp(gv)) = PL_rsfp;
7042 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
7044 const int fd = PerlIO_fileno(PL_rsfp);
7046 fcntl(fd,F_SETFD, FD_CLOEXEC);
7050 /* Mark this internal pseudo-handle as clean */
7051 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7052 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7053 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7055 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7056 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7057 /* if the script was opened in binmode, we need to revert
7058 * it to text mode for compatibility; but only iff it has CRs
7059 * XXX this is a questionable hack at best. */
7060 if (PL_bufend-PL_bufptr > 2
7061 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7064 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7065 loc = PerlIO_tell(PL_rsfp);
7066 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7069 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7071 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7072 #endif /* NETWARE */
7074 PerlIO_seek(PL_rsfp, loc, 0);
7078 #ifdef PERLIO_LAYERS
7081 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7082 else if (IN_ENCODING) {
7088 XPUSHs(_get_encoding());
7090 call_method("name", G_SCALAR);
7094 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7095 Perl_form(aTHX_ ":encoding(%"SVf")",
7108 FUN0OP(CvCLONE(PL_compcv)
7109 ? newOP(OP_RUNCV, 0)
7110 : newPVOP(OP_RUNCV,0,NULL));
7119 if (PL_expect == XSTATE) {
7130 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7131 if ((*s == ':' && s[1] == ':')
7132 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7136 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7140 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7141 UTF8fARG(UTF, len, PL_tokenbuf));
7144 else if (tmp == KEY_require || tmp == KEY_do
7146 /* that's a way to remember we saw "CORE::" */
7158 LOP(OP_ACCEPT,XTERM);
7161 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7166 LOP(OP_ATAN2,XTERM);
7172 LOP(OP_BINMODE,XTERM);
7175 LOP(OP_BLESS,XTERM);
7184 /* We have to disambiguate the two senses of
7185 "continue". If the next token is a '{' then
7186 treat it as the start of a continue block;
7187 otherwise treat it as a control operator.
7197 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7207 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7216 if (!PL_cryptseen) {
7217 PL_cryptseen = TRUE;
7221 LOP(OP_CRYPT,XTERM);
7224 LOP(OP_CHMOD,XTERM);
7227 LOP(OP_CHOWN,XTERM);
7230 LOP(OP_CONNECT,XTERM);
7250 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7252 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7253 && !keyword(PL_tokenbuf + 1, len, 0)) {
7256 force_ident_maybe_lex('&');
7261 if (orig_keyword == KEY_do) {
7270 PL_hints |= HINT_BLOCK_SCOPE;
7280 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7281 STR_WITH_LEN("NDBM_File::"),
7282 STR_WITH_LEN("DB_File::"),
7283 STR_WITH_LEN("GDBM_File::"),
7284 STR_WITH_LEN("SDBM_File::"),
7285 STR_WITH_LEN("ODBM_File::"),
7287 LOP(OP_DBMOPEN,XTERM);
7299 pl_yylval.ival = CopLINE(PL_curcop);
7303 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7315 if (*s == '{') { /* block eval */
7316 PL_expect = XTERMBLOCK;
7317 UNIBRACK(OP_ENTERTRY);
7319 else { /* string eval */
7321 UNIBRACK(OP_ENTEREVAL);
7326 UNIBRACK(-OP_ENTEREVAL);
7340 case KEY_endhostent:
7346 case KEY_endservent:
7349 case KEY_endprotoent:
7360 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7362 pl_yylval.ival = CopLINE(PL_curcop);
7364 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7367 if ((PL_bufend - p) >= 3
7368 && strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7372 else if ((PL_bufend - p) >= 4
7373 && strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7376 /* skip optional package name, as in "for my abc $x (..)" */
7377 if (isIDFIRST_lazy_if(p,UTF)) {
7378 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7382 Perl_croak(aTHX_ "Missing $ on loop variable");
7387 LOP(OP_FORMLINE,XTERM);
7396 LOP(OP_FCNTL,XTERM);
7402 LOP(OP_FLOCK,XTERM);
7405 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7410 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7415 LOP(OP_GREPSTART, XREF);
7432 case KEY_getpriority:
7433 LOP(OP_GETPRIORITY,XTERM);
7435 case KEY_getprotobyname:
7438 case KEY_getprotobynumber:
7439 LOP(OP_GPBYNUMBER,XTERM);
7441 case KEY_getprotoent:
7453 case KEY_getpeername:
7454 UNI(OP_GETPEERNAME);
7456 case KEY_gethostbyname:
7459 case KEY_gethostbyaddr:
7460 LOP(OP_GHBYADDR,XTERM);
7462 case KEY_gethostent:
7465 case KEY_getnetbyname:
7468 case KEY_getnetbyaddr:
7469 LOP(OP_GNBYADDR,XTERM);
7474 case KEY_getservbyname:
7475 LOP(OP_GSBYNAME,XTERM);
7477 case KEY_getservbyport:
7478 LOP(OP_GSBYPORT,XTERM);
7480 case KEY_getservent:
7483 case KEY_getsockname:
7484 UNI(OP_GETSOCKNAME);
7486 case KEY_getsockopt:
7487 LOP(OP_GSOCKOPT,XTERM);
7502 pl_yylval.ival = CopLINE(PL_curcop);
7503 Perl_ck_warner_d(aTHX_
7504 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7505 "given is experimental");
7510 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7518 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7520 pl_yylval.ival = CopLINE(PL_curcop);
7524 LOP(OP_INDEX,XTERM);
7530 LOP(OP_IOCTL,XTERM);
7558 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7563 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7577 LOP(OP_LISTEN,XTERM);
7586 s = scan_pat(s,OP_MATCH);
7587 TERM(sublex_start());
7590 LOP(OP_MAPSTART, XREF);
7593 LOP(OP_MKDIR,XTERM);
7596 LOP(OP_MSGCTL,XTERM);
7599 LOP(OP_MSGGET,XTERM);
7602 LOP(OP_MSGRCV,XTERM);
7605 LOP(OP_MSGSND,XTERM);
7611 yyerror(Perl_form(aTHX_
7612 "Can't redeclare \"%s\" in \"%s\"",
7613 tmp == KEY_my ? "my" :
7614 tmp == KEY_state ? "state" : "our",
7615 PL_in_my == KEY_my ? "my" :
7616 PL_in_my == KEY_state ? "state" : "our"));
7618 PL_in_my = (U16)tmp;
7620 if (isIDFIRST_lazy_if(s,UTF)) {
7621 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7622 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7624 if (!FEATURE_LEXSUBS_IS_ENABLED)
7626 "Experimental \"%s\" subs not enabled",
7627 tmp == KEY_my ? "my" :
7628 tmp == KEY_state ? "state" : "our");
7629 Perl_ck_warner_d(aTHX_
7630 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7631 "The lexical_subs feature is experimental");
7634 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7635 if (!PL_in_my_stash) {
7639 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7640 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7641 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7651 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7656 s = tokenize_use(0, s);
7660 if (*s == '(' || (s = skipspace(s), *s == '('))
7663 if (!PL_lex_allbrackets
7664 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7666 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7673 if (isIDFIRST_lazy_if(s,UTF)) {
7675 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7677 for (t=d; isSPACE(*t);)
7679 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7681 && !(t[0] == '=' && t[1] == '>')
7682 && !(t[0] == ':' && t[1] == ':')
7683 && !keyword(s, d-s, 0)
7685 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7686 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7687 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7693 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7695 pl_yylval.ival = OP_OR;
7705 LOP(OP_OPEN_DIR,XTERM);
7708 checkcomma(s,PL_tokenbuf,"filehandle");
7712 checkcomma(s,PL_tokenbuf,"filehandle");
7731 s = force_word(s,WORD,FALSE,TRUE);
7733 s = force_strict_version(s);
7737 LOP(OP_PIPE_OP,XTERM);
7740 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7743 COPLINE_SET_FROM_MULTI_END;
7744 pl_yylval.ival = OP_CONST;
7745 TERM(sublex_start());
7752 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7755 COPLINE_SET_FROM_MULTI_END;
7756 PL_expect = XOPERATOR;
7757 if (SvCUR(PL_lex_stuff)) {
7758 int warned_comma = !ckWARN(WARN_QW);
7759 int warned_comment = warned_comma;
7760 d = SvPV_force(PL_lex_stuff, len);
7762 for (; isSPACE(*d) && len; --len, ++d)
7767 if (!warned_comma || !warned_comment) {
7768 for (; !isSPACE(*d) && len; --len, ++d) {
7769 if (!warned_comma && *d == ',') {
7770 Perl_warner(aTHX_ packWARN(WARN_QW),
7771 "Possible attempt to separate words with commas");
7774 else if (!warned_comment && *d == '#') {
7775 Perl_warner(aTHX_ packWARN(WARN_QW),
7776 "Possible attempt to put comments in qw() list");
7782 for (; !isSPACE(*d) && len; --len, ++d)
7785 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7786 words = op_append_elem(OP_LIST, words,
7787 newSVOP(OP_CONST, 0, tokeq(sv)));
7792 words = newNULLLIST();
7793 SvREFCNT_dec_NN(PL_lex_stuff);
7794 PL_lex_stuff = NULL;
7795 PL_expect = XOPERATOR;
7796 pl_yylval.opval = sawparens(words);
7801 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7804 pl_yylval.ival = OP_STRINGIFY;
7805 if (SvIVX(PL_lex_stuff) == '\'')
7806 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7807 TERM(sublex_start());
7810 s = scan_pat(s,OP_QR);
7811 TERM(sublex_start());
7814 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7817 pl_yylval.ival = OP_BACKTICK;
7818 TERM(sublex_start());
7826 s = force_version(s, FALSE);
7828 else if (*s != 'v' || !isDIGIT(s[1])
7829 || (s = force_version(s, TRUE), *s == 'v'))
7831 *PL_tokenbuf = '\0';
7832 s = force_word(s,WORD,TRUE,TRUE);
7833 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7834 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7835 GV_ADD | (UTF ? SVf_UTF8 : 0));
7837 yyerror("<> at require-statement should be quotes");
7839 if (orig_keyword == KEY_require) {
7845 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7847 PL_last_uni = PL_oldbufptr;
7848 PL_last_lop_op = OP_REQUIRE;
7850 return REPORT( (int)REQUIRE );
7859 LOP(OP_RENAME,XTERM);
7868 LOP(OP_RINDEX,XTERM);
7877 UNIDOR(OP_READLINE);
7880 UNIDOR(OP_BACKTICK);
7889 LOP(OP_REVERSE,XTERM);
7892 UNIDOR(OP_READLINK);
7899 if (pl_yylval.opval)
7900 TERM(sublex_start());
7902 TOKEN(1); /* force error */
7905 checkcomma(s,PL_tokenbuf,"filehandle");
7915 LOP(OP_SELECT,XTERM);
7921 LOP(OP_SEMCTL,XTERM);
7924 LOP(OP_SEMGET,XTERM);
7927 LOP(OP_SEMOP,XTERM);
7933 LOP(OP_SETPGRP,XTERM);
7935 case KEY_setpriority:
7936 LOP(OP_SETPRIORITY,XTERM);
7938 case KEY_sethostent:
7944 case KEY_setservent:
7947 case KEY_setprotoent:
7957 LOP(OP_SEEKDIR,XTERM);
7959 case KEY_setsockopt:
7960 LOP(OP_SSOCKOPT,XTERM);
7966 LOP(OP_SHMCTL,XTERM);
7969 LOP(OP_SHMGET,XTERM);
7972 LOP(OP_SHMREAD,XTERM);
7975 LOP(OP_SHMWRITE,XTERM);
7978 LOP(OP_SHUTDOWN,XTERM);
7987 LOP(OP_SOCKET,XTERM);
7989 case KEY_socketpair:
7990 LOP(OP_SOCKPAIR,XTERM);
7993 checkcomma(s,PL_tokenbuf,"subroutine name");
7996 s = force_word(s,WORD,TRUE,TRUE);
8000 LOP(OP_SPLIT,XTERM);
8003 LOP(OP_SPRINTF,XTERM);
8006 LOP(OP_SPLICE,XTERM);
8021 LOP(OP_SUBSTR,XTERM);
8027 char * const tmpbuf = PL_tokenbuf + 1;
8028 expectation attrful;
8029 bool have_name, have_proto;
8030 const int key = tmp;
8031 SV *format_name = NULL;
8036 if (isIDFIRST_lazy_if(s,UTF)
8038 || (*s == ':' && s[1] == ':'))
8042 attrful = XATTRBLOCK;
8043 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8045 if (key == KEY_format)
8046 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8048 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8050 PL_tokenbuf, len + 1, 0
8052 sv_setpvn(PL_subname, tmpbuf, len);
8054 sv_setsv(PL_subname,PL_curstname);
8055 sv_catpvs(PL_subname,"::");
8056 sv_catpvn(PL_subname,tmpbuf,len);
8058 if (SvUTF8(PL_linestr))
8059 SvUTF8_on(PL_subname);
8066 if (key == KEY_my || key == KEY_our || key==KEY_state)
8069 /* diag_listed_as: Missing name in "%s sub" */
8071 "Missing name in \"%s\"", PL_bufptr);
8073 PL_expect = XTERMBLOCK;
8074 attrful = XATTRTERM;
8075 sv_setpvs(PL_subname,"?");
8079 if (key == KEY_format) {
8081 NEXTVAL_NEXTTOKE.opval
8082 = (OP*)newSVOP(OP_CONST,0, format_name);
8083 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8089 /* Look for a prototype */
8090 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8091 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8092 COPLINE_SET_FROM_MULTI_END;
8094 Perl_croak(aTHX_ "Prototype not terminated");
8095 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8103 if (*s == ':' && s[1] != ':')
8104 PL_expect = attrful;
8105 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8106 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8107 key == KEY_DESTROY || key == KEY_BEGIN ||
8108 key == KEY_UNITCHECK || key == KEY_CHECK ||
8109 key == KEY_INIT || key == KEY_END ||
8110 key == KEY_my || key == KEY_state ||
8113 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8114 else if (*s != ';' && *s != '}')
8115 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8119 NEXTVAL_NEXTTOKE.opval =
8120 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8121 PL_lex_stuff = NULL;
8126 sv_setpvs(PL_subname, "__ANON__");
8128 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8131 force_ident_maybe_lex('&');
8136 LOP(OP_SYSTEM,XREF);
8139 LOP(OP_SYMLINK,XTERM);
8142 LOP(OP_SYSCALL,XTERM);
8145 LOP(OP_SYSOPEN,XTERM);
8148 LOP(OP_SYSSEEK,XTERM);
8151 LOP(OP_SYSREAD,XTERM);
8154 LOP(OP_SYSWRITE,XTERM);
8159 TERM(sublex_start());
8180 LOP(OP_TRUNCATE,XTERM);
8192 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8194 pl_yylval.ival = CopLINE(PL_curcop);
8198 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8200 pl_yylval.ival = CopLINE(PL_curcop);
8204 LOP(OP_UNLINK,XTERM);
8210 LOP(OP_UNPACK,XTERM);
8213 LOP(OP_UTIME,XTERM);
8219 LOP(OP_UNSHIFT,XTERM);
8222 s = tokenize_use(1, s);
8232 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8234 pl_yylval.ival = CopLINE(PL_curcop);
8235 Perl_ck_warner_d(aTHX_
8236 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8237 "when is experimental");
8241 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8243 pl_yylval.ival = CopLINE(PL_curcop);
8247 PL_hints |= HINT_BLOCK_SCOPE;
8254 LOP(OP_WAITPID,XTERM);
8260 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8261 * we use the same number on EBCDIC */
8262 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8266 if (PL_expect == XOPERATOR) {
8267 if (*s == '=' && !PL_lex_allbrackets
8268 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8278 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8280 pl_yylval.ival = OP_XOR;
8289 Looks up an identifier in the pad or in a package
8292 PRIVATEREF if this is a lexical name.
8293 WORD if this belongs to a package.
8296 if we're in a my declaration
8297 croak if they tried to say my($foo::bar)
8298 build the ops for a my() declaration
8299 if it's an access to a my() variable
8300 build ops for access to a my() variable
8301 if in a dq string, and they've said @foo and we can't find @foo
8303 build ops for a bareword
8307 S_pending_ident(pTHX)
8310 const char pit = (char)pl_yylval.ival;
8311 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8312 /* All routes through this function want to know if there is a colon. */
8313 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8315 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8316 "### Pending identifier '%s'\n", PL_tokenbuf); });
8318 /* if we're in a my(), we can't allow dynamics here.
8319 $foo'bar has already been turned into $foo::bar, so
8320 just check for colons.
8322 if it's a legal name, the OP is a PADANY.
8325 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8327 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8328 "variable %s in \"our\"",
8329 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8330 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8334 /* "my" variable %s can't be in a package */
8335 /* PL_no_myglob is constant */
8336 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8337 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8338 PL_in_my == KEY_my ? "my" : "state",
8339 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8341 UTF ? SVf_UTF8 : 0);
8345 pl_yylval.opval = newOP(OP_PADANY, 0);
8346 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8347 UTF ? SVf_UTF8 : 0);
8353 build the ops for accesses to a my() variable.
8358 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8360 if (tmp != NOT_IN_PAD) {
8361 /* might be an "our" variable" */
8362 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8363 /* build ops for a bareword */
8364 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8365 HEK * const stashname = HvNAME_HEK(stash);
8366 SV * const sym = newSVhek(stashname);
8367 sv_catpvs(sym, "::");
8368 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8369 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8370 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8374 ((PL_tokenbuf[0] == '$') ? SVt_PV
8375 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8380 pl_yylval.opval = newOP(OP_PADANY, 0);
8381 pl_yylval.opval->op_targ = tmp;
8387 Whine if they've said @foo in a doublequoted string,
8388 and @foo isn't a variable we can find in the symbol
8391 if (ckWARN(WARN_AMBIGUOUS)
8393 && PL_lex_state != LEX_NORMAL
8394 && !PL_lex_brackets)
8396 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8397 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8398 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8399 /* DO NOT warn for @- and @+ */
8400 && !( PL_tokenbuf[2] == '\0'
8401 && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8404 /* Downgraded from fatal to warning 20000522 mjd */
8405 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8406 "Possible unintended interpolation of %"UTF8f
8408 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8412 /* build ops for a bareword */
8413 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8414 newSVpvn_flags(PL_tokenbuf + 1,
8416 UTF ? SVf_UTF8 : 0 ));
8417 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8419 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8420 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8421 | ( UTF ? SVf_UTF8 : 0 ),
8422 ((PL_tokenbuf[0] == '$') ? SVt_PV
8423 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8429 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8431 PERL_ARGS_ASSERT_CHECKCOMMA;
8433 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8434 if (ckWARN(WARN_SYNTAX)) {
8437 for (w = s+2; *w && level; w++) {
8445 /* the list of chars below is for end of statements or
8446 * block / parens, boolean operators (&&, ||, //) and branch
8447 * constructs (or, and, if, until, unless, while, err, for).
8448 * Not a very solid hack... */
8449 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8450 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8451 "%s (...) interpreted as function",name);
8454 while (s < PL_bufend && isSPACE(*s))
8458 while (s < PL_bufend && isSPACE(*s))
8460 if (isIDFIRST_lazy_if(s,UTF)) {
8461 const char * const w = s;
8462 s += UTF ? UTF8SKIP(s) : 1;
8463 while (isWORDCHAR_lazy_if(s,UTF))
8464 s += UTF ? UTF8SKIP(s) : 1;
8465 while (s < PL_bufend && isSPACE(*s))
8470 if (keyword(w, s - w, 0))
8473 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8474 if (gv && GvCVu(gv))
8478 Copy(w, tmpbuf+1, s - w, char);
8480 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8481 if (off != NOT_IN_PAD) return;
8483 Perl_croak(aTHX_ "No comma allowed after %s", what);
8488 /* S_new_constant(): do any overload::constant lookup.
8490 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8491 Best used as sv=new_constant(..., sv, ...).
8492 If s, pv are NULL, calls subroutine with one argument,
8493 and <type> is used with error messages only.
8494 <type> is assumed to be well formed UTF-8 */
8497 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8498 SV *sv, SV *pv, const char *type, STRLEN typelen)
8501 HV * table = GvHV(PL_hintgv); /* ^H */
8506 const char *why1 = "", *why2 = "", *why3 = "";
8508 PERL_ARGS_ASSERT_NEW_CONSTANT;
8509 /* We assume that this is true: */
8510 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8513 /* charnames doesn't work well if there have been errors found */
8514 if (PL_error_count > 0 && *key == 'c')
8516 SvREFCNT_dec_NN(sv);
8517 return &PL_sv_undef;
8520 sv_2mortal(sv); /* Parent created it permanently */
8522 || ! (PL_hints & HINT_LOCALIZE_HH)
8523 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8528 /* Here haven't found what we're looking for. If it is charnames,
8529 * perhaps it needs to be loaded. Try doing that before giving up */
8531 Perl_load_module(aTHX_
8533 newSVpvs("_charnames"),
8534 /* version parameter; no need to specify it, as if
8535 * we get too early a version, will fail anyway,
8536 * not being able to find '_charnames' */
8541 assert(sp == PL_stack_sp);
8542 table = GvHV(PL_hintgv);
8544 && (PL_hints & HINT_LOCALIZE_HH)
8545 && (cvp = hv_fetch(table, key, keylen, FALSE))
8551 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8552 msg = Perl_form(aTHX_
8553 "Constant(%.*s) unknown",
8554 (int)(type ? typelen : len),
8560 why3 = "} is not defined";
8563 msg = Perl_form(aTHX_
8564 /* The +3 is for '\N{'; -4 for that, plus '}' */
8565 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8569 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8570 (int)(type ? typelen : len),
8571 (type ? type: s), why1, why2, why3);
8574 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8575 return SvREFCNT_inc_simple_NN(sv);
8580 pv = newSVpvn_flags(s, len, SVs_TEMP);
8582 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8584 typesv = &PL_sv_undef;
8586 PUSHSTACKi(PERLSI_OVERLOAD);
8598 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8602 /* Check the eval first */
8603 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8605 const char * errstr;
8606 sv_catpvs(errsv, "Propagated");
8607 errstr = SvPV_const(errsv, errlen);
8608 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8610 res = SvREFCNT_inc_simple_NN(sv);
8614 SvREFCNT_inc_simple_void_NN(res);
8623 why1 = "Call to &{$^H{";
8625 why3 = "}} did not return a defined value";
8627 (void)sv_2mortal(sv);
8634 PERL_STATIC_INLINE void
8635 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8636 PERL_ARGS_ASSERT_PARSE_IDENT;
8640 Perl_croak(aTHX_ "%s", ident_too_long);
8641 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8642 /* The UTF-8 case must come first, otherwise things
8643 * like c\N{COMBINING TILDE} would start failing, as the
8644 * isWORDCHAR_A case below would gobble the 'c' up.
8647 char *t = *s + UTF8SKIP(*s);
8648 while (isIDCONT_utf8((U8*)t))
8650 if (*d + (t - *s) > e)
8651 Perl_croak(aTHX_ "%s", ident_too_long);
8652 Copy(*s, *d, t - *s, char);
8656 else if ( isWORDCHAR_A(**s) ) {
8659 } while (isWORDCHAR_A(**s) && *d < e);
8661 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8666 else if (allow_package && **s == ':' && (*s)[1] == ':'
8667 /* Disallow things like Foo::$bar. For the curious, this is
8668 * the code path that triggers the "Bad name after" warning
8669 * when looking for barewords.
8671 && (*s)[2] != '$') {
8681 /* Returns a NUL terminated string, with the length of the string written to
8685 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8688 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8689 bool is_utf8 = cBOOL(UTF);
8691 PERL_ARGS_ASSERT_SCAN_WORD;
8693 parse_ident(&s, &d, e, allow_package, is_utf8);
8699 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8700 * iff Unicode semantics are to be used. The legal ones are any of:
8701 * a) all ASCII characters except:
8702 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
8704 * The final case currently doesn't get this far in the program, so we
8705 * don't test for it. If that were to change, it would be ok to allow it.
8706 * c) When not under Unicode rules, any upper Latin1 character
8707 * d) Otherwise, when unicode rules are used, all XIDS characters.
8709 * Because all ASCII characters have the same representation whether
8710 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8711 * '{' without knowing if is UTF-8 or not.
8712 * EBCDIC already uses the rules that ASCII platforms will use after the
8713 * deprecation cycle; see comment below about the deprecation. */
8715 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8716 (isGRAPH_A(*(s)) || ((is_utf8) \
8717 ? isIDFIRST_utf8((U8*) (s)) \
8719 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8721 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8722 (isGRAPH_A(*(s)) || ((is_utf8) \
8723 ? isIDFIRST_utf8((U8*) (s)) \
8724 : ! isASCII_utf8((U8*) (s))))
8728 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8730 I32 herelines = PL_parser->herelines;
8731 SSize_t bracket = -1;
8734 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8735 bool is_utf8 = cBOOL(UTF);
8736 I32 orig_copline = 0, tmp_copline = 0;
8738 PERL_ARGS_ASSERT_SCAN_IDENT;
8740 if (isSPACE(*s) || !*s)
8743 while (isDIGIT(*s)) {
8745 Perl_croak(aTHX_ "%s", ident_too_long);
8749 else { /* See if it is a "normal" identifier */
8750 parse_ident(&s, &d, e, 1, is_utf8);
8755 /* Either a digit variable, or parse_ident() found an identifier
8756 (anything valid as a bareword), so job done and return. */
8757 if (PL_lex_state != LEX_NORMAL)
8758 PL_lex_state = LEX_INTERPENDMAYBE;
8762 /* Here, it is not a run-of-the-mill identifier name */
8764 if (*s == '$' && s[1]
8765 && (isIDFIRST_lazy_if(s+1,is_utf8)
8766 || isDIGIT_A((U8)s[1])
8769 || strnEQ(s+1,"::",2)) )
8771 /* Dereferencing a value in a scalar variable.
8772 The alternatives are different syntaxes for a scalar variable.
8773 Using ' as a leading package separator isn't allowed. :: is. */
8776 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8778 bracket = s - SvPVX(PL_linestr);
8780 orig_copline = CopLINE(PL_curcop);
8781 if (s < PL_bufend && isSPACE(*s)) {
8785 if ((s <= PL_bufend - (is_utf8)
8788 && VALID_LEN_ONE_IDENT(s, is_utf8))
8790 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8791 * because often it has no graphic representation. (We can't get to
8792 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8795 ? ! isGRAPH_utf8( (U8*) s)
8796 : (! isGRAPH_L1( (U8) *s)
8797 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8799 deprecate("literal non-graphic characters in variable names");
8803 const STRLEN skip = UTF8SKIP(s);
8806 for ( i = 0; i < skip; i++ )
8814 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8815 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8819 /* Warn about ambiguous code after unary operators if {...} notation isn't
8820 used. There's no difference in ambiguity; it's merely a heuristic
8821 about when not to warn. */
8822 else if (ck_uni && bracket == -1)
8824 if (bracket != -1) {
8825 /* If we were processing {...} notation then... */
8826 if (isIDFIRST_lazy_if(d,is_utf8)) {
8827 /* if it starts as a valid identifier, assume that it is one.
8828 (the later check for } being at the expected point will trap
8829 cases where this doesn't pan out.) */
8830 d += is_utf8 ? UTF8SKIP(d) : 1;
8831 parse_ident(&s, &d, e, 1, is_utf8);
8833 tmp_copline = CopLINE(PL_curcop);
8834 if (s < PL_bufend && isSPACE(*s)) {
8837 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8838 /* ${foo[0]} and ${foo{bar}} notation. */
8839 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8840 const char * const brack =
8842 ((*s == '[') ? "[...]" : "{...}");
8843 orig_copline = CopLINE(PL_curcop);
8844 CopLINE_set(PL_curcop, tmp_copline);
8845 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8846 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8847 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8848 funny, dest, brack, funny, dest, brack);
8849 CopLINE_set(PL_curcop, orig_copline);
8852 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8853 PL_lex_allbrackets++;
8857 /* Handle extended ${^Foo} variables
8858 * 1999-02-27 mjd-perl-patch@plover.com */
8859 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8863 while (isWORDCHAR(*s) && d < e) {
8867 Perl_croak(aTHX_ "%s", ident_too_long);
8872 tmp_copline = CopLINE(PL_curcop);
8873 if (s < PL_bufend && isSPACE(*s)) {
8877 /* Expect to find a closing } after consuming any trailing whitespace.
8881 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8882 PL_lex_state = LEX_INTERPEND;
8885 if (PL_lex_state == LEX_NORMAL) {
8886 if (ckWARN(WARN_AMBIGUOUS)
8887 && (keyword(dest, d - dest, 0)
8888 || get_cvn_flags(dest, d - dest, is_utf8
8892 SV *tmp = newSVpvn_flags( dest, d - dest,
8893 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8896 orig_copline = CopLINE(PL_curcop);
8897 CopLINE_set(PL_curcop, tmp_copline);
8898 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8899 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8900 funny, SVfARG(tmp), funny, SVfARG(tmp));
8901 CopLINE_set(PL_curcop, orig_copline);
8906 /* Didn't find the closing } at the point we expected, so restore
8907 state such that the next thing to process is the opening { and */
8908 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8909 CopLINE_set(PL_curcop, orig_copline);
8910 PL_parser->herelines = herelines;
8914 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8915 PL_lex_state = LEX_INTERPEND;
8920 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8922 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8923 * found in the parse starting at 's', based on the subset that are valid
8924 * in this context input to this routine in 'valid_flags'. Advances s.
8925 * Returns TRUE if the input should be treated as a valid flag, so the next
8926 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8927 * upon first call on the current regex. This routine will set it to any
8928 * charset modifier found. The caller shouldn't change it. This way,
8929 * another charset modifier encountered in the parse can be detected as an
8930 * error, as we have decided to allow only one */
8933 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8935 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8936 if (isWORDCHAR_lazy_if(*s, UTF)) {
8937 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8938 UTF ? SVf_UTF8 : 0);
8940 /* Pretend that it worked, so will continue processing before
8949 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8950 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8951 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8952 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8953 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8954 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8955 case LOCALE_PAT_MOD:
8957 goto multiple_charsets;
8959 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8962 case UNICODE_PAT_MOD:
8964 goto multiple_charsets;
8966 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8969 case ASCII_RESTRICT_PAT_MOD:
8971 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8975 /* Error if previous modifier wasn't an 'a', but if it was, see
8976 * if, and accept, a second occurrence (only) */
8978 || get_regex_charset(*pmfl)
8979 != REGEX_ASCII_RESTRICTED_CHARSET)
8981 goto multiple_charsets;
8983 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8987 case DEPENDS_PAT_MOD:
8989 goto multiple_charsets;
8991 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9000 if (*charset != c) {
9001 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9003 else if (c == 'a') {
9004 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9005 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9008 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9011 /* Pretend that it worked, so will continue processing before dieing */
9017 S_scan_pat(pTHX_ char *start, I32 type)
9021 const char * const valid_flags =
9022 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9023 char charset = '\0'; /* character set modifier */
9024 unsigned int x_mod_count = 0;
9026 PERL_ARGS_ASSERT_SCAN_PAT;
9028 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9030 Perl_croak(aTHX_ "Search pattern not terminated");
9032 pm = (PMOP*)newPMOP(type, 0);
9033 if (PL_multi_open == '?') {
9034 /* This is the only point in the code that sets PMf_ONCE: */
9035 pm->op_pmflags |= PMf_ONCE;
9037 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9038 allows us to restrict the list needed by reset to just the ??
9040 assert(type != OP_TRANS);
9042 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9045 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9048 elements = mg->mg_len / sizeof(PMOP**);
9049 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9050 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9051 mg->mg_len = elements * sizeof(PMOP**);
9052 PmopSTASH_set(pm,PL_curstash);
9056 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9057 * anon CV. False positives like qr/[(?{]/ are harmless */
9059 if (type == OP_QR) {
9061 char *e, *p = SvPV(PL_lex_stuff, len);
9063 for (; p < e; p++) {
9064 if (p[0] == '(' && p[1] == '?'
9065 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9067 pm->op_pmflags |= PMf_HAS_CV;
9071 pm->op_pmflags |= PMf_IS_QR;
9074 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9075 &s, &charset, &x_mod_count))
9077 /* issue a warning if /c is specified,but /g is not */
9078 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9080 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9081 "Use of /c modifier is meaningless without /g" );
9084 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9086 PL_lex_op = (OP*)pm;
9087 pl_yylval.ival = OP_MATCH;
9092 S_scan_subst(pTHX_ char *start)
9099 char charset = '\0'; /* character set modifier */
9100 unsigned int x_mod_count = 0;
9103 PERL_ARGS_ASSERT_SCAN_SUBST;
9105 pl_yylval.ival = OP_NULL;
9107 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9110 Perl_croak(aTHX_ "Substitution pattern not terminated");
9114 first_start = PL_multi_start;
9115 first_line = CopLINE(PL_curcop);
9116 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9118 SvREFCNT_dec_NN(PL_lex_stuff);
9119 PL_lex_stuff = NULL;
9120 Perl_croak(aTHX_ "Substitution replacement not terminated");
9122 PL_multi_start = first_start; /* so whole substitution is taken together */
9124 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9128 if (*s == EXEC_PAT_MOD) {
9132 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9133 &s, &charset, &x_mod_count))
9139 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9141 if ((pm->op_pmflags & PMf_CONTINUE)) {
9142 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9146 SV * const repl = newSVpvs("");
9149 pm->op_pmflags |= PMf_EVAL;
9152 sv_catpvs(repl, "eval ");
9154 sv_catpvs(repl, "do ");
9156 sv_catpvs(repl, "{");
9157 sv_catsv(repl, PL_sublex_info.repl);
9158 sv_catpvs(repl, "}");
9160 SvREFCNT_dec(PL_sublex_info.repl);
9161 PL_sublex_info.repl = repl;
9163 if (CopLINE(PL_curcop) != first_line) {
9164 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9165 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9166 CopLINE(PL_curcop) - first_line;
9167 CopLINE_set(PL_curcop, first_line);
9170 PL_lex_op = (OP*)pm;
9171 pl_yylval.ival = OP_SUBST;
9176 S_scan_trans(pTHX_ char *start)
9183 bool nondestruct = 0;
9186 PERL_ARGS_ASSERT_SCAN_TRANS;
9188 pl_yylval.ival = OP_NULL;
9190 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9192 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9196 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9198 SvREFCNT_dec_NN(PL_lex_stuff);
9199 PL_lex_stuff = NULL;
9200 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9203 complement = del = squash = 0;
9207 complement = OPpTRANS_COMPLEMENT;
9210 del = OPpTRANS_DELETE;
9213 squash = OPpTRANS_SQUASH;
9225 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9226 o->op_private &= ~OPpTRANS_ALL;
9227 o->op_private |= del|squash|complement|
9228 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9229 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9232 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9239 Takes a pointer to the first < in <<FOO.
9240 Returns a pointer to the byte following <<FOO.
9242 This function scans a heredoc, which involves different methods
9243 depending on whether we are in a string eval, quoted construct, etc.
9244 This is because PL_linestr could containing a single line of input, or
9245 a whole string being evalled, or the contents of the current quote-
9248 The two basic methods are:
9249 - Steal lines from the input stream
9250 - Scan the heredoc in PL_linestr and remove it therefrom
9252 In a file scope or filtered eval, the first method is used; in a
9253 string eval, the second.
9255 In a quote-like operator, we have to choose between the two,
9256 depending on where we can find a newline. We peek into outer lex-
9257 ing scopes until we find one with a newline in it. If we reach the
9258 outermost lexing scope and it is a file, we use the stream method.
9259 Otherwise it is treated as an eval.
9263 S_scan_heredoc(pTHX_ char *s)
9265 I32 op_type = OP_SCALAR;
9272 const bool infile = PL_rsfp || PL_parser->filtered;
9273 const line_t origline = CopLINE(PL_curcop);
9274 LEXSHARED *shared = PL_parser->lex_shared;
9276 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9279 d = PL_tokenbuf + 1;
9280 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9281 *PL_tokenbuf = '\n';
9283 while (SPACE_OR_TAB(*peek))
9285 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9288 s = delimcpy(d, e, s, PL_bufend, term, &len);
9290 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9296 /* <<\FOO is equivalent to <<'FOO' */
9300 if (!isWORDCHAR_lazy_if(s,UTF))
9301 deprecate("bare << to mean <<\"\"");
9303 while (isWORDCHAR_lazy_if(peek,UTF)) {
9304 peek += UTF ? UTF8SKIP(peek) : 1;
9306 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9307 Copy(s, d, len, char);
9311 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9312 Perl_croak(aTHX_ "Delimiter for here document is too long");
9315 len = d - PL_tokenbuf;
9317 #ifndef PERL_STRICT_CR
9318 d = strchr(s, '\r');
9320 char * const olds = s;
9322 while (s < PL_bufend) {
9328 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9337 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9342 tmpstr = newSV_type(SVt_PVIV);
9346 SvIV_set(tmpstr, -1);
9348 else if (term == '`') {
9349 op_type = OP_BACKTICK;
9350 SvIV_set(tmpstr, '\\');
9353 PL_multi_start = origline + 1 + PL_parser->herelines;
9354 PL_multi_open = PL_multi_close = '<';
9355 /* inside a string eval or quote-like operator */
9356 if (!infile || PL_lex_inwhat) {
9359 char * const olds = s;
9360 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9361 /* These two fields are not set until an inner lexing scope is
9362 entered. But we need them set here. */
9363 shared->ls_bufptr = s;
9364 shared->ls_linestr = PL_linestr;
9366 /* Look for a newline. If the current buffer does not have one,
9367 peek into the line buffer of the parent lexing scope, going
9368 up as many levels as necessary to find one with a newline
9371 while (!(s = (char *)memchr(
9372 (void *)shared->ls_bufptr, '\n',
9373 SvEND(shared->ls_linestr)-shared->ls_bufptr
9375 shared = shared->ls_prev;
9376 /* shared is only null if we have gone beyond the outermost
9377 lexing scope. In a file, we will have broken out of the
9378 loop in the previous iteration. In an eval, the string buf-
9379 fer ends with "\n;", so the while condition above will have
9380 evaluated to false. So shared can never be null. Or so you
9381 might think. Odd syntax errors like s;@{<<; can gobble up
9382 the implicit semicolon at the end of a flie, causing the
9383 file handle to be closed even when we are not in a string
9384 eval. So shared may be null in that case. */
9385 if (UNLIKELY(!shared))
9387 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9388 most lexing scope. In a file, shared->ls_linestr at that
9389 level is just one line, so there is no body to steal. */
9390 if (infile && !shared->ls_prev) {
9396 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9399 linestr = shared->ls_linestr;
9400 bufend = SvEND(linestr);
9402 while (s < bufend - len + 1
9403 && memNE(s,PL_tokenbuf,len) )
9406 ++PL_parser->herelines;
9408 if (s >= bufend - len + 1) {
9411 sv_setpvn(tmpstr,d+1,s-d);
9413 /* the preceding stmt passes a newline */
9414 PL_parser->herelines++;
9416 /* s now points to the newline after the heredoc terminator.
9417 d points to the newline before the body of the heredoc.
9420 /* We are going to modify linestr in place here, so set
9421 aside copies of the string if necessary for re-evals or
9423 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9424 check shared->re_eval_str. */
9425 if (shared->re_eval_start || shared->re_eval_str) {
9426 /* Set aside the rest of the regexp */
9427 if (!shared->re_eval_str)
9428 shared->re_eval_str =
9429 newSVpvn(shared->re_eval_start,
9430 bufend - shared->re_eval_start);
9431 shared->re_eval_start -= s-d;
9434 && CxTYPE(cx) == CXt_EVAL
9435 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
9436 && cx->blk_eval.cur_text == linestr)
9438 cx->blk_eval.cur_text = newSVsv(linestr);
9439 SvSCREAM_on(cx->blk_eval.cur_text);
9441 /* Copy everything from s onwards back to d. */
9442 Move(s,d,bufend-s + 1,char);
9443 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9444 /* Setting PL_bufend only applies when we have not dug deeper
9445 into other scopes, because sublex_done sets PL_bufend to
9446 SvEND(PL_linestr). */
9447 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9454 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9455 term = PL_tokenbuf[1];
9457 linestr_save = PL_linestr; /* must restore this afterwards */
9458 d = s; /* and this */
9459 PL_linestr = newSVpvs("");
9460 PL_bufend = SvPVX(PL_linestr);
9462 PL_bufptr = PL_bufend;
9463 CopLINE_set(PL_curcop,
9464 origline + 1 + PL_parser->herelines);
9465 if (!lex_next_chunk(LEX_NO_TERM)
9466 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9467 /* Simply freeing linestr_save might seem simpler here, as it
9468 does not matter what PL_linestr points to, since we are
9469 about to croak; but in a quote-like op, linestr_save
9470 will have been prospectively freed already, via
9471 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9472 restore PL_linestr. */
9473 SvREFCNT_dec_NN(PL_linestr);
9474 PL_linestr = linestr_save;
9477 CopLINE_set(PL_curcop, origline);
9478 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9479 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9480 /* ^That should be enough to avoid this needing to grow: */
9481 sv_catpvs(PL_linestr, "\n\0");
9482 assert(s == SvPVX(PL_linestr));
9483 PL_bufend = SvEND(PL_linestr);
9486 PL_parser->herelines++;
9487 PL_last_lop = PL_last_uni = NULL;
9488 #ifndef PERL_STRICT_CR
9489 if (PL_bufend - PL_linestart >= 2) {
9490 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
9491 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9493 PL_bufend[-2] = '\n';
9495 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9497 else if (PL_bufend[-1] == '\r')
9498 PL_bufend[-1] = '\n';
9500 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9501 PL_bufend[-1] = '\n';
9503 if (*s == term && PL_bufend-s >= len
9504 && memEQ(s,PL_tokenbuf + 1,len)) {
9505 SvREFCNT_dec(PL_linestr);
9506 PL_linestr = linestr_save;
9507 PL_linestart = SvPVX(linestr_save);
9508 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9513 sv_catsv(tmpstr,PL_linestr);
9517 PL_multi_end = origline + PL_parser->herelines;
9518 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9519 SvPV_shrink_to_cur(tmpstr);
9522 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9524 else if (IN_ENCODING)
9525 sv_recode_to_utf8(tmpstr, _get_encoding());
9527 PL_lex_stuff = tmpstr;
9528 pl_yylval.ival = op_type;
9532 SvREFCNT_dec(tmpstr);
9533 CopLINE_set(PL_curcop, origline);
9534 missingterm(PL_tokenbuf + 1);
9538 takes: current position in input buffer
9539 returns: new position in input buffer
9540 side-effects: pl_yylval and lex_op are set.
9545 <<>> read from ARGV without magic open
9546 <FH> read from filehandle
9547 <pkg::FH> read from package qualified filehandle
9548 <pkg'FH> read from package qualified filehandle
9549 <$fh> read from filehandle in $fh
9555 S_scan_inputsymbol(pTHX_ char *start)
9557 char *s = start; /* current position in buffer */
9560 bool nomagicopen = FALSE;
9561 char *d = PL_tokenbuf; /* start of temp holding space */
9562 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9564 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9566 end = strchr(s, '\n');
9569 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9576 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9578 /* die if we didn't have space for the contents of the <>,
9579 or if it didn't end, or if we see a newline
9582 if (len >= (I32)sizeof PL_tokenbuf)
9583 Perl_croak(aTHX_ "Excessively long <> operator");
9585 Perl_croak(aTHX_ "Unterminated <> operator");
9590 Remember, only scalar variables are interpreted as filehandles by
9591 this code. Anything more complex (e.g., <$fh{$num}>) will be
9592 treated as a glob() call.
9593 This code makes use of the fact that except for the $ at the front,
9594 a scalar variable and a filehandle look the same.
9596 if (*d == '$' && d[1]) d++;
9598 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9599 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9600 d += UTF ? UTF8SKIP(d) : 1;
9602 /* If we've tried to read what we allow filehandles to look like, and
9603 there's still text left, then it must be a glob() and not a getline.
9604 Use scan_str to pull out the stuff between the <> and treat it
9605 as nothing more than a string.
9608 if (d - PL_tokenbuf != len) {
9609 pl_yylval.ival = OP_GLOB;
9610 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9612 Perl_croak(aTHX_ "Glob not terminated");
9616 bool readline_overriden = FALSE;
9618 /* we're in a filehandle read situation */
9621 /* turn <> into <ARGV> */
9623 Copy("ARGV",d,5,char);
9625 /* Check whether readline() is overriden */
9626 if ((gv_readline = gv_override("readline",8)))
9627 readline_overriden = TRUE;
9629 /* if <$fh>, create the ops to turn the variable into a
9633 /* try to find it in the pad for this block, otherwise find
9634 add symbol table ops
9636 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9637 if (tmp != NOT_IN_PAD) {
9638 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9639 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9640 HEK * const stashname = HvNAME_HEK(stash);
9641 SV * const sym = sv_2mortal(newSVhek(stashname));
9642 sv_catpvs(sym, "::");
9648 OP * const o = newOP(OP_PADSV, 0);
9650 PL_lex_op = readline_overriden
9651 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9652 op_append_elem(OP_LIST, o,
9653 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9654 : (OP*)newUNOP(OP_READLINE, 0, o);
9662 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9664 PL_lex_op = readline_overriden
9665 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9666 op_append_elem(OP_LIST,
9667 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9668 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9669 : (OP*)newUNOP(OP_READLINE, 0,
9670 newUNOP(OP_RV2SV, 0,
9671 newGVOP(OP_GV, 0, gv)));
9673 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9674 pl_yylval.ival = OP_NULL;
9677 /* If it's none of the above, it must be a literal filehandle
9678 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9680 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9681 PL_lex_op = readline_overriden
9682 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9683 op_append_elem(OP_LIST,
9684 newGVOP(OP_GV, 0, gv),
9685 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9686 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9687 pl_yylval.ival = OP_NULL;
9697 start position in buffer
9698 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9699 only if they are of the open/close form
9700 keep_delims preserve the delimiters around the string
9701 re_reparse compiling a run-time /(?{})/:
9702 collapse // to /, and skip encoding src
9703 delimp if non-null, this is set to the position of
9704 the closing delimiter, or just after it if
9705 the closing and opening delimiters differ
9706 (i.e., the opening delimiter of a substitu-
9708 returns: position to continue reading from buffer
9709 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9710 updates the read buffer.
9712 This subroutine pulls a string out of the input. It is called for:
9713 q single quotes q(literal text)
9714 ' single quotes 'literal text'
9715 qq double quotes qq(interpolate $here please)
9716 " double quotes "interpolate $here please"
9717 qx backticks qx(/bin/ls -l)
9718 ` backticks `/bin/ls -l`
9719 qw quote words @EXPORT_OK = qw( func() $spam )
9720 m// regexp match m/this/
9721 s/// regexp substitute s/this/that/
9722 tr/// string transliterate tr/this/that/
9723 y/// string transliterate y/this/that/
9724 ($*@) sub prototypes sub foo ($)
9725 (stuff) sub attr parameters sub foo : attr(stuff)
9726 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9728 In most of these cases (all but <>, patterns and transliterate)
9729 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9730 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9731 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9734 It skips whitespace before the string starts, and treats the first
9735 character as the delimiter. If the delimiter is one of ([{< then
9736 the corresponding "close" character )]}> is used as the closing
9737 delimiter. It allows quoting of delimiters, and if the string has
9738 balanced delimiters ([{<>}]) it allows nesting.
9740 On success, the SV with the resulting string is put into lex_stuff or,
9741 if that is already non-NULL, into lex_repl. The second case occurs only
9742 when parsing the RHS of the special constructs s/// and tr/// (y///).
9743 For convenience, the terminating delimiter character is stuffed into
9748 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9752 SV *sv; /* scalar value: string */
9753 const char *tmps; /* temp string, used for delimiter matching */
9754 char *s = start; /* current position in the buffer */
9755 char term; /* terminating character */
9756 char *to; /* current position in the sv's data */
9757 I32 brackets = 1; /* bracket nesting level */
9758 bool has_utf8 = FALSE; /* is there any utf8 content? */
9759 I32 termcode; /* terminating char. code */
9760 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9761 STRLEN termlen; /* length of terminating string */
9762 int last_off = 0; /* last position for nesting bracket */
9765 PERL_ARGS_ASSERT_SCAN_STR;
9767 /* skip space before the delimiter */
9772 /* mark where we are, in case we need to report errors */
9775 /* after skipping whitespace, the next character is the terminator */
9778 termcode = termstr[0] = term;
9782 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9783 Copy(s, termstr, termlen, U8);
9784 if (!UTF8_IS_INVARIANT(term))
9788 /* mark where we are */
9789 PL_multi_start = CopLINE(PL_curcop);
9790 PL_multi_open = term;
9791 herelines = PL_parser->herelines;
9793 /* find corresponding closing delimiter */
9794 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9795 termcode = termstr[0] = term = tmps[5];
9797 PL_multi_close = term;
9799 if (PL_multi_open == PL_multi_close) {
9800 keep_bracketed_quoted = FALSE;
9803 /* create a new SV to hold the contents. 79 is the SV's initial length.
9804 What a random number. */
9805 sv = newSV_type(SVt_PVIV);
9807 SvIV_set(sv, termcode);
9808 (void)SvPOK_only(sv); /* validate pointer */
9810 /* move past delimiter and try to read a complete string */
9812 sv_catpvn(sv, s, termlen);
9815 if (IN_ENCODING && !UTF && !re_reparse) {
9819 int offset = s - SvPVX_const(PL_linestr);
9820 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9821 &offset, (char*)termstr, termlen);
9825 if (SvIsCOW(PL_linestr)) {
9826 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9827 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9828 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9829 char *buf = SvPVX(PL_linestr);
9830 bufend_pos = PL_parser->bufend - buf;
9831 bufptr_pos = PL_parser->bufptr - buf;
9832 oldbufptr_pos = PL_parser->oldbufptr - buf;
9833 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9834 linestart_pos = PL_parser->linestart - buf;
9835 last_uni_pos = PL_parser->last_uni
9836 ? PL_parser->last_uni - buf
9838 last_lop_pos = PL_parser->last_lop
9839 ? PL_parser->last_lop - buf
9842 PL_parser->lex_shared->re_eval_start ?
9843 PL_parser->lex_shared->re_eval_start - buf : 0;
9846 sv_force_normal(PL_linestr);
9848 buf = SvPVX(PL_linestr);
9849 PL_parser->bufend = buf + bufend_pos;
9850 PL_parser->bufptr = buf + bufptr_pos;
9851 PL_parser->oldbufptr = buf + oldbufptr_pos;
9852 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9853 PL_parser->linestart = buf + linestart_pos;
9854 if (PL_parser->last_uni)
9855 PL_parser->last_uni = buf + last_uni_pos;
9856 if (PL_parser->last_lop)
9857 PL_parser->last_lop = buf + last_lop_pos;
9858 if (PL_parser->lex_shared->re_eval_start)
9859 PL_parser->lex_shared->re_eval_start =
9860 buf + re_eval_start_pos;
9863 ns = SvPVX_const(PL_linestr) + offset;
9864 svlast = SvEND(sv) - 1;
9866 for (; s < ns; s++) {
9867 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9868 COPLINE_INC_WITH_HERELINES;
9871 goto read_more_line;
9873 /* handle quoted delimiters */
9874 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9876 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9878 if ((svlast-1 - t) % 2) {
9879 if (!keep_bracketed_quoted) {
9882 SvCUR_set(sv, SvCUR(sv) - 1);
9887 if (PL_multi_open == PL_multi_close) {
9893 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9894 /* At here, all closes are "was quoted" one,
9895 so we don't check PL_multi_close. */
9897 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9902 else if (*t == PL_multi_open)
9910 SvCUR_set(sv, w - SvPVX_const(sv));
9912 last_off = w - SvPVX(sv);
9913 if (--brackets <= 0)
9919 SvCUR_set(sv, SvCUR(sv) - 1);
9925 /* extend sv if need be */
9926 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9927 /* set 'to' to the next character in the sv's string */
9928 to = SvPVX(sv)+SvCUR(sv);
9930 /* if open delimiter is the close delimiter read unbridle */
9931 if (PL_multi_open == PL_multi_close) {
9932 for (; s < PL_bufend; s++,to++) {
9933 /* embedded newlines increment the current line number */
9934 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9935 COPLINE_INC_WITH_HERELINES;
9936 /* handle quoted delimiters */
9937 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9938 if (!keep_bracketed_quoted
9940 || (re_reparse && s[1] == '\\'))
9943 else /* any other quotes are simply copied straight through */
9946 /* terminate when run out of buffer (the for() condition), or
9947 have found the terminator */
9948 else if (*s == term) {
9951 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9954 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9960 /* if the terminator isn't the same as the start character (e.g.,
9961 matched brackets), we have to allow more in the quoting, and
9962 be prepared for nested brackets.
9965 /* read until we run out of string, or we find the terminator */
9966 for (; s < PL_bufend; s++,to++) {
9967 /* embedded newlines increment the line count */
9968 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9969 COPLINE_INC_WITH_HERELINES;
9970 /* backslashes can escape the open or closing characters */
9971 if (*s == '\\' && s+1 < PL_bufend) {
9972 if (!keep_bracketed_quoted
9973 && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9980 /* allow nested opens and closes */
9981 else if (*s == PL_multi_close && --brackets <= 0)
9983 else if (*s == PL_multi_open)
9985 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9990 /* terminate the copied string and update the sv's end-of-string */
9992 SvCUR_set(sv, to - SvPVX_const(sv));
9995 * this next chunk reads more into the buffer if we're not done yet
9999 break; /* handle case where we are done yet :-) */
10001 #ifndef PERL_STRICT_CR
10002 if (to - SvPVX_const(sv) >= 2) {
10003 if ( (to[-2] == '\r' && to[-1] == '\n')
10004 || (to[-2] == '\n' && to[-1] == '\r'))
10008 SvCUR_set(sv, to - SvPVX_const(sv));
10010 else if (to[-1] == '\r')
10013 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10018 /* if we're out of file, or a read fails, bail and reset the current
10019 line marker so we can report where the unterminated string began
10021 COPLINE_INC_WITH_HERELINES;
10022 PL_bufptr = PL_bufend;
10023 if (!lex_next_chunk(0)) {
10025 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10031 /* at this point, we have successfully read the delimited string */
10033 if (!IN_ENCODING || UTF || re_reparse) {
10036 sv_catpvn(sv, s, termlen);
10039 if (has_utf8 || (IN_ENCODING && !re_reparse))
10042 PL_multi_end = CopLINE(PL_curcop);
10043 CopLINE_set(PL_curcop, PL_multi_start);
10044 PL_parser->herelines = herelines;
10046 /* if we allocated too much space, give some back */
10047 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10048 SvLEN_set(sv, SvCUR(sv) + 1);
10049 SvPV_renew(sv, SvLEN(sv));
10052 /* decide whether this is the first or second quoted string we've read
10057 PL_sublex_info.repl = sv;
10060 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10066 takes: pointer to position in buffer
10067 returns: pointer to new position in buffer
10068 side-effects: builds ops for the constant in pl_yylval.op
10070 Read a number in any of the formats that Perl accepts:
10072 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10073 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10074 0b[01](_?[01])* binary integers
10075 0[0-7](_?[0-7])* octal integers
10076 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10077 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10079 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10082 If it reads a number without a decimal point or an exponent, it will
10083 try converting the number to an integer and see if it can do so
10084 without loss of precision.
10088 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10090 const char *s = start; /* current position in buffer */
10091 char *d; /* destination in temp buffer */
10092 char *e; /* end of temp buffer */
10093 NV nv; /* number read, as a double */
10094 SV *sv = NULL; /* place to put the converted number */
10095 bool floatit; /* boolean: int or float? */
10096 const char *lastub = NULL; /* position of last underbar */
10097 static const char* const number_too_long = "Number too long";
10098 /* Hexadecimal floating point.
10100 * In many places (where we have quads and NV is IEEE 754 double)
10101 * we can fit the mantissa bits of a NV into an unsigned quad.
10102 * (Note that UVs might not be quads even when we have quads.)
10103 * This will not work everywhere, though (either no quads, or
10104 * using long doubles), in which case we have to resort to NV,
10105 * which will probably mean horrible loss of precision due to
10106 * multiple fp operations. */
10107 bool hexfp = FALSE;
10108 int total_bits = 0;
10109 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10110 # define HEXFP_UQUAD
10111 Uquad_t hexfp_uquad = 0;
10112 int hexfp_frac_bits = 0;
10117 NV hexfp_mult = 1.0;
10118 UV high_non_zero = 0; /* highest digit */
10120 PERL_ARGS_ASSERT_SCAN_NUM;
10122 /* We use the first character to decide what type of number this is */
10126 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10128 /* if it starts with a 0, it could be an octal number, a decimal in
10129 0.13 disguise, or a hexadecimal number, or a binary number. */
10133 u holds the "number so far"
10134 shift the power of 2 of the base
10135 (hex == 4, octal == 3, binary == 1)
10136 overflowed was the number more than we can hold?
10138 Shift is used when we add a digit. It also serves as an "are
10139 we in octal/hex/binary?" indicator to disallow hex characters
10140 when in octal mode.
10145 bool overflowed = FALSE;
10146 bool just_zero = TRUE; /* just plain 0 or binary number? */
10147 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10148 static const char* const bases[5] =
10149 { "", "binary", "", "octal", "hexadecimal" };
10150 static const char* const Bases[5] =
10151 { "", "Binary", "", "Octal", "Hexadecimal" };
10152 static const char* const maxima[5] =
10154 "0b11111111111111111111111111111111",
10158 const char *base, *Base, *max;
10160 /* check for hex */
10161 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10165 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10170 /* check for a decimal in disguise */
10171 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10173 /* so it must be octal */
10180 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10181 "Misplaced _ in number");
10185 base = bases[shift];
10186 Base = Bases[shift];
10187 max = maxima[shift];
10189 /* read the rest of the number */
10191 /* x is used in the overflow test,
10192 b is the digit we're adding on. */
10197 /* if we don't mention it, we're done */
10201 /* _ are ignored -- but warned about if consecutive */
10203 if (lastub && s == lastub + 1)
10204 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10205 "Misplaced _ in number");
10209 /* 8 and 9 are not octal */
10210 case '8': case '9':
10212 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10216 case '2': case '3': case '4':
10217 case '5': case '6': case '7':
10219 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10222 case '0': case '1':
10223 b = *s++ & 15; /* ASCII digit -> value of digit */
10227 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10228 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10229 /* make sure they said 0x */
10232 b = (*s++ & 7) + 9;
10234 /* Prepare to put the digit we have onto the end
10235 of the number so far. We check for overflows.
10241 x = u << shift; /* make room for the digit */
10243 total_bits += shift;
10245 if ((x >> shift) != u
10246 && !(PL_hints & HINT_NEW_BINARY)) {
10249 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10250 "Integer overflow in %s number",
10253 u = x | b; /* add the digit to the end */
10256 n *= nvshift[shift];
10257 /* If an NV has not enough bits in its
10258 * mantissa to represent an UV this summing of
10259 * small low-order numbers is a waste of time
10260 * (because the NV cannot preserve the
10261 * low-order bits anyway): we could just
10262 * remember when did we overflow and in the
10263 * end just multiply n by the right
10268 if (high_non_zero == 0 && b > 0)
10271 /* this could be hexfp, but peek ahead
10272 * to avoid matching ".." */
10273 if (UNLIKELY(HEXFP_PEEK(s))) {
10281 /* if we get here, we had success: make a scalar value from
10286 /* final misplaced underbar check */
10287 if (s[-1] == '_') {
10288 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10291 if (UNLIKELY(HEXFP_PEEK(s))) {
10292 /* Do sloppy (on the underbars) but quick detection
10293 * (and value construction) for hexfp, the decimal
10294 * detection will shortly be more thorough with the
10295 * underbar checks. */
10299 #else /* HEXFP_NV */
10304 NV mult = 1 / 16.0;
10307 while (isXDIGIT(*h) || *h == '_') {
10308 if (isXDIGIT(*h)) {
10309 U8 b = XDIGIT_VALUE(*h);
10310 total_bits += shift;
10312 hexfp_uquad <<= shift;
10314 hexfp_frac_bits += shift;
10315 #else /* HEXFP_NV */
10316 hexfp_nv += b * mult;
10324 if (total_bits >= 4) {
10325 if (high_non_zero < 0x8)
10327 if (high_non_zero < 0x4)
10329 if (high_non_zero < 0x2)
10333 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10334 bool negexp = FALSE;
10338 else if (*h == '-') {
10344 while (isDIGIT(*h) || *h == '_') {
10347 hexfp_exp += *h - '0';
10350 && -hexfp_exp < NV_MIN_EXP - 1) {
10351 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10352 "Hexadecimal float: exponent underflow");
10358 && hexfp_exp > NV_MAX_EXP - 1) {
10359 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10360 "Hexadecimal float: exponent overflow");
10368 hexfp_exp = -hexfp_exp;
10370 hexfp_exp -= hexfp_frac_bits;
10372 hexfp_mult = pow(2.0, hexfp_exp);
10380 if (n > 4294967295.0)
10381 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10382 "%s number > %s non-portable",
10388 if (u > 0xffffffff)
10389 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10390 "%s number > %s non-portable",
10395 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10396 sv = new_constant(start, s - start, "integer",
10397 sv, NULL, NULL, 0);
10398 else if (PL_hints & HINT_NEW_BINARY)
10399 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10404 handle decimal numbers.
10405 we're also sent here when we read a 0 as the first digit
10407 case '1': case '2': case '3': case '4': case '5':
10408 case '6': case '7': case '8': case '9': case '.':
10411 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10420 /* read next group of digits and _ and copy into d */
10423 || UNLIKELY(hexfp && isXDIGIT(*s)))
10425 /* skip underscores, checking for misplaced ones
10429 if (lastub && s == lastub + 1)
10430 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10431 "Misplaced _ in number");
10435 /* check for end of fixed-length buffer */
10437 Perl_croak(aTHX_ "%s", number_too_long);
10438 /* if we're ok, copy the character */
10443 /* final misplaced underbar check */
10444 if (lastub && s == lastub + 1) {
10445 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10448 /* read a decimal portion if there is one. avoid
10449 3..5 being interpreted as the number 3. followed
10452 if (*s == '.' && s[1] != '.') {
10457 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10458 "Misplaced _ in number");
10462 /* copy, ignoring underbars, until we run out of digits.
10466 || UNLIKELY(hexfp && isXDIGIT(*s));
10469 /* fixed length buffer check */
10471 Perl_croak(aTHX_ "%s", number_too_long);
10473 if (lastub && s == lastub + 1)
10474 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10475 "Misplaced _ in number");
10481 /* fractional part ending in underbar? */
10482 if (s[-1] == '_') {
10483 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10484 "Misplaced _ in number");
10486 if (*s == '.' && isDIGIT(s[1])) {
10487 /* oops, it's really a v-string, but without the "v" */
10493 /* read exponent part, if present */
10494 if ((isALPHA_FOLD_EQ(*s, 'e')
10495 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10496 && strchr("+-0123456789_", s[1]))
10500 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10501 ditto for p (hexfloats) */
10502 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10503 /* At least some Mach atof()s don't grok 'E' */
10506 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10513 /* stray preinitial _ */
10515 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10516 "Misplaced _ in number");
10520 /* allow positive or negative exponent */
10521 if (*s == '+' || *s == '-')
10524 /* stray initial _ */
10526 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10527 "Misplaced _ in number");
10531 /* read digits of exponent */
10532 while (isDIGIT(*s) || *s == '_') {
10535 Perl_croak(aTHX_ "%s", number_too_long);
10539 if (((lastub && s == lastub + 1)
10540 || (!isDIGIT(s[1]) && s[1] != '_')))
10541 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10542 "Misplaced _ in number");
10550 We try to do an integer conversion first if no characters
10551 indicating "float" have been found.
10556 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10558 if (flags == IS_NUMBER_IN_UV) {
10560 sv = newSViv(uv); /* Prefer IVs over UVs. */
10563 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10564 if (uv <= (UV) IV_MIN)
10565 sv = newSViv(-(IV)uv);
10572 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10573 /* terminate the string */
10575 if (UNLIKELY(hexfp)) {
10576 # ifdef NV_MANT_DIG
10577 if (total_bits > NV_MANT_DIG)
10578 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10579 "Hexadecimal float: mantissa overflow");
10582 nv = hexfp_uquad * hexfp_mult;
10583 #else /* HEXFP_NV */
10584 nv = hexfp_nv * hexfp_mult;
10587 nv = Atof(PL_tokenbuf);
10589 RESTORE_LC_NUMERIC_UNDERLYING();
10594 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10595 const char *const key = floatit ? "float" : "integer";
10596 const STRLEN keylen = floatit ? 5 : 7;
10597 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10598 key, keylen, sv, NULL, NULL, 0);
10602 /* if it starts with a v, it could be a v-string */
10605 sv = newSV(5); /* preallocate storage space */
10606 ENTER_with_name("scan_vstring");
10608 s = scan_vstring(s, PL_bufend, sv);
10609 SvREFCNT_inc_simple_void_NN(sv);
10610 LEAVE_with_name("scan_vstring");
10614 /* make the op for the constant and return */
10617 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10619 lvalp->opval = NULL;
10625 S_scan_formline(pTHX_ char *s)
10629 SV * const stuff = newSVpvs("");
10630 bool needargs = FALSE;
10631 bool eofmt = FALSE;
10633 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10635 while (!needargs) {
10638 #ifdef PERL_STRICT_CR
10639 while (SPACE_OR_TAB(*t))
10642 while (SPACE_OR_TAB(*t) || *t == '\r')
10645 if (*t == '\n' || t == PL_bufend) {
10650 eol = (char *) memchr(s,'\n',PL_bufend-s);
10654 for (t = s; t < eol; t++) {
10655 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10657 goto enough; /* ~~ must be first line in formline */
10659 if (*t == '@' || *t == '^')
10663 sv_catpvn(stuff, s, eol-s);
10664 #ifndef PERL_STRICT_CR
10665 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10666 char *end = SvPVX(stuff) + SvCUR(stuff);
10669 SvCUR_set(stuff, SvCUR(stuff) - 1);
10677 if ((PL_rsfp || PL_parser->filtered)
10678 && PL_parser->form_lex_state == LEX_NORMAL) {
10680 PL_bufptr = PL_bufend;
10681 COPLINE_INC_WITH_HERELINES;
10682 got_some = lex_next_chunk(0);
10683 CopLINE_dec(PL_curcop);
10691 if (!SvCUR(stuff) || needargs)
10692 PL_lex_state = PL_parser->form_lex_state;
10693 if (SvCUR(stuff)) {
10694 PL_expect = XSTATE;
10696 const char *s2 = s;
10697 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10701 PL_expect = XTERMBLOCK;
10702 NEXTVAL_NEXTTOKE.ival = 0;
10705 NEXTVAL_NEXTTOKE.ival = 0;
10706 force_next(FORMLBRACK);
10709 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10711 else if (IN_ENCODING)
10712 sv_recode_to_utf8(stuff, _get_encoding());
10714 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10718 SvREFCNT_dec(stuff);
10720 PL_lex_formbrack = 0;
10726 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10728 const I32 oldsavestack_ix = PL_savestack_ix;
10729 CV* const outsidecv = PL_compcv;
10731 SAVEI32(PL_subline);
10732 save_item(PL_subname);
10733 SAVESPTR(PL_compcv);
10735 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10736 CvFLAGS(PL_compcv) |= flags;
10738 PL_subline = CopLINE(PL_curcop);
10739 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10740 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10741 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10742 if (outsidecv && CvPADLIST(outsidecv))
10743 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10745 return oldsavestack_ix;
10749 S_yywarn(pTHX_ const char *const s, U32 flags)
10751 PERL_ARGS_ASSERT_YYWARN;
10753 PL_in_eval |= EVAL_WARNONLY;
10754 yyerror_pv(s, flags);
10759 Perl_yyerror(pTHX_ const char *const s)
10761 PERL_ARGS_ASSERT_YYERROR;
10762 return yyerror_pvn(s, strlen(s), 0);
10766 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10768 PERL_ARGS_ASSERT_YYERROR_PV;
10769 return yyerror_pvn(s, strlen(s), flags);
10773 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10775 const char *context = NULL;
10778 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10779 int yychar = PL_parser->yychar;
10781 PERL_ARGS_ASSERT_YYERROR_PVN;
10783 if (!yychar || (yychar == ';' && !PL_rsfp))
10784 sv_catpvs(where_sv, "at EOF");
10785 else if ( PL_oldoldbufptr
10786 && PL_bufptr > PL_oldoldbufptr
10787 && PL_bufptr - PL_oldoldbufptr < 200
10788 && PL_oldoldbufptr != PL_oldbufptr
10789 && PL_oldbufptr != PL_bufptr)
10793 The code below is removed for NetWare because it abends/crashes on NetWare
10794 when the script has error such as not having the closing quotes like:
10795 if ($var eq "value)
10796 Checking of white spaces is anyway done in NetWare code.
10799 while (isSPACE(*PL_oldoldbufptr))
10802 context = PL_oldoldbufptr;
10803 contlen = PL_bufptr - PL_oldoldbufptr;
10805 else if ( PL_oldbufptr
10806 && PL_bufptr > PL_oldbufptr
10807 && PL_bufptr - PL_oldbufptr < 200
10808 && PL_oldbufptr != PL_bufptr) {
10811 The code below is removed for NetWare because it abends/crashes on NetWare
10812 when the script has error such as not having the closing quotes like:
10813 if ($var eq "value)
10814 Checking of white spaces is anyway done in NetWare code.
10817 while (isSPACE(*PL_oldbufptr))
10820 context = PL_oldbufptr;
10821 contlen = PL_bufptr - PL_oldbufptr;
10823 else if (yychar > 255)
10824 sv_catpvs(where_sv, "next token ???");
10825 else if (yychar == YYEMPTY) {
10826 if ( PL_lex_state == LEX_NORMAL
10827 || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10828 sv_catpvs(where_sv, "at end of line");
10829 else if (PL_lex_inpat)
10830 sv_catpvs(where_sv, "within pattern");
10832 sv_catpvs(where_sv, "within string");
10835 sv_catpvs(where_sv, "next char ");
10837 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10838 else if (isPRINT_LC(yychar)) {
10839 const char string = yychar;
10840 sv_catpvn(where_sv, &string, 1);
10843 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10845 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10846 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10847 OutCopFILE(PL_curcop),
10848 (IV)(PL_parser->preambling == NOLINE
10849 ? CopLINE(PL_curcop)
10850 : PL_parser->preambling));
10852 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10853 UTF8fARG(UTF, contlen, context));
10855 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10856 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10857 Perl_sv_catpvf(aTHX_ msg,
10858 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10859 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10862 if (PL_in_eval & EVAL_WARNONLY) {
10863 PL_in_eval &= ~EVAL_WARNONLY;
10864 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10868 if (PL_error_count >= 10) {
10870 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10871 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10872 SVfARG(errsv), OutCopFILE(PL_curcop));
10874 Perl_croak(aTHX_ "%s has too many errors.\n",
10875 OutCopFILE(PL_curcop));
10878 PL_in_my_stash = NULL;
10883 S_swallow_bom(pTHX_ U8 *s)
10885 const STRLEN slen = SvCUR(PL_linestr);
10887 PERL_ARGS_ASSERT_SWALLOW_BOM;
10891 if (s[1] == 0xFE) {
10892 /* UTF-16 little-endian? (or UTF-32LE?) */
10893 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10894 /* diag_listed_as: Unsupported script encoding %s */
10895 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10896 #ifndef PERL_NO_UTF16_FILTER
10897 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10899 if (PL_bufend > (char*)s) {
10900 s = add_utf16_textfilter(s, TRUE);
10903 /* diag_listed_as: Unsupported script encoding %s */
10904 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10909 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10910 #ifndef PERL_NO_UTF16_FILTER
10911 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10913 if (PL_bufend > (char *)s) {
10914 s = add_utf16_textfilter(s, FALSE);
10917 /* diag_listed_as: Unsupported script encoding %s */
10918 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10922 case BOM_UTF8_FIRST_BYTE: {
10923 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10924 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10925 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10926 s += len + 1; /* UTF-8 */
10933 if (s[2] == 0xFE && s[3] == 0xFF) {
10934 /* UTF-32 big-endian */
10935 /* diag_listed_as: Unsupported script encoding %s */
10936 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10939 else if (s[2] == 0 && s[3] != 0) {
10942 * are a good indicator of UTF-16BE. */
10943 #ifndef PERL_NO_UTF16_FILTER
10944 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10945 s = add_utf16_textfilter(s, FALSE);
10947 /* diag_listed_as: Unsupported script encoding %s */
10948 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10955 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10958 * are a good indicator of UTF-16LE. */
10959 #ifndef PERL_NO_UTF16_FILTER
10960 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10961 s = add_utf16_textfilter(s, TRUE);
10963 /* diag_listed_as: Unsupported script encoding %s */
10964 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10972 #ifndef PERL_NO_UTF16_FILTER
10974 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10976 SV *const filter = FILTER_DATA(idx);
10977 /* We re-use this each time round, throwing the contents away before we
10979 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10980 SV *const utf8_buffer = filter;
10981 IV status = IoPAGE(filter);
10982 const bool reverse = cBOOL(IoLINES(filter));
10985 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10987 /* As we're automatically added, at the lowest level, and hence only called
10988 from this file, we can be sure that we're not called in block mode. Hence
10989 don't bother writing code to deal with block mode. */
10991 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10994 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10996 DEBUG_P(PerlIO_printf(Perl_debug_log,
10997 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10998 FPTR2DPTR(void *, S_utf16_textfilter),
10999 reverse ? 'l' : 'b', idx, maxlen, status,
11000 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11007 /* First, look in our buffer of existing UTF-8 data: */
11008 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11012 } else if (status == 0) {
11014 IoPAGE(filter) = 0;
11015 nl = SvEND(utf8_buffer);
11018 STRLEN got = nl - SvPVX(utf8_buffer);
11019 /* Did we have anything to append? */
11021 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11022 /* Everything else in this code works just fine if SVp_POK isn't
11023 set. This, however, needs it, and we need it to work, else
11024 we loop infinitely because the buffer is never consumed. */
11025 sv_chop(utf8_buffer, nl);
11029 /* OK, not a complete line there, so need to read some more UTF-16.
11030 Read an extra octect if the buffer currently has an odd number. */
11034 if (SvCUR(utf16_buffer) >= 2) {
11035 /* Location of the high octet of the last complete code point.
11036 Gosh, UTF-16 is a pain. All the benefits of variable length,
11037 *coupled* with all the benefits of partial reads and
11039 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11040 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11042 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11046 /* We have the first half of a surrogate. Read more. */
11047 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11050 status = FILTER_READ(idx + 1, utf16_buffer,
11051 160 + (SvCUR(utf16_buffer) & 1));
11052 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11053 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11056 IoPAGE(filter) = status;
11061 chars = SvCUR(utf16_buffer) >> 1;
11062 have = SvCUR(utf8_buffer);
11063 SvGROW(utf8_buffer, have + chars * 3 + 1);
11066 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11067 (U8*)SvPVX_const(utf8_buffer) + have,
11068 chars * 2, &newlen);
11070 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11071 (U8*)SvPVX_const(utf8_buffer) + have,
11072 chars * 2, &newlen);
11074 SvCUR_set(utf8_buffer, have + newlen);
11077 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11078 it's private to us, and utf16_to_utf8{,reversed} take a
11079 (pointer,length) pair, rather than a NUL-terminated string. */
11080 if(SvCUR(utf16_buffer) & 1) {
11081 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11082 SvCUR_set(utf16_buffer, 1);
11084 SvCUR_set(utf16_buffer, 0);
11087 DEBUG_P(PerlIO_printf(Perl_debug_log,
11088 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11090 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11091 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11096 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11098 SV *filter = filter_add(S_utf16_textfilter, NULL);
11100 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11102 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11103 sv_setpvs(filter, "");
11104 IoLINES(filter) = reversed;
11105 IoPAGE(filter) = 1; /* Not EOF */
11107 /* Sadly, we have to return a valid pointer, come what may, so we have to
11108 ignore any error return from this. */
11109 SvCUR_set(PL_linestr, 0);
11110 if (FILTER_READ(0, PL_linestr, 0)) {
11111 SvUTF8_on(PL_linestr);
11113 SvUTF8_on(PL_linestr);
11115 PL_bufend = SvEND(PL_linestr);
11116 return (U8*)SvPVX(PL_linestr);
11121 Returns a pointer to the next character after the parsed
11122 vstring, as well as updating the passed in sv.
11124 Function must be called like
11126 sv = sv_2mortal(newSV(5));
11127 s = scan_vstring(s,e,sv);
11129 where s and e are the start and end of the string.
11130 The sv should already be large enough to store the vstring
11131 passed in, for performance reasons.
11133 This function may croak if fatal warnings are enabled in the
11134 calling scope, hence the sv_2mortal in the example (to prevent
11135 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11141 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11143 const char *pos = s;
11144 const char *start = s;
11146 PERL_ARGS_ASSERT_SCAN_VSTRING;
11148 if (*pos == 'v') pos++; /* get past 'v' */
11149 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11151 if ( *pos != '.') {
11152 /* this may not be a v-string if followed by => */
11153 const char *next = pos;
11154 while (next < e && isSPACE(*next))
11156 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11157 /* return string not v-string */
11158 sv_setpvn(sv,(char *)s,pos-s);
11159 return (char *)pos;
11163 if (!isALPHA(*pos)) {
11164 U8 tmpbuf[UTF8_MAXBYTES+1];
11167 s++; /* get past 'v' */
11172 /* this is atoi() that tolerates underscores */
11175 const char *end = pos;
11177 while (--end >= s) {
11179 const UV orev = rev;
11180 rev += (*end - '0') * mult;
11183 /* diag_listed_as: Integer overflow in %s number */
11184 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11185 "Integer overflow in decimal number");
11189 if (rev > 0x7FFFFFFF)
11190 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11192 /* Append native character for the rev point */
11193 tmpend = uvchr_to_utf8(tmpbuf, rev);
11194 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11195 if (!UVCHR_IS_INVARIANT(rev))
11197 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11203 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11207 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11214 Perl_keyword_plugin_standard(pTHX_
11215 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11217 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11218 PERL_UNUSED_CONTEXT;
11219 PERL_UNUSED_ARG(keyword_ptr);
11220 PERL_UNUSED_ARG(keyword_len);
11221 PERL_UNUSED_ARG(op_ptr);
11222 return KEYWORD_PLUGIN_DECLINE;
11225 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11227 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11229 SAVEI32(PL_lex_brackets);
11230 if (PL_lex_brackets > 100)
11231 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11232 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11233 SAVEI32(PL_lex_allbrackets);
11234 PL_lex_allbrackets = 0;
11235 SAVEI8(PL_lex_fakeeof);
11236 PL_lex_fakeeof = (U8)fakeeof;
11237 if(yyparse(gramtype) && !PL_parser->error_count)
11238 qerror(Perl_mess(aTHX_ "Parse error"));
11241 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11243 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11247 SAVEVPTR(PL_eval_root);
11248 PL_eval_root = NULL;
11249 parse_recdescent(gramtype, fakeeof);
11255 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11257 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11260 if (flags & ~PARSE_OPTIONAL)
11261 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11262 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11263 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11264 if (!PL_parser->error_count)
11265 qerror(Perl_mess(aTHX_ "Parse error"));
11266 exprop = newOP(OP_NULL, 0);
11272 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11274 Parse a Perl arithmetic expression. This may contain operators of precedence
11275 down to the bit shift operators. The expression must be followed (and thus
11276 terminated) either by a comparison or lower-precedence operator or by
11277 something that would normally terminate an expression such as semicolon.
11278 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11279 otherwise it is mandatory. It is up to the caller to ensure that the
11280 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11281 the source of the code to be parsed and the lexical context for the
11284 The op tree representing the expression is returned. If an optional
11285 expression is absent, a null pointer is returned, otherwise the pointer
11288 If an error occurs in parsing or compilation, in most cases a valid op
11289 tree is returned anyway. The error is reflected in the parser state,
11290 normally resulting in a single exception at the top level of parsing
11291 which covers all the compilation errors that occurred. Some compilation
11292 errors, however, will throw an exception immediately.
11298 Perl_parse_arithexpr(pTHX_ U32 flags)
11300 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11304 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11306 Parse a Perl term expression. This may contain operators of precedence
11307 down to the assignment operators. The expression must be followed (and thus
11308 terminated) either by a comma or lower-precedence operator or by
11309 something that would normally terminate an expression such as semicolon.
11310 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11311 otherwise it is mandatory. It is up to the caller to ensure that the
11312 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11313 the source of the code to be parsed and the lexical context for the
11316 The op tree representing the expression is returned. If an optional
11317 expression is absent, a null pointer is returned, otherwise the pointer
11320 If an error occurs in parsing or compilation, in most cases a valid op
11321 tree is returned anyway. The error is reflected in the parser state,
11322 normally resulting in a single exception at the top level of parsing
11323 which covers all the compilation errors that occurred. Some compilation
11324 errors, however, will throw an exception immediately.
11330 Perl_parse_termexpr(pTHX_ U32 flags)
11332 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11336 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11338 Parse a Perl list expression. This may contain operators of precedence
11339 down to the comma operator. The expression must be followed (and thus
11340 terminated) either by a low-precedence logic operator such as C<or> or by
11341 something that would normally terminate an expression such as semicolon.
11342 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11343 otherwise it is mandatory. It is up to the caller to ensure that the
11344 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11345 the source of the code to be parsed and the lexical context for the
11348 The op tree representing the expression is returned. If an optional
11349 expression is absent, a null pointer is returned, otherwise the pointer
11352 If an error occurs in parsing or compilation, in most cases a valid op
11353 tree is returned anyway. The error is reflected in the parser state,
11354 normally resulting in a single exception at the top level of parsing
11355 which covers all the compilation errors that occurred. Some compilation
11356 errors, however, will throw an exception immediately.
11362 Perl_parse_listexpr(pTHX_ U32 flags)
11364 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11368 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11370 Parse a single complete Perl expression. This allows the full
11371 expression grammar, including the lowest-precedence operators such
11372 as C<or>. The expression must be followed (and thus terminated) by a
11373 token that an expression would normally be terminated by: end-of-file,
11374 closing bracketing punctuation, semicolon, or one of the keywords that
11375 signals a postfix expression-statement modifier. If C<flags> has the
11376 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
11377 mandatory. It is up to the caller to ensure that the dynamic parser
11378 state (L</PL_parser> et al) is correctly set to reflect the source of
11379 the code to be parsed and the lexical context for the expression.
11381 The op tree representing the expression is returned. If an optional
11382 expression is absent, a null pointer is returned, otherwise the pointer
11385 If an error occurs in parsing or compilation, in most cases a valid op
11386 tree is returned anyway. The error is reflected in the parser state,
11387 normally resulting in a single exception at the top level of parsing
11388 which covers all the compilation errors that occurred. Some compilation
11389 errors, however, will throw an exception immediately.
11395 Perl_parse_fullexpr(pTHX_ U32 flags)
11397 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11401 =for apidoc Amx|OP *|parse_block|U32 flags
11403 Parse a single complete Perl code block. This consists of an opening
11404 brace, a sequence of statements, and a closing brace. The block
11405 constitutes a lexical scope, so C<my> variables and various compile-time
11406 effects can be contained within it. It is up to the caller to ensure
11407 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11408 reflect the source of the code to be parsed and the lexical context for
11411 The op tree representing the code block is returned. This is always a
11412 real op, never a null pointer. It will normally be a C<lineseq> list,
11413 including C<nextstate> or equivalent ops. No ops to construct any kind
11414 of runtime scope are included by virtue of it being a block.
11416 If an error occurs in parsing or compilation, in most cases a valid op
11417 tree (most likely null) is returned anyway. The error is reflected in
11418 the parser state, normally resulting in a single exception at the top
11419 level of parsing which covers all the compilation errors that occurred.
11420 Some compilation errors, however, will throw an exception immediately.
11422 The C<flags> parameter is reserved for future use, and must always
11429 Perl_parse_block(pTHX_ U32 flags)
11432 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11433 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11437 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11439 Parse a single unadorned Perl statement. This may be a normal imperative
11440 statement or a declaration that has compile-time effect. It does not
11441 include any label or other affixture. It is up to the caller to ensure
11442 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11443 reflect the source of the code to be parsed and the lexical context for
11446 The op tree representing the statement is returned. This may be a
11447 null pointer if the statement is null, for example if it was actually
11448 a subroutine definition (which has compile-time side effects). If not
11449 null, it will be ops directly implementing the statement, suitable to
11450 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11451 equivalent op (except for those embedded in a scope contained entirely
11452 within the statement).
11454 If an error occurs in parsing or compilation, in most cases a valid op
11455 tree (most likely null) is returned anyway. The error is reflected in
11456 the parser state, normally resulting in a single exception at the top
11457 level of parsing which covers all the compilation errors that occurred.
11458 Some compilation errors, however, will throw an exception immediately.
11460 The C<flags> parameter is reserved for future use, and must always
11467 Perl_parse_barestmt(pTHX_ U32 flags)
11470 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11471 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11475 =for apidoc Amx|SV *|parse_label|U32 flags
11477 Parse a single label, possibly optional, of the type that may prefix a
11478 Perl statement. It is up to the caller to ensure that the dynamic parser
11479 state (L</PL_parser> et al) is correctly set to reflect the source of
11480 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
11481 label is optional, otherwise it is mandatory.
11483 The name of the label is returned in the form of a fresh scalar. If an
11484 optional label is absent, a null pointer is returned.
11486 If an error occurs in parsing, which can only occur if the label is
11487 mandatory, a valid label is returned anyway. The error is reflected in
11488 the parser state, normally resulting in a single exception at the top
11489 level of parsing which covers all the compilation errors that occurred.
11495 Perl_parse_label(pTHX_ U32 flags)
11497 if (flags & ~PARSE_OPTIONAL)
11498 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11499 if (PL_lex_state == LEX_KNOWNEXT) {
11500 PL_parser->yychar = yylex();
11501 if (PL_parser->yychar == LABEL) {
11502 char * const lpv = pl_yylval.pval;
11503 STRLEN llen = strlen(lpv);
11504 PL_parser->yychar = YYEMPTY;
11505 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11512 STRLEN wlen, bufptr_pos;
11515 if (!isIDFIRST_lazy_if(s, UTF))
11517 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11518 if (word_takes_any_delimeter(s, wlen))
11520 bufptr_pos = s - SvPVX(PL_linestr);
11522 lex_read_space(LEX_KEEP_PREVIOUS);
11524 s = SvPVX(PL_linestr) + bufptr_pos;
11525 if (t[0] == ':' && t[1] != ':') {
11526 PL_oldoldbufptr = PL_oldbufptr;
11529 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11533 if (flags & PARSE_OPTIONAL) {
11536 qerror(Perl_mess(aTHX_ "Parse error"));
11537 return newSVpvs("x");
11544 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11546 Parse a single complete Perl statement. This may be a normal imperative
11547 statement or a declaration that has compile-time effect, and may include
11548 optional labels. It is up to the caller to ensure that the dynamic
11549 parser state (L</PL_parser> et al) is correctly set to reflect the source
11550 of the code to be parsed and the lexical context for the statement.
11552 The op tree representing the statement is returned. This may be a
11553 null pointer if the statement is null, for example if it was actually
11554 a subroutine definition (which has compile-time side effects). If not
11555 null, it will be the result of a L</newSTATEOP> call, normally including
11556 a C<nextstate> or equivalent op.
11558 If an error occurs in parsing or compilation, in most cases a valid op
11559 tree (most likely null) is returned anyway. The error is reflected in
11560 the parser state, normally resulting in a single exception at the top
11561 level of parsing which covers all the compilation errors that occurred.
11562 Some compilation errors, however, will throw an exception immediately.
11564 The C<flags> parameter is reserved for future use, and must always
11571 Perl_parse_fullstmt(pTHX_ U32 flags)
11574 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11575 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11579 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11581 Parse a sequence of zero or more Perl statements. These may be normal
11582 imperative statements, including optional labels, or declarations
11583 that have compile-time effect, or any mixture thereof. The statement
11584 sequence ends when a closing brace or end-of-file is encountered in a
11585 place where a new statement could have validly started. It is up to
11586 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11587 is correctly set to reflect the source of the code to be parsed and the
11588 lexical context for the statements.
11590 The op tree representing the statement sequence is returned. This may
11591 be a null pointer if the statements were all null, for example if there
11592 were no statements or if there were only subroutine definitions (which
11593 have compile-time side effects). If not null, it will be a C<lineseq>
11594 list, normally including C<nextstate> or equivalent ops.
11596 If an error occurs in parsing or compilation, in most cases a valid op
11597 tree is returned anyway. The error is reflected in the parser state,
11598 normally resulting in a single exception at the top level of parsing
11599 which covers all the compilation errors that occurred. Some compilation
11600 errors, however, will throw an exception immediately.
11602 The C<flags> parameter is reserved for future use, and must always
11609 Perl_parse_stmtseq(pTHX_ U32 flags)
11614 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11615 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11616 c = lex_peek_unichar(0);
11617 if (c != -1 && c != /*{*/'}')
11618 qerror(Perl_mess(aTHX_ "Parse error"));
11622 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11624 S_lex_token_boundary(pTHX)
11626 PL_oldoldbufptr = PL_oldbufptr;
11627 PL_oldbufptr = PL_bufptr;
11630 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11632 S_parse_opt_lexvar(pTHX)
11637 lex_token_boundary();
11638 sigil = lex_read_unichar(0);
11639 if (lex_peek_unichar(0) == '#') {
11640 qerror(Perl_mess(aTHX_ "Parse error"));
11644 c = lex_peek_unichar(0);
11645 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11648 d = PL_tokenbuf + 1;
11649 PL_tokenbuf[0] = (char)sigil;
11650 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11652 if (d == PL_tokenbuf+1)
11654 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11655 OPf_MOD | (OPpLVAL_INTRO<<8));
11656 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11661 Perl_parse_subsignature(pTHX)
11664 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11665 OP *initops = NULL;
11667 c = lex_peek_unichar(0);
11668 while (c != /*(*/')') {
11672 if (prev_type == 2)
11673 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11674 var = parse_opt_lexvar();
11676 newBINOP(OP_AELEM, 0,
11677 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11679 newSVOP(OP_CONST, 0, newSViv(pos))) :
11682 c = lex_peek_unichar(0);
11684 lex_token_boundary();
11685 lex_read_unichar(0);
11687 c = lex_peek_unichar(0);
11688 if (c == ',' || c == /*(*/')') {
11690 qerror(Perl_mess(aTHX_ "Optional parameter "
11691 "lacks default expression"));
11693 OP *defexpr = parse_termexpr(0);
11694 if (defexpr->op_type == OP_UNDEF
11695 && !(defexpr->op_flags & OPf_KIDS))
11701 scalar(newUNOP(OP_RV2AV, 0,
11702 newGVOP(OP_GV, 0, PL_defgv))),
11703 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11705 newCONDOP(0, ifop, expr, defexpr) :
11706 newLOGOP(OP_OR, 0, ifop, defexpr);
11711 if (prev_type == 1)
11712 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11713 "follows optional parameter"));
11715 min_arity = pos + 1;
11717 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11719 initops = op_append_list(OP_LINESEQ, initops,
11720 newSTATEOP(0, NULL, expr));
11726 if (prev_type == 2)
11727 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11728 var = parse_opt_lexvar();
11730 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11731 newBINOP(OP_BIT_AND, 0,
11732 scalar(newUNOP(OP_RV2AV, 0,
11733 newGVOP(OP_GV, 0, PL_defgv))),
11734 newSVOP(OP_CONST, 0, newSViv(1))),
11735 op_convert_list(OP_DIE, 0,
11736 op_convert_list(OP_SPRINTF, 0,
11737 op_append_list(OP_LIST,
11738 newSVOP(OP_CONST, 0,
11739 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11741 op_append_list(OP_LIST,
11742 newSVOP(OP_CONST, 0, newSViv(1)),
11743 newSVOP(OP_CONST, 0, newSViv(2))),
11744 newOP(OP_CALLER, 0))))));
11745 if (pos != min_arity)
11746 chkop = newLOGOP(OP_AND, 0,
11748 scalar(newUNOP(OP_RV2AV, 0,
11749 newGVOP(OP_GV, 0, PL_defgv))),
11750 newSVOP(OP_CONST, 0, newSViv(pos))),
11752 initops = op_append_list(OP_LINESEQ,
11753 newSTATEOP(0, NULL, chkop),
11758 op_prepend_elem(OP_ASLICE,
11759 newOP(OP_PUSHMARK, 0),
11760 newLISTOP(OP_ASLICE, 0,
11762 newSVOP(OP_CONST, 0, newSViv(pos)),
11763 newUNOP(OP_AV2ARYLEN, 0,
11764 ref(newUNOP(OP_RV2AV, 0,
11765 newGVOP(OP_GV, 0, PL_defgv)),
11767 ref(newUNOP(OP_RV2AV, 0,
11768 newGVOP(OP_GV, 0, PL_defgv)),
11770 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11771 initops = op_append_list(OP_LINESEQ, initops,
11772 newSTATEOP(0, NULL,
11773 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11780 qerror(Perl_mess(aTHX_ "Parse error"));
11784 c = lex_peek_unichar(0);
11786 case /*(*/')': break;
11789 lex_token_boundary();
11790 lex_read_unichar(0);
11792 c = lex_peek_unichar(0);
11793 } while (c == ',');
11799 if (min_arity != 0) {
11800 initops = op_append_list(OP_LINESEQ,
11801 newSTATEOP(0, NULL,
11804 scalar(newUNOP(OP_RV2AV, 0,
11805 newGVOP(OP_GV, 0, PL_defgv))),
11806 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11807 op_convert_list(OP_DIE, 0,
11808 op_convert_list(OP_SPRINTF, 0,
11809 op_append_list(OP_LIST,
11810 newSVOP(OP_CONST, 0,
11811 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11813 op_append_list(OP_LIST,
11814 newSVOP(OP_CONST, 0, newSViv(1)),
11815 newSVOP(OP_CONST, 0, newSViv(2))),
11816 newOP(OP_CALLER, 0))))))),
11819 if (max_arity != -1) {
11820 initops = op_append_list(OP_LINESEQ,
11821 newSTATEOP(0, NULL,
11824 scalar(newUNOP(OP_RV2AV, 0,
11825 newGVOP(OP_GV, 0, PL_defgv))),
11826 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11827 op_convert_list(OP_DIE, 0,
11828 op_convert_list(OP_SPRINTF, 0,
11829 op_append_list(OP_LIST,
11830 newSVOP(OP_CONST, 0,
11831 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11833 op_append_list(OP_LIST,
11834 newSVOP(OP_CONST, 0, newSViv(1)),
11835 newSVOP(OP_CONST, 0, newSViv(2))),
11836 newOP(OP_CALLER, 0))))))),
11843 * ex: set ts=8 sts=4 sw=4 et: