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 (*t && !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;
2522 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2523 "Unknown charname '' is deprecated");
2527 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2529 &first_bad_char_loc))
2531 /* If warnings are on, this will print a more detailed analysis of what
2532 * is wrong than the error message below */
2533 utf8n_to_uvchr(first_bad_char_loc,
2534 e - ((char *) first_bad_char_loc),
2537 /* We deliberately don't try to print the malformed character, which
2538 * might not print very well; it also may be just the first of many
2539 * malformations, so don't print what comes after it */
2540 yyerror_pv(Perl_form(aTHX_
2541 "Malformed UTF-8 character immediately after '%.*s'",
2542 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2547 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2548 /* include the <}> */
2549 e - backslash_ptr + 1);
2551 SvREFCNT_dec_NN(res);
2555 /* See if the charnames handler is the Perl core's, and if so, we can skip
2556 * the validation needed for a user-supplied one, as Perl's does its own
2558 table = GvHV(PL_hintgv); /* ^H */
2559 cvp = hv_fetchs(table, "charnames", FALSE);
2560 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2561 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2563 const char * const name = HvNAME(stash);
2564 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2565 && strEQ(name, "_charnames")) {
2570 /* Here, it isn't Perl's charname handler. We can't rely on a
2571 * user-supplied handler to validate the input name. For non-ut8 input,
2572 * look to see that the first character is legal. Then loop through the
2573 * rest checking that each is a continuation */
2575 /* This code makes the reasonable assumption that the only Latin1-range
2576 * characters that begin a character name alias are alphabetic, otherwise
2577 * would have to create a isCHARNAME_BEGIN macro */
2580 if (! isALPHAU(*s)) {
2585 if (! isCHARNAME_CONT(*s)) {
2588 if (*s == ' ' && *(s-1) == ' ') {
2595 /* Similarly for utf8. For invariants can check directly; for other
2596 * Latin1, can calculate their code point and check; otherwise use a
2598 if (UTF8_IS_INVARIANT(*s)) {
2599 if (! isALPHAU(*s)) {
2603 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2604 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2610 if (! PL_utf8_charname_begin) {
2611 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2612 PL_utf8_charname_begin = _core_swash_init("utf8",
2613 "_Perl_Charname_Begin",
2615 1, 0, NULL, &flags);
2617 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2624 if (UTF8_IS_INVARIANT(*s)) {
2625 if (! isCHARNAME_CONT(*s)) {
2628 if (*s == ' ' && *(s-1) == ' ') {
2633 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2634 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2641 if (! PL_utf8_charname_continue) {
2642 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2643 PL_utf8_charname_continue = _core_swash_init("utf8",
2644 "_Perl_Charname_Continue",
2646 1, 0, NULL, &flags);
2648 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2655 if (*(s-1) == ' ') {
2658 "charnames alias definitions may not contain trailing "
2659 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2660 (int)(s - backslash_ptr + 1), backslash_ptr,
2661 (int)(e - s + 1), s + 1
2663 UTF ? SVf_UTF8 : 0);
2667 if (SvUTF8(res)) { /* Don't accept malformed input */
2668 const U8* first_bad_char_loc;
2670 const char* const str = SvPV_const(res, len);
2671 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2672 /* If warnings are on, this will print a more detailed analysis of
2673 * what is wrong than the error message below */
2674 utf8n_to_uvchr(first_bad_char_loc,
2675 (char *) first_bad_char_loc - str,
2678 /* We deliberately don't try to print the malformed character,
2679 * which might not print very well; it also may be just the first
2680 * of many malformations, so don't print what comes after it */
2683 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2684 (int) (e - backslash_ptr + 1), backslash_ptr,
2685 (int) ((char *) first_bad_char_loc - str), str
2696 /* The final %.*s makes sure that should the trailing NUL be missing
2697 * that this print won't run off the end of the string */
2700 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2701 (int)(s - backslash_ptr + 1), backslash_ptr,
2702 (int)(e - s + 1), s + 1
2704 UTF ? SVf_UTF8 : 0);
2711 "charnames alias definitions may not contain a sequence of "
2712 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2713 (int)(s - backslash_ptr + 1), backslash_ptr,
2714 (int)(e - s + 1), s + 1
2716 UTF ? SVf_UTF8 : 0);
2723 Extracts the next constant part of a pattern, double-quoted string,
2724 or transliteration. This is terrifying code.
2726 For example, in parsing the double-quoted string "ab\x63$d", it would
2727 stop at the '$' and return an OP_CONST containing 'abc'.
2729 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2730 processing a pattern (PL_lex_inpat is true), a transliteration
2731 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2733 Returns a pointer to the character scanned up to. If this is
2734 advanced from the start pointer supplied (i.e. if anything was
2735 successfully parsed), will leave an OP_CONST for the substring scanned
2736 in pl_yylval. Caller must intuit reason for not parsing further
2737 by looking at the next characters herself.
2741 \N{FOO} => \N{U+hex_for_character_FOO}
2742 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2745 all other \-char, including \N and \N{ apart from \N{ABC}
2748 @ and $ where it appears to be a var, but not for $ as tail anchor
2752 In transliterations:
2753 characters are VERY literal, except for - not at the start or end
2754 of the string, which indicates a range. If the range is in bytes,
2755 scan_const expands the range to the full set of intermediate
2756 characters. If the range is in utf8, the hyphen is replaced with
2757 a certain range mark which will be handled by pmtrans() in op.c.
2759 In double-quoted strings:
2761 double-quoted style: \r and \n
2762 constants: \x31, etc.
2763 deprecated backrefs: \1 (in substitution replacements)
2764 case and quoting: \U \Q \E
2767 scan_const does *not* construct ops to handle interpolated strings.
2768 It stops processing as soon as it finds an embedded $ or @ variable
2769 and leaves it to the caller to work out what's going on.
2771 embedded arrays (whether in pattern or not) could be:
2772 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2774 $ in double-quoted strings must be the symbol of an embedded scalar.
2776 $ in pattern could be $foo or could be tail anchor. Assumption:
2777 it's a tail anchor if $ is the last thing in the string, or if it's
2778 followed by one of "()| \r\n\t"
2780 \1 (backreferences) are turned into $1 in substitutions
2782 The structure of the code is
2783 while (there's a character to process) {
2784 handle transliteration ranges
2785 skip regexp comments /(?#comment)/ and codes /(?{code})/
2786 skip #-initiated comments in //x patterns
2787 check for embedded arrays
2788 check for embedded scalars
2790 deprecate \1 in substitution replacements
2791 handle string-changing backslashes \l \U \Q \E, etc.
2792 switch (what was escaped) {
2793 handle \- in a transliteration (becomes a literal -)
2794 if a pattern and not \N{, go treat as regular character
2795 handle \132 (octal characters)
2796 handle \x15 and \x{1234} (hex characters)
2797 handle \N{name} (named characters, also \N{3,5} in a pattern)
2798 handle \cV (control characters)
2799 handle printf-style backslashes (\f, \r, \n, etc)
2802 } (end if backslash)
2803 handle regular character
2804 } (end while character to read)
2809 S_scan_const(pTHX_ char *start)
2811 char *send = PL_bufend; /* end of the constant */
2812 SV *sv = newSV(send - start); /* sv for the constant. See note below
2814 char *s = start; /* start of the constant */
2815 char *d = SvPVX(sv); /* destination for copies */
2816 bool dorange = FALSE; /* are we in a translit range? */
2817 bool didrange = FALSE; /* did we just finish a range? */
2818 bool in_charclass = FALSE; /* within /[...]/ */
2819 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2820 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2821 UTF8? But, this can show as true
2822 when the source isn't utf8, as for
2823 example when it is entirely composed
2825 SV *res; /* result from charnames */
2826 STRLEN offset_to_max; /* The offset in the output to where the range
2827 high-end character is temporarily placed */
2829 /* Note on sizing: The scanned constant is placed into sv, which is
2830 * initialized by newSV() assuming one byte of output for every byte of
2831 * input. This routine expects newSV() to allocate an extra byte for a
2832 * trailing NUL, which this routine will append if it gets to the end of
2833 * the input. There may be more bytes of input than output (eg., \N{LATIN
2834 * CAPITAL LETTER A}), or more output than input if the constant ends up
2835 * recoded to utf8, but each time a construct is found that might increase
2836 * the needed size, SvGROW() is called. Its size parameter each time is
2837 * based on the best guess estimate at the time, namely the length used so
2838 * far, plus the length the current construct will occupy, plus room for
2839 * the trailing NUL, plus one byte for every input byte still unscanned */
2841 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2844 int backslash_N = 0; /* ? was the character from \N{} */
2845 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2846 platform-specific like \x65 */
2849 PERL_ARGS_ASSERT_SCAN_CONST;
2851 assert(PL_lex_inwhat != OP_TRANSR);
2852 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2853 /* If we are doing a trans and we know we want UTF8 set expectation */
2854 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2855 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2858 /* Protect sv from errors and fatal warnings. */
2859 ENTER_with_name("scan_const");
2863 || dorange /* Handle tr/// range at right edge of input */
2866 /* get transliterations out of the way (they're most literal) */
2867 if (PL_lex_inwhat == OP_TRANS) {
2869 /* But there isn't any special handling necessary unless there is a
2870 * range, so for most cases we just drop down and handle the value
2871 * as any other. There are two exceptions.
2873 * 1. A minus sign indicates that we are actually going to have
2874 * a range. In this case, skip the '-', set a flag, then drop
2875 * down to handle what should be the end range value.
2876 * 2. After we've handled that value, the next time through, that
2877 * flag is set and we fix up the range.
2879 * Ranges entirely within Latin1 are expanded out entirely, in
2880 * order to avoid the significant overhead of making a swash.
2881 * Ranges that extend above Latin1 have to have a swash, so there
2882 * is no advantage to abbreviate them here, so they are stored here
2883 * as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte signifies a
2884 * hyphen without any possible ambiguity. On EBCDIC machines, if
2885 * the range is expressed as Unicode, the Latin1 portion is
2886 * expanded out even if the entire range extends above Latin1.
2887 * This is because each code point in it has to be processed here
2888 * individually to get its native translation */
2892 /* Here, we don't think we're in a range. If we've processed
2893 * at least one character, then see if this next one is a '-',
2894 * indicating the previous one was the start of a range. But
2895 * don't bother if we're too close to the end for the minus to
2897 if (*s != '-' || s >= send - 1 || s == start) {
2899 /* A regular character. Process like any other, but first
2900 * clear any flags */
2904 non_portable_endpoint = 0;
2907 /* Drops down to generic code to process current byte */
2910 if (didrange) { /* Something like y/A-C-Z// */
2911 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2916 s++; /* Skip past the minus */
2918 /* d now points to where the end-range character will be
2919 * placed. Save it so won't have to go finding it later,
2920 * and drop down to get that character. (Actually we
2921 * instead save the offset, to handle the case where a
2922 * realloc in the meantime could change the actual
2923 * pointer). We'll finish processing the range the next
2924 * time through the loop */
2925 offset_to_max = d - SvPVX_const(sv);
2927 } /* End of not a range */
2929 /* Here we have parsed a range. Now must handle it. At this
2931 * 'sv' is a SV* that contains the output string we are
2932 * constructing. The final two characters in that string
2933 * are the range start and range end, in order.
2934 * 'd' points to just beyond the range end in the 'sv' string,
2935 * where we would next place something
2936 * 'offset_to_max' is the offset in 'sv' at which the character
2937 * before 'd' begins.
2939 const char * max_ptr = SvPVX_const(sv) + offset_to_max;
2940 const char * min_ptr;
2942 IV range_max; /* last character in range */
2945 #ifndef EBCDIC /* Not meaningful except in EBCDIC, so initialize to false */
2946 const bool convert_unicode = FALSE;
2947 const IV real_range_max = 0;
2949 bool convert_unicode;
2950 IV real_range_max = 0;
2953 /* Get the range-ends code point values. */
2955 /* We know the utf8 is valid, because we just constructed
2956 * it ourselves in previous loop iterations */
2957 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
2958 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
2959 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
2962 min_ptr = max_ptr - 1;
2963 range_min = * (U8*) min_ptr;
2964 range_max = * (U8*) max_ptr;
2968 /* On EBCDIC platforms, we may have to deal with portable
2969 * ranges. These happen if at least one range endpoint is a
2970 * Unicode value (\N{...}), or if the range is a subset of
2971 * [A-Z] or [a-z], and both ends are literal characters,
2972 * like 'A', and not like \x{C1} */
2973 if ((convert_unicode
2974 = cBOOL(backslash_N) /* \N{} forces Unicode, hence
2976 || ( ! non_portable_endpoint
2977 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
2978 || (isUPPER_A(range_min) && isUPPER_A(range_max))))
2981 /* Special handling is needed for these portable ranges.
2982 * They are defined to all be in Unicode terms, which
2983 * include all Unicode code points between the end points.
2984 * Convert to Unicode to get the Unicode range. Later we
2985 * will convert each code point in the range back to
2987 range_min = NATIVE_TO_UNI(range_min);
2988 range_max = NATIVE_TO_UNI(range_max);
2992 if (range_min > range_max) {
2993 if (convert_unicode) {
2994 /* Need to convert back to native for meaningful
2995 * messages for this platform */
2996 range_min = UNI_TO_NATIVE(range_min);
2997 range_max = UNI_TO_NATIVE(range_max);
3000 /* Use the characters themselves for the error message if
3001 * ASCII printables; otherwise some visible representation
3003 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3005 "Invalid range \"%c-%c\" in transliteration operator",
3006 (char)range_min, (char)range_max);
3008 else if (convert_unicode) {
3009 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3011 "Invalid range \"\\N{U+%04"UVXf"}-\\N{U+%04"UVXf"}\""
3012 " in transliteration operator",
3013 range_min, range_max);
3016 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3018 "Invalid range \"\\x{%04"UVXf"}-\\x{%04"UVXf"}\""
3019 " in transliteration operator",
3020 range_min, range_max);
3026 /* We try to avoid creating a swash. If the upper end of
3027 * this range is below 256, this range won't force a swash;
3028 * otherwise it does force a swash, and as long as we have
3029 * to have one, we might as well not expand things out.
3030 * But if it's EBCDIC, we may have to look at each
3031 * character below 256 if we have to convert to/from
3035 && (range_min > 255 || ! convert_unicode)
3038 /* Move the high character one byte to the right; then
3039 * insert between it and the range begin, an illegal
3040 * byte which serves to indicate this is a range (using
3041 * a '-' could be ambiguous). */
3043 while (e-- > max_ptr) {
3046 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3050 /* Here, we're going to expand out the range. For EBCDIC
3051 * the range can extend above 255 (not so in ASCII), so
3052 * for EBCDIC, split it into the parts above and below
3055 if (range_max > 255) {
3056 real_range_max = range_max;
3062 /* Here we need to expand out the string to contain each
3063 * character in the range. Grow the output to handle this */
3065 save_offset = min_ptr - SvPVX_const(sv);
3067 /* The base growth is the number of code points in the range */
3068 grow = range_max - range_min + 1;
3071 /* But if the output is UTF-8, some of those characters may
3072 * need two bytes (since the maximum range value here is
3073 * 255, the max bytes per character is two). On ASCII
3074 * platforms, it's not much trouble to get an accurate
3075 * count of what's needed. But on EBCDIC, the ones that
3076 * need 2 bytes are scattered around, so just use a worst
3077 * case value instead of calculating for that platform. */
3081 /* Only those above 127 require 2 bytes. This may be
3082 * everything in the range, or not */
3083 if (range_min > 127) {
3086 else if (range_max > 127) {
3087 grow += range_max - 127;
3092 /* Subtract 3 for the bytes that were already accounted for
3093 * (min, max, and the hyphen) */
3094 SvGROW(sv, SvLEN(sv) + grow - 3);
3095 d = SvPVX(sv) + save_offset; /* refresh d after realloc */
3097 /* Here, we expand out the range. On ASCII platforms, the
3098 * compiler should optimize out the 'convert_unicode==TRUE'
3099 * portion of this */
3100 if (convert_unicode) {
3103 /* Recall that the min and max are now in Unicode terms, so
3104 * we have to convert each character to its native
3107 for (i = range_min; i <= range_max; i++) {
3108 append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i),
3113 for (i = range_min; i <= range_max; i++) {
3114 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3121 /* Here, no conversions are necessary, which means that the
3122 * first character in the range is already in 'd' and
3123 * valid, so we can skip overwriting it */
3126 for (i = range_min + 1; i <= range_max; i++) {
3127 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3132 for (i = range_min + 1; i <= range_max; i++) {
3138 /* (Compilers should optimize this out for non-EBCDIC). If the
3139 * original range extended above 255, add in that portion */
3140 if (real_range_max) {
3141 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3142 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3143 if (real_range_max > 0x101)
3144 *d++ = (char) ILLEGAL_UTF8_BYTE;
3145 if (real_range_max > 0x100)
3146 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3150 /* mark the range as done, and continue */
3154 non_portable_endpoint = 0;
3158 } /* End of is a range */
3159 } /* End of transliteration. Joins main code after these else's */
3160 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3163 while (s1 >= start && *s1-- == '\\')
3166 in_charclass = TRUE;
3169 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3172 while (s1 >= start && *s1-- == '\\')
3175 in_charclass = FALSE;
3178 /* skip for regexp comments /(?#comment)/, except for the last
3179 * char, which will be done separately.
3180 * Stop on (?{..}) and friends */
3182 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3184 while (s+1 < send && *s != ')')
3187 else if (!PL_lex_casemods
3188 && ( s[2] == '{' /* This should match regcomp.c */
3189 || (s[2] == '?' && s[3] == '{')))
3195 /* likewise skip #-initiated comments in //x patterns */
3199 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3201 while (s+1 < send && *s != '\n')
3205 /* no further processing of single-quoted regex */
3206 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3207 goto default_action;
3209 /* check for embedded arrays
3210 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3212 else if (*s == '@' && s[1]) {
3213 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3215 if (strchr(":'{$", s[1]))
3217 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3218 break; /* in regexp, neither @+ nor @- are interpolated */
3221 /* check for embedded scalars. only stop if we're sure it's a
3224 else if (*s == '$') {
3225 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3227 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3229 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3230 "Possible unintended interpolation of $\\ in regex");
3232 break; /* in regexp, $ might be tail anchor */
3236 /* End of else if chain - OP_TRANS rejoin rest */
3239 if (*s == '\\' && s+1 < send) {
3240 char* e; /* Can be used for ending '}', etc. */
3244 /* warn on \1 - \9 in substitution replacements, but note that \11
3245 * is an octal; and \19 is \1 followed by '9' */
3246 if (PL_lex_inwhat == OP_SUBST
3252 /* diag_listed_as: \%d better written as $%d */
3253 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3258 /* string-change backslash escapes */
3259 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3263 /* In a pattern, process \N, but skip any other backslash escapes.
3264 * This is because we don't want to translate an escape sequence
3265 * into a meta symbol and have the regex compiler use the meta
3266 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3267 * in spite of this, we do have to process \N here while the proper
3268 * charnames handler is in scope. See bugs #56444 and #62056.
3270 * There is a complication because \N in a pattern may also stand
3271 * for 'match a non-nl', and not mean a charname, in which case its
3272 * processing should be deferred to the regex compiler. To be a
3273 * charname it must be followed immediately by a '{', and not look
3274 * like \N followed by a curly quantifier, i.e., not something like
3275 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3277 else if (PL_lex_inpat
3280 || regcurly(s + 1)))
3283 goto default_action;
3289 if ((isALPHANUMERIC(*s)))
3290 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3291 "Unrecognized escape \\%c passed through",
3293 /* default action is to copy the quoted character */
3294 goto default_action;
3297 /* eg. \132 indicates the octal constant 0132 */
3298 case '0': case '1': case '2': case '3':
3299 case '4': case '5': case '6': case '7':
3301 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3303 uv = grok_oct(s, &len, &flags, NULL);
3305 if (len < 3 && s < send && isDIGIT(*s)
3306 && ckWARN(WARN_MISC))
3308 Perl_warner(aTHX_ packWARN(WARN_MISC),
3309 "%s", form_short_octal_warning(s, len));
3312 goto NUM_ESCAPE_INSERT;
3314 /* eg. \o{24} indicates the octal constant \024 */
3319 bool valid = grok_bslash_o(&s, &uv, &error,
3320 TRUE, /* Output warning */
3321 FALSE, /* Not strict */
3322 TRUE, /* Output warnings for
3329 goto NUM_ESCAPE_INSERT;
3332 /* eg. \x24 indicates the hex constant 0x24 */
3337 bool valid = grok_bslash_x(&s, &uv, &error,
3338 TRUE, /* Output warning */
3339 FALSE, /* Not strict */
3340 TRUE, /* Output warnings for
3350 /* Insert oct or hex escaped character. */
3352 /* Here uv is the ordinal of the next character being added */
3353 if (UVCHR_IS_INVARIANT(uv)) {
3357 if (!has_utf8 && uv > 255) {
3358 /* Might need to recode whatever we have accumulated so
3359 * far if it contains any chars variant in utf8 or
3362 SvCUR_set(sv, d - SvPVX_const(sv));
3365 /* See Note on sizing above. */
3366 sv_utf8_upgrade_flags_grow(
3368 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3369 /* Above-latin1 in string
3370 * implies no encoding */
3371 |SV_UTF8_NO_ENCODING,
3372 UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
3373 d = SvPVX(sv) + SvCUR(sv);
3378 /* Usually, there will already be enough room in 'sv'
3379 * since such escapes are likely longer than any UTF-8
3380 * sequence they can end up as. This isn't the case on
3381 * EBCDIC where \x{40000000} contains 12 bytes, and the
3382 * UTF-8 for it contains 14. And, we have to allow for
3383 * a trailing NUL. It probably can't happen on ASCII
3384 * platforms, but be safe */
3385 const STRLEN needed = d - SvPVX(sv) + UVCHR_SKIP(uv)
3387 if (UNLIKELY(needed > SvLEN(sv))) {
3388 SvCUR_set(sv, d - SvPVX_const(sv));
3389 d = sv_grow(sv, needed) + SvCUR(sv);
3392 d = (char*)uvchr_to_utf8((U8*)d, uv);
3393 if (PL_lex_inwhat == OP_TRANS
3394 && PL_sublex_info.sub_op)
3396 PL_sublex_info.sub_op->op_private |=
3397 (PL_lex_repl ? OPpTRANS_FROM_UTF
3406 non_portable_endpoint++;
3411 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3412 * named character, like \N{LATIN SMALL LETTER A}, or a named
3413 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3414 * GRAVE} (except y/// can't handle the latter, croaking). For
3415 * convenience all three forms are referred to as "named
3416 * characters" below.
3418 * For patterns, \N also can mean to match a non-newline. Code
3419 * before this 'switch' statement should already have handled
3420 * this situation, and hence this code only has to deal with
3421 * the named character cases.
3423 * For non-patterns, the named characters are converted to
3424 * their string equivalents. In patterns, named characters are
3425 * not converted to their ultimate forms for the same reasons
3426 * that other escapes aren't. Instead, they are converted to
3427 * the \N{U+...} form to get the value from the charnames that
3428 * is in effect right now, while preserving the fact that it
3429 * was a named character, so that the regex compiler knows
3432 * The structure of this section of code (besides checking for
3433 * errors and upgrading to utf8) is:
3434 * If the named character is of the form \N{U+...}, pass it
3435 * through if a pattern; otherwise convert the code point
3437 * Otherwise must be some \N{NAME}: convert to
3438 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3440 * Transliteration is an exception. The conversion to utf8 is
3441 * only done if the code point requires it to be representable.
3443 * Here, 's' points to the 'N'; the test below is guaranteed to
3444 * succeed if we are being called on a pattern, as we already
3445 * know from a test above that the next character is a '{'. A
3446 * non-pattern \N must mean 'named character', which requires
3450 yyerror("Missing braces on \\N{}");
3455 /* If there is no matching '}', it is an error. */
3456 if (! (e = strchr(s, '}'))) {
3457 if (! PL_lex_inpat) {
3458 yyerror("Missing right brace on \\N{}");
3460 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3465 /* Here it looks like a named character */
3467 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3468 s += 2; /* Skip to next char after the 'U+' */
3471 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3472 /* Check the syntax. */
3475 if (!isXDIGIT(*s)) {
3478 "Invalid hexadecimal number in \\N{U+...}"
3486 else if ((*s == '.' || *s == '_')
3492 /* Pass everything through unchanged.
3493 * +1 is for the '}' */
3494 Copy(orig_s, d, e - orig_s + 1, char);
3495 d += e - orig_s + 1;
3497 else { /* Not a pattern: convert the hex to string */
3498 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3499 | PERL_SCAN_SILENT_ILLDIGIT
3500 | PERL_SCAN_DISALLOW_PREFIX;
3502 uv = grok_hex(s, &len, &flags, NULL);
3503 if (len == 0 || (len != (STRLEN)(e - s)))
3506 /* For non-tr///, if the destination is not in utf8,
3507 * unconditionally recode it to be so. This is
3508 * because \N{} implies Unicode semantics, and scalars
3509 * have to be in utf8 to guarantee those semantics.
3510 * tr/// doesn't care about Unicode rules, so no need
3511 * there to upgrade to UTF-8 for small enough code
3513 if (! has_utf8 && ( uv > 0xFF
3514 || PL_lex_inwhat != OP_TRANS))
3516 SvCUR_set(sv, d - SvPVX_const(sv));
3519 /* See Note on sizing above. */
3520 sv_utf8_upgrade_flags_grow(
3522 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3523 UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
3524 d = SvPVX(sv) + SvCUR(sv);
3528 /* Add the (Unicode) code point to the output. */
3529 if (OFFUNI_IS_INVARIANT(uv)) {
3530 *d++ = (char) LATIN1_TO_NATIVE(uv);
3533 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3537 else /* Here is \N{NAME} but not \N{U+...}. */
3538 if ((res = get_and_check_backslash_N_name(s, e)))
3541 const char *str = SvPV_const(res, len);
3544 if (! len) { /* The name resolved to an empty string */
3545 Copy("\\N{}", d, 4, char);
3549 /* In order to not lose information for the regex
3550 * compiler, pass the result in the specially made
3551 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3552 * the code points in hex of each character
3553 * returned by charnames */
3555 const char *str_end = str + len;
3556 const STRLEN off = d - SvPVX_const(sv);
3558 if (! SvUTF8(res)) {
3559 /* For the non-UTF-8 case, we can determine the
3560 * exact length needed without having to parse
3561 * through the string. Each character takes up
3562 * 2 hex digits plus either a trailing dot or
3564 const char initial_text[] = "\\N{U+";
3565 const STRLEN initial_len = sizeof(initial_text)
3567 d = off + SvGROW(sv, off
3570 /* +1 for trailing NUL */
3573 + (STRLEN)(send - e));
3574 Copy(initial_text, d, initial_len, char);
3576 while (str < str_end) {
3579 my_snprintf(hex_string,
3583 /* The regex compiler is
3584 * expecting Unicode, not
3586 NATIVE_TO_LATIN1(*str));
3587 PERL_MY_SNPRINTF_POST_GUARD(len,
3588 sizeof(hex_string));
3589 Copy(hex_string, d, 3, char);
3593 d--; /* Below, we will overwrite the final
3594 dot with a right brace */
3597 STRLEN char_length; /* cur char's byte length */
3599 /* and the number of bytes after this is
3600 * translated into hex digits */
3601 STRLEN output_length;
3603 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3604 * for max('U+', '.'); and 1 for NUL */
3605 char hex_string[2 * UTF8_MAXBYTES + 5];
3607 /* Get the first character of the result. */
3608 U32 uv = utf8n_to_uvchr((U8 *) str,
3612 /* Convert first code point to Unicode hex,
3613 * including the boiler plate before it. */
3615 my_snprintf(hex_string, sizeof(hex_string),
3617 (unsigned int) NATIVE_TO_UNI(uv));
3619 /* Make sure there is enough space to hold it */
3620 d = off + SvGROW(sv, off
3622 + (STRLEN)(send - e)
3623 + 2); /* '}' + NUL */
3625 Copy(hex_string, d, output_length, char);
3628 /* For each subsequent character, append dot and
3629 * its Unicode code point in hex */
3630 while ((str += char_length) < str_end) {
3631 const STRLEN off = d - SvPVX_const(sv);
3632 U32 uv = utf8n_to_uvchr((U8 *) str,
3637 my_snprintf(hex_string,
3640 (unsigned int) NATIVE_TO_UNI(uv));
3642 d = off + SvGROW(sv, off
3644 + (STRLEN)(send - e)
3645 + 2); /* '}' + NUL */
3646 Copy(hex_string, d, output_length, char);
3651 *d++ = '}'; /* Done. Add the trailing brace */
3654 else { /* Here, not in a pattern. Convert the name to a
3657 if (PL_lex_inwhat == OP_TRANS) {
3658 str = SvPV_const(res, len);
3659 if (len > ((SvUTF8(res))
3663 yyerror(Perl_form(aTHX_
3664 "%.*s must not be a named sequence"
3665 " in transliteration operator",
3666 /* +1 to include the "}" */
3667 (int) (e + 1 - start), start));
3668 goto end_backslash_N;
3671 else if (! SvUTF8(res)) {
3672 /* Make sure \N{} return is UTF-8. This is because
3673 * \N{} implies Unicode semantics, and scalars have to
3674 * be in utf8 to guarantee those semantics; but not
3675 * needed in tr/// */
3676 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3677 str = SvPV_const(res, len);
3680 /* Upgrade destination to be utf8 if this new
3682 if (! has_utf8 && SvUTF8(res)) {
3683 SvCUR_set(sv, d - SvPVX_const(sv));
3686 /* See Note on sizing above. */
3687 sv_utf8_upgrade_flags_grow(sv,
3688 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3689 len + (STRLEN)(send - s) + 1);
3690 d = SvPVX(sv) + SvCUR(sv);
3692 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3694 /* See Note on sizing above. (NOTE: SvCUR() is not
3695 * set correctly here). */
3696 const STRLEN off = d - SvPVX_const(sv);
3697 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3699 Copy(str, d, len, char);
3705 } /* End \N{NAME} */
3709 backslash_N++; /* \N{} is defined to be Unicode */
3711 s = e + 1; /* Point to just after the '}' */
3714 /* \c is a control character */
3718 *d++ = grok_bslash_c(*s++, 1);
3721 yyerror("Missing control char name in \\c");
3724 non_portable_endpoint++;
3728 /* printf-style backslashes, formfeeds, newlines, etc */
3754 } /* end if (backslash) */
3757 /* If we started with encoded form, or already know we want it,
3758 then encode the next character */
3759 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3762 /* One might think that it is wasted effort in the case of the
3763 * source being utf8 (this_utf8 == TRUE) to take the next character
3764 * in the source, convert it to an unsigned value, and then convert
3765 * it back again. But the source has not been validated here. The
3766 * routine that does the conversion checks for errors like
3769 const UV nextuv = (this_utf8)
3770 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3772 const STRLEN need = UVCHR_SKIP(nextuv);
3774 SvCUR_set(sv, d - SvPVX_const(sv));
3777 /* See Note on sizing above. */
3778 sv_utf8_upgrade_flags_grow(sv,
3779 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3780 need + (STRLEN)(send - s) + 1);
3781 d = SvPVX(sv) + SvCUR(sv);
3783 } else if (need > len) {
3784 /* encoded value larger than old, may need extra space (NOTE:
3785 * SvCUR() is not set correctly here). See Note on sizing
3787 const STRLEN off = d - SvPVX_const(sv);
3788 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3792 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3797 } /* while loop to process each character */
3799 /* terminate the string and set up the sv */
3801 SvCUR_set(sv, d - SvPVX_const(sv));
3802 if (SvCUR(sv) >= SvLEN(sv))
3803 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3804 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3807 if (IN_ENCODING && !has_utf8) {
3808 sv_recode_to_utf8(sv, _get_encoding());
3814 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3815 PL_sublex_info.sub_op->op_private |=
3816 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3820 /* shrink the sv if we allocated more than we used */
3821 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3822 SvPV_shrink_to_cur(sv);
3825 /* return the substring (via pl_yylval) only if we parsed anything */
3828 for (; s2 < s; s2++) {
3830 COPLINE_INC_WITH_HERELINES;
3832 SvREFCNT_inc_simple_void_NN(sv);
3833 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3834 && ! PL_parser->lex_re_reparsing)
3836 const char *const key = PL_lex_inpat ? "qr" : "q";
3837 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3841 if (PL_lex_inwhat == OP_TRANS) {
3844 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3847 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3855 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3858 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3860 LEAVE_with_name("scan_const");
3865 * Returns TRUE if there's more to the expression (e.g., a subscript),
3868 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3870 * ->[ and ->{ return TRUE
3871 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3872 * { and [ outside a pattern are always subscripts, so return TRUE
3873 * if we're outside a pattern and it's not { or [, then return FALSE
3874 * if we're in a pattern and the first char is a {
3875 * {4,5} (any digits around the comma) returns FALSE
3876 * if we're in a pattern and the first char is a [
3878 * [SOMETHING] has a funky algorithm to decide whether it's a
3879 * character class or not. It has to deal with things like
3880 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3881 * anything else returns TRUE
3884 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3887 S_intuit_more(pTHX_ char *s)
3889 PERL_ARGS_ASSERT_INTUIT_MORE;
3891 if (PL_lex_brackets)
3893 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3895 if (*s == '-' && s[1] == '>'
3896 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3897 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3898 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3900 if (*s != '{' && *s != '[')
3905 /* In a pattern, so maybe we have {n,m}. */
3913 /* On the other hand, maybe we have a character class */
3916 if (*s == ']' || *s == '^')
3919 /* this is terrifying, and it works */
3922 const char * const send = strchr(s,']');
3923 unsigned char un_char, last_un_char;
3924 char tmpbuf[sizeof PL_tokenbuf * 4];
3926 if (!send) /* has to be an expression */
3928 weight = 2; /* let's weigh the evidence */
3932 else if (isDIGIT(*s)) {
3934 if (isDIGIT(s[1]) && s[2] == ']')
3940 Zero(seen,256,char);
3942 for (; s < send; s++) {
3943 last_un_char = un_char;
3944 un_char = (unsigned char)*s;
3949 weight -= seen[un_char] * 10;
3950 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3952 char *tmp = PL_bufend;
3953 PL_bufend = (char*)send;
3954 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3956 len = (int)strlen(tmpbuf);
3957 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3958 UTF ? SVf_UTF8 : 0, SVt_PV))
3965 && strchr("[#!%*<>()-=",s[1]))
3967 if (/*{*/ strchr("])} =",s[2]))
3976 if (strchr("wds]",s[1]))
3978 else if (seen[(U8)'\''] || seen[(U8)'"'])
3980 else if (strchr("rnftbxcav",s[1]))
3982 else if (isDIGIT(s[1])) {
3984 while (s[1] && isDIGIT(s[1]))
3994 if (strchr("aA01! ",last_un_char))
3996 if (strchr("zZ79~",s[1]))
3998 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3999 weight -= 5; /* cope with negative subscript */
4002 if (!isWORDCHAR(last_un_char)
4003 && !(last_un_char == '$' || last_un_char == '@'
4004 || last_un_char == '&')
4005 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4009 if (keyword(d, s - d, 0))
4012 if (un_char == last_un_char + 1)
4014 weight -= seen[un_char];
4019 if (weight >= 0) /* probably a character class */
4029 * Does all the checking to disambiguate
4031 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4032 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4034 * First argument is the stuff after the first token, e.g. "bar".
4036 * Not a method if foo is a filehandle.
4037 * Not a method if foo is a subroutine prototyped to take a filehandle.
4038 * Not a method if it's really "Foo $bar"
4039 * Method if it's "foo $bar"
4040 * Not a method if it's really "print foo $bar"
4041 * Method if it's really "foo package::" (interpreted as package->foo)
4042 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4043 * Not a method if bar is a filehandle or package, but is quoted with
4048 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4050 char *s = start + (*start == '$');
4051 char tmpbuf[sizeof PL_tokenbuf];
4054 /* Mustn't actually add anything to a symbol table.
4055 But also don't want to "initialise" any placeholder
4056 constants that might already be there into full
4057 blown PVGVs with attached PVCV. */
4059 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4061 PERL_ARGS_ASSERT_INTUIT_METHOD;
4063 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4065 if (cv && SvPOK(cv)) {
4066 const char *proto = CvPROTO(cv);
4068 while (*proto && (isSPACE(*proto) || *proto == ';'))
4075 if (*start == '$') {
4076 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4077 || isUPPER(*PL_tokenbuf))
4082 return *s == '(' ? FUNCMETH : METHOD;
4085 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4086 /* start is the beginning of the possible filehandle/object,
4087 * and s is the end of it
4088 * tmpbuf is a copy of it (but with single quotes as double colons)
4091 if (!keyword(tmpbuf, len, 0)) {
4092 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4097 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4098 if (indirgv && GvCVu(indirgv))
4100 /* filehandle or package name makes it a method */
4101 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4103 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4104 return 0; /* no assumptions -- "=>" quotes bareword */
4106 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4107 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4108 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4112 return *s == '(' ? FUNCMETH : METHOD;
4118 /* Encoded script support. filter_add() effectively inserts a
4119 * 'pre-processing' function into the current source input stream.
4120 * Note that the filter function only applies to the current source file
4121 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4123 * The datasv parameter (which may be NULL) can be used to pass
4124 * private data to this instance of the filter. The filter function
4125 * can recover the SV using the FILTER_DATA macro and use it to
4126 * store private buffers and state information.
4128 * The supplied datasv parameter is upgraded to a PVIO type
4129 * and the IoDIRP/IoANY field is used to store the function pointer,
4130 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4131 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4132 * private use must be set using malloc'd pointers.
4136 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4144 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4145 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4147 if (!PL_rsfp_filters)
4148 PL_rsfp_filters = newAV();
4151 SvUPGRADE(datasv, SVt_PVIO);
4152 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4153 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4154 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4155 FPTR2DPTR(void *, IoANY(datasv)),
4156 SvPV_nolen(datasv)));
4157 av_unshift(PL_rsfp_filters, 1);
4158 av_store(PL_rsfp_filters, 0, datasv) ;
4160 !PL_parser->filtered
4161 && PL_parser->lex_flags & LEX_EVALBYTES
4162 && PL_bufptr < PL_bufend
4164 const char *s = PL_bufptr;
4165 while (s < PL_bufend) {
4167 SV *linestr = PL_parser->linestr;
4168 char *buf = SvPVX(linestr);
4169 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4170 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4171 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4172 STRLEN const linestart_pos = PL_parser->linestart - buf;
4173 STRLEN const last_uni_pos =
4174 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4175 STRLEN const last_lop_pos =
4176 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4177 av_push(PL_rsfp_filters, linestr);
4178 PL_parser->linestr =
4179 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4180 buf = SvPVX(PL_parser->linestr);
4181 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4182 PL_parser->bufptr = buf + bufptr_pos;
4183 PL_parser->oldbufptr = buf + oldbufptr_pos;
4184 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4185 PL_parser->linestart = buf + linestart_pos;
4186 if (PL_parser->last_uni)
4187 PL_parser->last_uni = buf + last_uni_pos;
4188 if (PL_parser->last_lop)
4189 PL_parser->last_lop = buf + last_lop_pos;
4190 SvLEN(linestr) = SvCUR(linestr);
4191 SvCUR(linestr) = s-SvPVX(linestr);
4192 PL_parser->filtered = 1;
4202 /* Delete most recently added instance of this filter function. */
4204 Perl_filter_del(pTHX_ filter_t funcp)
4208 PERL_ARGS_ASSERT_FILTER_DEL;
4211 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4212 FPTR2DPTR(void*, funcp)));
4214 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4216 /* if filter is on top of stack (usual case) just pop it off */
4217 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4218 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4219 sv_free(av_pop(PL_rsfp_filters));
4223 /* we need to search for the correct entry and clear it */
4224 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4228 /* Invoke the idxth filter function for the current rsfp. */
4229 /* maxlen 0 = read one text line */
4231 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4235 /* This API is bad. It should have been using unsigned int for maxlen.
4236 Not sure if we want to change the API, but if not we should sanity
4237 check the value here. */
4238 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4240 PERL_ARGS_ASSERT_FILTER_READ;
4242 if (!PL_parser || !PL_rsfp_filters)
4244 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4245 /* Provide a default input filter to make life easy. */
4246 /* Note that we append to the line. This is handy. */
4247 DEBUG_P(PerlIO_printf(Perl_debug_log,
4248 "filter_read %d: from rsfp\n", idx));
4249 if (correct_length) {
4252 const int old_len = SvCUR(buf_sv);
4254 /* ensure buf_sv is large enough */
4255 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4256 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4257 correct_length)) <= 0) {
4258 if (PerlIO_error(PL_rsfp))
4259 return -1; /* error */
4261 return 0 ; /* end of file */
4263 SvCUR_set(buf_sv, old_len + len) ;
4264 SvPVX(buf_sv)[old_len + len] = '\0';
4267 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4268 if (PerlIO_error(PL_rsfp))
4269 return -1; /* error */
4271 return 0 ; /* end of file */
4274 return SvCUR(buf_sv);
4276 /* Skip this filter slot if filter has been deleted */
4277 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4278 DEBUG_P(PerlIO_printf(Perl_debug_log,
4279 "filter_read %d: skipped (filter deleted)\n",
4281 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4283 if (SvTYPE(datasv) != SVt_PVIO) {
4284 if (correct_length) {
4286 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4287 if (!remainder) return 0; /* eof */
4288 if (correct_length > remainder) correct_length = remainder;
4289 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4290 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4293 const char *s = SvEND(datasv);
4294 const char *send = SvPVX(datasv) + SvLEN(datasv);
4302 if (s == send) return 0; /* eof */
4303 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4304 SvCUR_set(datasv, s-SvPVX(datasv));
4306 return SvCUR(buf_sv);
4308 /* Get function pointer hidden within datasv */
4309 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4310 DEBUG_P(PerlIO_printf(Perl_debug_log,
4311 "filter_read %d: via function %p (%s)\n",
4312 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4313 /* Call function. The function is expected to */
4314 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4315 /* Return: <0:error, =0:eof, >0:not eof */
4316 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4320 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4322 PERL_ARGS_ASSERT_FILTER_GETS;
4324 #ifdef PERL_CR_FILTER
4325 if (!PL_rsfp_filters) {
4326 filter_add(S_cr_textfilter,NULL);
4329 if (PL_rsfp_filters) {
4331 SvCUR_set(sv, 0); /* start with empty line */
4332 if (FILTER_READ(0, sv, 0) > 0)
4333 return ( SvPVX(sv) ) ;
4338 return (sv_gets(sv, PL_rsfp, append));
4342 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4346 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4348 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4352 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4353 && (gv = gv_fetchpvn_flags(pkgname,
4355 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4357 return GvHV(gv); /* Foo:: */
4360 /* use constant CLASS => 'MyClass' */
4361 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4362 if (gv && GvCV(gv)) {
4363 SV * const sv = cv_const_sv(GvCV(gv));
4365 return gv_stashsv(sv, 0);
4368 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4373 S_tokenize_use(pTHX_ int is_use, char *s) {
4374 PERL_ARGS_ASSERT_TOKENIZE_USE;
4376 if (PL_expect != XSTATE)
4377 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4378 is_use ? "use" : "no"));
4381 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4382 s = force_version(s, TRUE);
4383 if (*s == ';' || *s == '}'
4384 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4385 NEXTVAL_NEXTTOKE.opval = NULL;
4388 else if (*s == 'v') {
4389 s = force_word(s,WORD,FALSE,TRUE);
4390 s = force_version(s, FALSE);
4394 s = force_word(s,WORD,FALSE,TRUE);
4395 s = force_version(s, FALSE);
4397 pl_yylval.ival = is_use;
4401 static const char* const exp_name[] =
4402 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4403 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4408 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4410 S_word_takes_any_delimeter(char *p, STRLEN len)
4412 return (len == 1 && strchr("msyq", p[0]))
4414 && ((p[0] == 't' && p[1] == 'r')
4415 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4419 S_check_scalar_slice(pTHX_ char *s)
4422 while (*s == ' ' || *s == '\t') s++;
4423 if (*s == 'q' && s[1] == 'w'
4424 && !isWORDCHAR_lazy_if(s+2,UTF))
4426 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4427 s += UTF ? UTF8SKIP(s) : 1;
4428 if (*s == '}' || *s == ']')
4429 pl_yylval.ival = OPpSLICEWARNING;
4435 Works out what to call the token just pulled out of the input
4436 stream. The yacc parser takes care of taking the ops we return and
4437 stitching them into a tree.
4440 The type of the next token
4443 Switch based on the current state:
4444 - if we already built the token before, use it
4445 - if we have a case modifier in a string, deal with that
4446 - handle other cases of interpolation inside a string
4447 - scan the next line if we are inside a format
4448 In the normal state switch on the next character:
4450 if alphabetic, go to key lookup
4451 unrecoginized character - croak
4452 - 0/4/26: handle end-of-line or EOF
4453 - cases for whitespace
4454 - \n and #: handle comments and line numbers
4455 - various operators, brackets and sigils
4458 - 'v': vstrings (or go to key lookup)
4459 - 'x' repetition operator (or go to key lookup)
4460 - other ASCII alphanumerics (key lookup begins here):
4463 scan built-in keyword (but do nothing with it yet)
4464 check for statement label
4465 check for lexical subs
4466 goto just_a_word if there is one
4467 see whether built-in keyword is overridden
4468 switch on keyword number:
4469 - default: just_a_word:
4470 not a built-in keyword; handle bareword lookup
4471 disambiguate between method and sub call
4472 fall back to bareword
4473 - cases for built-in keywords
4481 char *s = PL_bufptr;
4485 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4489 /* orig_keyword, gvp, and gv are initialized here because
4490 * jump to the label just_a_word_zero can bypass their
4491 * initialization later. */
4492 I32 orig_keyword = 0;
4497 SV* tmp = newSVpvs("");
4498 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4499 (IV)CopLINE(PL_curcop),
4500 lex_state_names[PL_lex_state],
4501 exp_name[PL_expect],
4502 pv_display(tmp, s, strlen(s), 0, 60));
4506 /* when we've already built the next token, just pull it out of the queue */
4509 pl_yylval = PL_nextval[PL_nexttoke];
4511 PL_lex_state = PL_lex_defer;
4512 PL_lex_defer = LEX_NORMAL;
4516 next_type = PL_nexttype[PL_nexttoke];
4517 if (next_type & (7<<24)) {
4518 if (next_type & (1<<24)) {
4519 if (PL_lex_brackets > 100)
4520 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4521 PL_lex_brackstack[PL_lex_brackets++] =
4522 (char) ((next_type >> 16) & 0xff);
4524 if (next_type & (2<<24))
4525 PL_lex_allbrackets++;
4526 if (next_type & (4<<24))
4527 PL_lex_allbrackets--;
4528 next_type &= 0xffff;
4530 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4534 switch (PL_lex_state) {
4536 case LEX_INTERPNORMAL:
4539 /* interpolated case modifiers like \L \U, including \Q and \E.
4540 when we get here, PL_bufptr is at the \
4542 case LEX_INTERPCASEMOD:
4544 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4546 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4547 PL_bufptr, PL_bufend, *PL_bufptr);
4549 /* handle \E or end of string */
4550 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4552 if (PL_lex_casemods) {
4553 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4554 PL_lex_casestack[PL_lex_casemods] = '\0';
4556 if (PL_bufptr != PL_bufend
4557 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4558 || oldmod == 'F')) {
4560 PL_lex_state = LEX_INTERPCONCAT;
4562 PL_lex_allbrackets--;
4565 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4566 /* Got an unpaired \E */
4567 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4568 "Useless use of \\E");
4570 if (PL_bufptr != PL_bufend)
4572 PL_lex_state = LEX_INTERPCONCAT;
4576 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4577 "### Saw case modifier\n"); });
4579 if (s[1] == '\\' && s[2] == 'E') {
4581 PL_lex_state = LEX_INTERPCONCAT;
4586 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4587 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4588 if ((*s == 'L' || *s == 'U' || *s == 'F')
4589 && (strchr(PL_lex_casestack, 'L')
4590 || strchr(PL_lex_casestack, 'U')
4591 || strchr(PL_lex_casestack, 'F')))
4593 PL_lex_casestack[--PL_lex_casemods] = '\0';
4594 PL_lex_allbrackets--;
4597 if (PL_lex_casemods > 10)
4598 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4599 PL_lex_casestack[PL_lex_casemods++] = *s;
4600 PL_lex_casestack[PL_lex_casemods] = '\0';
4601 PL_lex_state = LEX_INTERPCONCAT;
4602 NEXTVAL_NEXTTOKE.ival = 0;
4603 force_next((2<<24)|'(');
4605 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4607 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4609 NEXTVAL_NEXTTOKE.ival = OP_LC;
4611 NEXTVAL_NEXTTOKE.ival = OP_UC;
4613 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4615 NEXTVAL_NEXTTOKE.ival = OP_FC;
4617 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4621 if (PL_lex_starts) {
4624 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4625 if (PL_lex_casemods == 1 && PL_lex_inpat)
4628 AopNOASSIGN(OP_CONCAT);
4634 case LEX_INTERPPUSH:
4635 return REPORT(sublex_push());
4637 case LEX_INTERPSTART:
4638 if (PL_bufptr == PL_bufend)
4639 return REPORT(sublex_done());
4640 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4641 "### Interpolated variable\n"); });
4643 /* for /@a/, we leave the joining for the regex engine to do
4644 * (unless we're within \Q etc) */
4645 PL_lex_dojoin = (*PL_bufptr == '@'
4646 && (!PL_lex_inpat || PL_lex_casemods));
4647 PL_lex_state = LEX_INTERPNORMAL;
4648 if (PL_lex_dojoin) {
4649 NEXTVAL_NEXTTOKE.ival = 0;
4651 force_ident("\"", '$');
4652 NEXTVAL_NEXTTOKE.ival = 0;
4654 NEXTVAL_NEXTTOKE.ival = 0;
4655 force_next((2<<24)|'(');
4656 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4659 /* Convert (?{...}) and friends to 'do {...}' */
4660 if (PL_lex_inpat && *PL_bufptr == '(') {
4661 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4663 if (*PL_bufptr != '{')
4665 PL_expect = XTERMBLOCK;
4669 if (PL_lex_starts++) {
4671 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4672 if (!PL_lex_casemods && PL_lex_inpat)
4675 AopNOASSIGN(OP_CONCAT);
4679 case LEX_INTERPENDMAYBE:
4680 if (intuit_more(PL_bufptr)) {
4681 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4687 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4688 XXX This hack can be removed if we stop setting PL_lex_state to
4689 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4690 if (UNLIKELY(!PL_lex_inwhat)) {
4691 PL_lex_state = LEX_NORMAL;
4695 if (PL_lex_dojoin) {
4696 const U8 dojoin_was = PL_lex_dojoin;
4697 PL_lex_dojoin = FALSE;
4698 PL_lex_state = LEX_INTERPCONCAT;
4699 PL_lex_allbrackets--;
4700 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4702 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4703 && SvEVALED(PL_lex_repl))
4705 if (PL_bufptr != PL_bufend)
4706 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4709 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4710 re_eval_str. If the here-doc body’s length equals the previous
4711 value of re_eval_start, re_eval_start will now be null. So
4712 check re_eval_str as well. */
4713 if (PL_parser->lex_shared->re_eval_start
4714 || PL_parser->lex_shared->re_eval_str) {
4716 if (*PL_bufptr != ')')
4717 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4719 /* having compiled a (?{..}) expression, return the original
4720 * text too, as a const */
4721 if (PL_parser->lex_shared->re_eval_str) {
4722 sv = PL_parser->lex_shared->re_eval_str;
4723 PL_parser->lex_shared->re_eval_str = NULL;
4725 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4726 SvPV_shrink_to_cur(sv);
4728 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4729 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4730 NEXTVAL_NEXTTOKE.opval =
4731 (OP*)newSVOP(OP_CONST, 0,
4734 PL_parser->lex_shared->re_eval_start = NULL;
4740 case LEX_INTERPCONCAT:
4742 if (PL_lex_brackets)
4743 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4744 (long) PL_lex_brackets);
4746 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4747 XXX This hack can be removed if we stop setting PL_lex_state to
4749 if (UNLIKELY(!PL_lex_inwhat)) {
4750 PL_lex_state = LEX_NORMAL;
4754 if (PL_bufptr == PL_bufend)
4755 return REPORT(sublex_done());
4757 /* m'foo' still needs to be parsed for possible (?{...}) */
4758 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4759 SV *sv = newSVsv(PL_linestr);
4761 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4765 s = scan_const(PL_bufptr);
4767 PL_lex_state = LEX_INTERPCASEMOD;
4769 PL_lex_state = LEX_INTERPSTART;
4772 if (s != PL_bufptr) {
4773 NEXTVAL_NEXTTOKE = pl_yylval;
4776 if (PL_lex_starts++) {
4777 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4778 if (!PL_lex_casemods && PL_lex_inpat)
4781 AopNOASSIGN(OP_CONCAT);
4791 s = scan_formline(PL_bufptr);
4792 if (!PL_lex_formbrack)
4801 /* We really do *not* want PL_linestr ever becoming a COW. */
4802 assert (!SvIsCOW(PL_linestr));
4804 PL_oldoldbufptr = PL_oldbufptr;
4806 PL_parser->saw_infix_sigil = 0;
4812 if (! isUTF8_CHAR((U8 *) s, (U8 *) PL_bufend)) {
4814 SAVESPTR(PL_warnhook);
4815 PL_warnhook = PERL_WARNHOOK_FATAL;
4816 utf8n_to_uvchr((U8*)s, PL_bufend-s, NULL, 0);
4819 if (isIDFIRST_utf8((U8*)s)) {
4823 else if (isALNUMC(*s)) {
4827 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4828 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4830 SVs_TEMP | SVf_UTF8),
4831 10, UNI_DISPLAY_ISPRINT)
4832 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4833 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4834 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4835 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4839 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4840 UTF8fARG(UTF, (s - d), d),
4845 goto fake_eof; /* emulate EOF on ^D or ^Z */
4847 if ((!PL_rsfp || PL_lex_inwhat)
4848 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4852 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
4854 yyerror((const char *)
4856 ? "Format not terminated"
4857 : "Missing right curly or square bracket"));
4859 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4860 "### Tokener got EOF\n");
4864 if (s++ < PL_bufend)
4865 goto retry; /* ignore stray nulls */
4868 if (!PL_in_eval && !PL_preambled) {
4869 PL_preambled = TRUE;
4871 /* Generate a string of Perl code to load the debugger.
4872 * If PERL5DB is set, it will return the contents of that,
4873 * otherwise a compile-time require of perl5db.pl. */
4875 const char * const pdb = PerlEnv_getenv("PERL5DB");
4878 sv_setpv(PL_linestr, pdb);
4879 sv_catpvs(PL_linestr,";");
4881 SETERRNO(0,SS_NORMAL);
4882 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4884 PL_parser->preambling = CopLINE(PL_curcop);
4886 sv_setpvs(PL_linestr,"");
4887 if (PL_preambleav) {
4888 SV **svp = AvARRAY(PL_preambleav);
4889 SV **const end = svp + AvFILLp(PL_preambleav);
4891 sv_catsv(PL_linestr, *svp);
4893 sv_catpvs(PL_linestr, ";");
4895 sv_free(MUTABLE_SV(PL_preambleav));
4896 PL_preambleav = NULL;
4899 sv_catpvs(PL_linestr,
4900 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4901 if (PL_minus_n || PL_minus_p) {
4902 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4904 sv_catpvs(PL_linestr,"chomp;");
4907 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4908 || *PL_splitstr == '"')
4909 && strchr(PL_splitstr + 1, *PL_splitstr))
4910 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4912 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4913 bytes can be used as quoting characters. :-) */
4914 const char *splits = PL_splitstr;
4915 sv_catpvs(PL_linestr, "our @F=split(q\0");
4918 if (*splits == '\\')
4919 sv_catpvn(PL_linestr, splits, 1);
4920 sv_catpvn(PL_linestr, splits, 1);
4921 } while (*splits++);
4922 /* This loop will embed the trailing NUL of
4923 PL_linestr as the last thing it does before
4925 sv_catpvs(PL_linestr, ");");
4929 sv_catpvs(PL_linestr,"our @F=split(' ');");
4932 sv_catpvs(PL_linestr, "\n");
4933 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4934 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4935 PL_last_lop = PL_last_uni = NULL;
4936 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4937 update_debugger_info(PL_linestr, NULL, 0);
4942 bof = PL_rsfp ? TRUE : FALSE;
4945 fake_eof = LEX_FAKE_EOF;
4947 PL_bufptr = PL_bufend;
4948 COPLINE_INC_WITH_HERELINES;
4949 if (!lex_next_chunk(fake_eof)) {
4950 CopLINE_dec(PL_curcop);
4952 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4954 CopLINE_dec(PL_curcop);
4956 /* If it looks like the start of a BOM or raw UTF-16,
4957 * check if it in fact is. */
4960 || *(U8*)s == BOM_UTF8_FIRST_BYTE
4964 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4965 bof = (offset == (Off_t)SvCUR(PL_linestr));
4966 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4967 /* offset may include swallowed CR */
4969 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4972 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4973 s = swallow_bom((U8*)s);
4976 if (PL_parser->in_pod) {
4977 /* Incest with pod. */
4978 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4979 sv_setpvs(PL_linestr, "");
4980 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4981 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4982 PL_last_lop = PL_last_uni = NULL;
4983 PL_parser->in_pod = 0;
4986 if (PL_rsfp || PL_parser->filtered)
4988 } while (PL_parser->in_pod);
4989 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4990 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4991 PL_last_lop = PL_last_uni = NULL;
4992 if (CopLINE(PL_curcop) == 1) {
4993 while (s < PL_bufend && isSPACE(*s))
4995 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4999 if (*s == '#' && *(s+1) == '!')
5001 #ifdef ALTERNATE_SHEBANG
5003 static char const as[] = ALTERNATE_SHEBANG;
5004 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5005 d = s + (sizeof(as) - 1);
5007 #endif /* ALTERNATE_SHEBANG */
5016 while (*d && !isSPACE(*d))
5020 #ifdef ARG_ZERO_IS_SCRIPT
5021 if (ipathend > ipath) {
5023 * HP-UX (at least) sets argv[0] to the script name,
5024 * which makes $^X incorrect. And Digital UNIX and Linux,
5025 * at least, set argv[0] to the basename of the Perl
5026 * interpreter. So, having found "#!", we'll set it right.
5028 SV* copfilesv = CopFILESV(PL_curcop);
5031 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5033 assert(SvPOK(x) || SvGMAGICAL(x));
5034 if (sv_eq(x, copfilesv)) {
5035 sv_setpvn(x, ipath, ipathend - ipath);
5041 const char *bstart = SvPV_const(copfilesv, blen);
5042 const char * const lstart = SvPV_const(x, llen);
5044 bstart += blen - llen;
5045 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5046 sv_setpvn(x, ipath, ipathend - ipath);
5053 /* Anything to do if no copfilesv? */
5055 TAINT_NOT; /* $^X is always tainted, but that's OK */
5057 #endif /* ARG_ZERO_IS_SCRIPT */
5062 d = instr(s,"perl -");
5064 d = instr(s,"perl");
5065 if (d && d[4] == '6')
5068 /* avoid getting into infinite loops when shebang
5069 * line contains "Perl" rather than "perl" */
5071 for (d = ipathend-4; d >= ipath; --d) {
5072 if (isALPHA_FOLD_EQ(*d, 'p')
5073 && !ibcmp(d, "perl", 4))
5083 #ifdef ALTERNATE_SHEBANG
5085 * If the ALTERNATE_SHEBANG on this system starts with a
5086 * character that can be part of a Perl expression, then if
5087 * we see it but not "perl", we're probably looking at the
5088 * start of Perl code, not a request to hand off to some
5089 * other interpreter. Similarly, if "perl" is there, but
5090 * not in the first 'word' of the line, we assume the line
5091 * contains the start of the Perl program.
5093 if (d && *s != '#') {
5094 const char *c = ipath;
5095 while (*c && !strchr("; \t\r\n\f\v#", *c))
5098 d = NULL; /* "perl" not in first word; ignore */
5100 *s = '#'; /* Don't try to parse shebang line */
5102 #endif /* ALTERNATE_SHEBANG */
5107 && !instr(s,"indir")
5108 && instr(PL_origargv[0],"perl"))
5115 while (s < PL_bufend && isSPACE(*s))
5117 if (s < PL_bufend) {
5118 Newx(newargv,PL_origargc+3,char*);
5120 while (s < PL_bufend && !isSPACE(*s))
5123 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5126 newargv = PL_origargv;
5129 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5131 Perl_croak(aTHX_ "Can't exec %s", ipath);
5134 while (*d && !isSPACE(*d))
5136 while (SPACE_OR_TAB(*d))
5140 const bool switches_done = PL_doswitches;
5141 const U32 oldpdb = PL_perldb;
5142 const bool oldn = PL_minus_n;
5143 const bool oldp = PL_minus_p;
5147 bool baduni = FALSE;
5149 const char *d2 = d1 + 1;
5150 if (parse_unicode_opts((const char **)&d2)
5154 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5155 const char * const m = d1;
5156 while (*d1 && !isSPACE(*d1))
5158 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5161 d1 = moreswitches(d1);
5163 if (PL_doswitches && !switches_done) {
5164 int argc = PL_origargc;
5165 char **argv = PL_origargv;
5168 } while (argc && argv[0][0] == '-' && argv[0][1]);
5169 init_argv_symbols(argc,argv);
5171 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5172 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5173 /* if we have already added "LINE: while (<>) {",
5174 we must not do it again */
5176 sv_setpvs(PL_linestr, "");
5177 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5178 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5179 PL_last_lop = PL_last_uni = NULL;
5180 PL_preambled = FALSE;
5181 if (PERLDB_LINE_OR_SAVESRC)
5182 (void)gv_fetchfile(PL_origfilename);
5189 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5190 PL_lex_state = LEX_FORMLINE;
5191 force_next(FORMRBRACK);
5196 #ifdef PERL_STRICT_CR
5197 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5199 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5201 case ' ': case '\t': case '\f': case '\v':
5206 if (PL_lex_state != LEX_NORMAL
5207 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5209 const bool in_comment = *s == '#';
5210 if (*s == '#' && s == PL_linestart && PL_in_eval
5211 && !PL_rsfp && !PL_parser->filtered) {
5212 /* handle eval qq[#line 1 "foo"\n ...] */
5213 CopLINE_dec(PL_curcop);
5217 while (d < PL_bufend && *d != '\n')
5221 else if (d > PL_bufend)
5222 /* Found by Ilya: feed random input to Perl. */
5223 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5226 if (in_comment && d == PL_bufend
5227 && PL_lex_state == LEX_INTERPNORMAL
5228 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5229 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5232 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5233 PL_lex_state = LEX_FORMLINE;
5234 force_next(FORMRBRACK);
5239 while (s < PL_bufend && *s != '\n')
5247 else if (s > PL_bufend)
5248 /* Found by Ilya: feed random input to Perl. */
5249 Perl_croak(aTHX_ "panic: input overflow");
5253 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5261 while (s < PL_bufend && SPACE_OR_TAB(*s))
5264 if (strnEQ(s,"=>",2)) {
5265 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5266 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5267 OPERATOR('-'); /* unary minus */
5270 case 'r': ftst = OP_FTEREAD; break;
5271 case 'w': ftst = OP_FTEWRITE; break;
5272 case 'x': ftst = OP_FTEEXEC; break;
5273 case 'o': ftst = OP_FTEOWNED; break;
5274 case 'R': ftst = OP_FTRREAD; break;
5275 case 'W': ftst = OP_FTRWRITE; break;
5276 case 'X': ftst = OP_FTREXEC; break;
5277 case 'O': ftst = OP_FTROWNED; break;
5278 case 'e': ftst = OP_FTIS; break;
5279 case 'z': ftst = OP_FTZERO; break;
5280 case 's': ftst = OP_FTSIZE; break;
5281 case 'f': ftst = OP_FTFILE; break;
5282 case 'd': ftst = OP_FTDIR; break;
5283 case 'l': ftst = OP_FTLINK; break;
5284 case 'p': ftst = OP_FTPIPE; break;
5285 case 'S': ftst = OP_FTSOCK; break;
5286 case 'u': ftst = OP_FTSUID; break;
5287 case 'g': ftst = OP_FTSGID; break;
5288 case 'k': ftst = OP_FTSVTX; break;
5289 case 'b': ftst = OP_FTBLK; break;
5290 case 'c': ftst = OP_FTCHR; break;
5291 case 't': ftst = OP_FTTTY; break;
5292 case 'T': ftst = OP_FTTEXT; break;
5293 case 'B': ftst = OP_FTBINARY; break;
5294 case 'M': case 'A': case 'C':
5295 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5297 case 'M': ftst = OP_FTMTIME; break;
5298 case 'A': ftst = OP_FTATIME; break;
5299 case 'C': ftst = OP_FTCTIME; break;
5307 PL_last_uni = PL_oldbufptr;
5308 PL_last_lop_op = (OPCODE)ftst;
5309 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5310 "### Saw file test %c\n", (int)tmp);
5315 /* Assume it was a minus followed by a one-letter named
5316 * subroutine call (or a -bareword), then. */
5317 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5318 "### '-%c' looked like a file test but was not\n",
5325 const char tmp = *s++;
5328 if (PL_expect == XOPERATOR)
5333 else if (*s == '>') {
5336 if (((*s == '$' || *s == '&') && s[1] == '*')
5337 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5338 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5339 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5342 PL_expect = XPOSTDEREF;
5345 if (isIDFIRST_lazy_if(s,UTF)) {
5346 s = force_word(s,METHOD,FALSE,TRUE);
5354 if (PL_expect == XOPERATOR) {
5356 && !PL_lex_allbrackets
5357 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5365 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5367 OPERATOR('-'); /* unary minus */
5373 const char tmp = *s++;
5376 if (PL_expect == XOPERATOR)
5381 if (PL_expect == XOPERATOR) {
5383 && !PL_lex_allbrackets
5384 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5392 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5399 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5400 if (PL_expect != XOPERATOR) {
5401 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5402 PL_expect = XOPERATOR;
5403 force_ident(PL_tokenbuf, '*');
5411 if (*s == '=' && !PL_lex_allbrackets
5412 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5420 && !PL_lex_allbrackets
5421 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5426 PL_parser->saw_infix_sigil = 1;
5431 if (PL_expect == XOPERATOR) {
5433 && !PL_lex_allbrackets
5434 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5439 PL_parser->saw_infix_sigil = 1;
5442 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5443 PL_tokenbuf[0] = '%';
5444 s = scan_ident(s, PL_tokenbuf + 1,
5445 sizeof PL_tokenbuf - 1, FALSE);
5447 if (!PL_tokenbuf[1]) {
5450 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5452 PL_tokenbuf[0] = '@';
5454 PL_expect = XOPERATOR;
5455 force_ident_maybe_lex('%');
5460 bof = FEATURE_BITWISE_IS_ENABLED;
5461 if (bof && s[1] == '.')
5463 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5464 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5470 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5472 if (PL_lex_brackets > 100)
5473 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5474 PL_lex_brackstack[PL_lex_brackets++] = 0;
5475 PL_lex_allbrackets++;
5477 const char tmp = *s++;
5482 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5484 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5487 Perl_ck_warner_d(aTHX_
5488 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5489 "Smartmatch is experimental");
5493 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5495 BCop(OP_SCOMPLEMENT);
5497 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5499 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5506 goto just_a_word_zero_gv;
5512 switch (PL_expect) {
5514 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5516 PL_bufptr = s; /* update in case we back off */
5519 "Use of := for an empty attribute list is not allowed");
5526 PL_expect = XTERMBLOCK;
5530 while (isIDFIRST_lazy_if(s,UTF)) {
5533 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5534 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5535 if (tmp < 0) tmp = -tmp;
5550 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5552 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5553 COPLINE_SET_FROM_MULTI_END;
5555 /* MUST advance bufptr here to avoid bogus
5556 "at end of line" context messages from yyerror().
5558 PL_bufptr = s + len;
5559 yyerror("Unterminated attribute parameter in attribute list");
5563 return REPORT(0); /* EOF indicator */
5567 sv_catsv(sv, PL_lex_stuff);
5568 attrs = op_append_elem(OP_LIST, attrs,
5569 newSVOP(OP_CONST, 0, sv));
5570 SvREFCNT_dec_NN(PL_lex_stuff);
5571 PL_lex_stuff = NULL;
5574 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5576 if (PL_in_my == KEY_our) {
5577 deprecate(":unique");
5580 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5583 /* NOTE: any CV attrs applied here need to be part of
5584 the CVf_BUILTIN_ATTRS define in cv.h! */
5585 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5587 CvLVALUE_on(PL_compcv);
5589 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5591 deprecate(":locked");
5593 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5595 CvMETHOD_on(PL_compcv);
5597 else if (!PL_in_my && len == 5
5598 && strnEQ(SvPVX(sv), "const", len))
5601 Perl_ck_warner_d(aTHX_
5602 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5603 ":const is experimental"
5605 CvANONCONST_on(PL_compcv);
5606 if (!CvANON(PL_compcv))
5607 yyerror(":const is not permitted on named "
5610 /* After we've set the flags, it could be argued that
5611 we don't need to do the attributes.pm-based setting
5612 process, and shouldn't bother appending recognized
5613 flags. To experiment with that, uncomment the
5614 following "else". (Note that's already been
5615 uncommented. That keeps the above-applied built-in
5616 attributes from being intercepted (and possibly
5617 rejected) by a package's attribute routines, but is
5618 justified by the performance win for the common case
5619 of applying only built-in attributes.) */
5621 attrs = op_append_elem(OP_LIST, attrs,
5622 newSVOP(OP_CONST, 0,
5626 if (*s == ':' && s[1] != ':')
5629 break; /* require real whitespace or :'s */
5630 /* XXX losing whitespace on sequential attributes here */
5635 && !(PL_expect == XOPERATOR
5636 ? (*s == '=' || *s == ')')
5637 : (*s == '{' || *s == '(')))
5639 const char q = ((*s == '\'') ? '"' : '\'');
5640 /* If here for an expression, and parsed no attrs, back
5642 if (PL_expect == XOPERATOR && !attrs) {
5646 /* MUST advance bufptr here to avoid bogus "at end of line"
5647 context messages from yyerror().
5650 yyerror( (const char *)
5652 ? Perl_form(aTHX_ "Invalid separator character "
5653 "%c%c%c in attribute list", q, *s, q)
5654 : "Unterminated attribute list" ) );
5662 NEXTVAL_NEXTTOKE.opval = attrs;
5668 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5672 PL_lex_allbrackets--;
5676 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5677 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5681 PL_lex_allbrackets++;
5684 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5691 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5694 PL_lex_allbrackets--;
5700 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5703 if (PL_lex_brackets <= 0)
5704 /* diag_listed_as: Unmatched right %s bracket */
5705 yyerror("Unmatched right square bracket");
5708 PL_lex_allbrackets--;
5709 if (PL_lex_state == LEX_INTERPNORMAL) {
5710 if (PL_lex_brackets == 0) {
5711 if (*s == '-' && s[1] == '>')
5712 PL_lex_state = LEX_INTERPENDMAYBE;
5713 else if (*s != '[' && *s != '{')
5714 PL_lex_state = LEX_INTERPEND;
5721 if (PL_lex_brackets > 100) {
5722 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5724 switch (PL_expect) {
5727 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5728 PL_lex_allbrackets++;
5729 OPERATOR(HASHBRACK);
5731 while (s < PL_bufend && SPACE_OR_TAB(*s))
5734 PL_tokenbuf[0] = '\0';
5735 if (d < PL_bufend && *d == '-') {
5736 PL_tokenbuf[0] = '-';
5738 while (d < PL_bufend && SPACE_OR_TAB(*d))
5741 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5742 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5744 while (d < PL_bufend && SPACE_OR_TAB(*d))
5747 const char minus = (PL_tokenbuf[0] == '-');
5748 s = force_word(s + minus, WORD, FALSE, TRUE);
5756 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5757 PL_lex_allbrackets++;
5762 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5763 PL_lex_allbrackets++;
5767 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5768 PL_lex_allbrackets++;
5773 if (PL_oldoldbufptr == PL_last_lop)
5774 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5776 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5777 PL_lex_allbrackets++;
5780 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5782 /* This hack is to get the ${} in the message. */
5784 yyerror("syntax error");
5787 OPERATOR(HASHBRACK);
5789 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5790 /* ${...} or @{...} etc., but not print {...}
5791 * Skip the disambiguation and treat this as a block.
5793 goto block_expectation;
5795 /* This hack serves to disambiguate a pair of curlies
5796 * as being a block or an anon hash. Normally, expectation
5797 * determines that, but in cases where we're not in a
5798 * position to expect anything in particular (like inside
5799 * eval"") we have to resolve the ambiguity. This code
5800 * covers the case where the first term in the curlies is a
5801 * quoted string. Most other cases need to be explicitly
5802 * disambiguated by prepending a "+" before the opening
5803 * curly in order to force resolution as an anon hash.
5805 * XXX should probably propagate the outer expectation
5806 * into eval"" to rely less on this hack, but that could
5807 * potentially break current behavior of eval"".
5811 if (*s == '\'' || *s == '"' || *s == '`') {
5812 /* common case: get past first string, handling escapes */
5813 for (t++; t < PL_bufend && *t != *s;)
5818 else if (*s == 'q') {
5821 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5822 && !isWORDCHAR(*t))))
5824 /* skip q//-like construct */
5826 char open, close, term;
5829 while (t < PL_bufend && isSPACE(*t))
5831 /* check for q => */
5832 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5833 OPERATOR(HASHBRACK);
5837 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5841 for (t++; t < PL_bufend; t++) {
5842 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5844 else if (*t == open)
5848 for (t++; t < PL_bufend; t++) {
5849 if (*t == '\\' && t+1 < PL_bufend)
5851 else if (*t == close && --brackets <= 0)
5853 else if (*t == open)
5860 /* skip plain q word */
5861 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5862 t += UTF ? UTF8SKIP(t) : 1;
5864 else if (isWORDCHAR_lazy_if(t,UTF)) {
5865 t += UTF ? UTF8SKIP(t) : 1;
5866 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5867 t += UTF ? UTF8SKIP(t) : 1;
5869 while (t < PL_bufend && isSPACE(*t))
5871 /* if comma follows first term, call it an anon hash */
5872 /* XXX it could be a comma expression with loop modifiers */
5873 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5874 || (*t == '=' && t[1] == '>')))
5875 OPERATOR(HASHBRACK);
5876 if (PL_expect == XREF)
5879 /* If there is an opening brace or 'sub:', treat it
5880 as a term to make ${{...}}{k} and &{sub:attr...}
5881 dwim. Otherwise, treat it as a statement, so
5882 map {no strict; ...} works.
5889 if (strnEQ(s, "sub", 3)) {
5900 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5906 pl_yylval.ival = CopLINE(PL_curcop);
5907 PL_copline = NOLINE; /* invalidate current command line number */
5908 TOKEN(formbrack ? '=' : '{');
5910 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5914 if (PL_lex_brackets <= 0)
5915 /* diag_listed_as: Unmatched right %s bracket */
5916 yyerror("Unmatched right curly bracket");
5918 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5919 PL_lex_allbrackets--;
5920 if (PL_lex_state == LEX_INTERPNORMAL) {
5921 if (PL_lex_brackets == 0) {
5922 if (PL_expect & XFAKEBRACK) {
5923 PL_expect &= XENUMMASK;
5924 PL_lex_state = LEX_INTERPEND;
5926 return yylex(); /* ignore fake brackets */
5928 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5929 && SvEVALED(PL_lex_repl))
5930 PL_lex_state = LEX_INTERPEND;
5931 else if (*s == '-' && s[1] == '>')
5932 PL_lex_state = LEX_INTERPENDMAYBE;
5933 else if (*s != '[' && *s != '{')
5934 PL_lex_state = LEX_INTERPEND;
5937 if (PL_expect & XFAKEBRACK) {
5938 PL_expect &= XENUMMASK;
5940 return yylex(); /* ignore fake brackets */
5942 force_next(formbrack ? '.' : '}');
5943 if (formbrack) LEAVE;
5944 if (formbrack == 2) { /* means . where arguments were expected */
5950 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5953 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5954 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5961 if (PL_expect == XOPERATOR) {
5962 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5963 && isIDFIRST_lazy_if(s,UTF))
5965 CopLINE_dec(PL_curcop);
5966 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5967 CopLINE_inc(PL_curcop);
5970 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5972 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5973 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5979 PL_parser->saw_infix_sigil = 1;
5980 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5986 PL_tokenbuf[0] = '&';
5987 s = scan_ident(s - 1, PL_tokenbuf + 1,
5988 sizeof PL_tokenbuf - 1, TRUE);
5989 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5990 if (PL_tokenbuf[1]) {
5991 force_ident_maybe_lex('&');
6000 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6001 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6009 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6011 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6012 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6016 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6020 const char tmp = *s++;
6022 if (!PL_lex_allbrackets
6023 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6031 if (!PL_lex_allbrackets
6032 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6041 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6042 && strchr("+-*/%.^&|<",tmp))
6043 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6044 "Reversed %c= operator",(int)tmp);
6046 if (PL_expect == XSTATE
6048 && (s == PL_linestart+1 || s[-2] == '\n') )
6050 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6051 || PL_lex_state != LEX_NORMAL) {
6056 if (strnEQ(s,"=cut",4)) {
6070 PL_parser->in_pod = 1;
6074 if (PL_expect == XBLOCK) {
6076 #ifdef PERL_STRICT_CR
6077 while (SPACE_OR_TAB(*t))
6079 while (SPACE_OR_TAB(*t) || *t == '\r')
6082 if (*t == '\n' || *t == '#') {
6085 SAVEI8(PL_parser->form_lex_state);
6086 SAVEI32(PL_lex_formbrack);
6087 PL_parser->form_lex_state = PL_lex_state;
6088 PL_lex_formbrack = PL_lex_brackets + 1;
6092 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6101 const char tmp = *s++;
6103 /* was this !=~ where !~ was meant?
6104 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6106 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6107 const char *t = s+1;
6109 while (t < PL_bufend && isSPACE(*t))
6112 if (*t == '/' || *t == '?'
6113 || ((*t == 'm' || *t == 's' || *t == 'y')
6114 && !isWORDCHAR(t[1]))
6115 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6116 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6117 "!=~ should be !~");
6119 if (!PL_lex_allbrackets
6120 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6133 if (PL_expect != XOPERATOR) {
6134 if (s[1] != '<' && !strchr(s,'>'))
6136 if (s[1] == '<' && s[2] != '>')
6137 s = scan_heredoc(s);
6139 s = scan_inputsymbol(s);
6140 PL_expect = XOPERATOR;
6141 TOKEN(sublex_start());
6147 if (*s == '=' && !PL_lex_allbrackets
6148 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6153 SHop(OP_LEFT_SHIFT);
6158 if (!PL_lex_allbrackets
6159 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6167 if (!PL_lex_allbrackets
6168 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6177 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6185 const char tmp = *s++;
6187 if (*s == '=' && !PL_lex_allbrackets
6188 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6193 SHop(OP_RIGHT_SHIFT);
6195 else if (tmp == '=') {
6196 if (!PL_lex_allbrackets
6197 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6206 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6215 if (PL_expect == XOPERATOR) {
6216 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6217 return deprecate_commaless_var_list();
6220 else if (PL_expect == XPOSTDEREF) {
6223 POSTDEREF(DOLSHARP);
6228 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6229 PL_tokenbuf[0] = '@';
6230 s = scan_ident(s + 1, PL_tokenbuf + 1,
6231 sizeof PL_tokenbuf - 1, FALSE);
6232 if (PL_expect == XOPERATOR) {
6234 if (PL_bufptr > s) {
6236 PL_bufptr = PL_oldbufptr;
6238 no_op("Array length", d);
6240 if (!PL_tokenbuf[1])
6242 PL_expect = XOPERATOR;
6243 force_ident_maybe_lex('#');
6247 PL_tokenbuf[0] = '$';
6248 s = scan_ident(s, PL_tokenbuf + 1,
6249 sizeof PL_tokenbuf - 1, FALSE);
6250 if (PL_expect == XOPERATOR) {
6252 if (PL_bufptr > s) {
6254 PL_bufptr = PL_oldbufptr;
6258 if (!PL_tokenbuf[1]) {
6260 yyerror("Final $ should be \\$ or $name");
6266 const char tmp = *s;
6267 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6270 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6271 && intuit_more(s)) {
6273 PL_tokenbuf[0] = '@';
6274 if (ckWARN(WARN_SYNTAX)) {
6277 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6278 t += UTF ? UTF8SKIP(t) : 1;
6280 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6281 while (t < PL_bufend && *t != ']')
6283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6284 "Multidimensional syntax %"UTF8f" not supported",
6285 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6289 else if (*s == '{') {
6291 PL_tokenbuf[0] = '%';
6292 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6293 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6295 char tmpbuf[sizeof PL_tokenbuf];
6298 } while (isSPACE(*t));
6299 if (isIDFIRST_lazy_if(t,UTF)) {
6301 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6306 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6308 "You need to quote \"%"UTF8f"\"",
6309 UTF8fARG(UTF, len, tmpbuf));
6315 PL_expect = XOPERATOR;
6316 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6317 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6318 if (!islop || PL_last_lop_op == OP_GREPSTART)
6319 PL_expect = XOPERATOR;
6320 else if (strchr("$@\"'`q", *s))
6321 PL_expect = XTERM; /* e.g. print $fh "foo" */
6322 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6323 PL_expect = XTERM; /* e.g. print $fh &sub */
6324 else if (isIDFIRST_lazy_if(s,UTF)) {
6325 char tmpbuf[sizeof PL_tokenbuf];
6327 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6328 if ((t2 = keyword(tmpbuf, len, 0))) {
6329 /* binary operators exclude handle interpretations */
6341 PL_expect = XTERM; /* e.g. print $fh length() */
6346 PL_expect = XTERM; /* e.g. print $fh subr() */
6349 else if (isDIGIT(*s))
6350 PL_expect = XTERM; /* e.g. print $fh 3 */
6351 else if (*s == '.' && isDIGIT(s[1]))
6352 PL_expect = XTERM; /* e.g. print $fh .3 */
6353 else if ((*s == '?' || *s == '-' || *s == '+')
6354 && !isSPACE(s[1]) && s[1] != '=')
6355 PL_expect = XTERM; /* e.g. print $fh -1 */
6356 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6358 PL_expect = XTERM; /* e.g. print $fh /.../
6359 XXX except DORDOR operator
6361 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6363 PL_expect = XTERM; /* print $fh <<"EOF" */
6366 force_ident_maybe_lex('$');
6370 if (PL_expect == XPOSTDEREF)
6372 PL_tokenbuf[0] = '@';
6373 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6374 if (PL_expect == XOPERATOR) {
6376 if (PL_bufptr > s) {
6378 PL_bufptr = PL_oldbufptr;
6383 if (!PL_tokenbuf[1]) {
6386 if (PL_lex_state == LEX_NORMAL)
6388 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6390 PL_tokenbuf[0] = '%';
6392 /* Warn about @ where they meant $. */
6393 if (*s == '[' || *s == '{') {
6394 if (ckWARN(WARN_SYNTAX)) {
6395 S_check_scalar_slice(aTHX_ s);
6399 PL_expect = XOPERATOR;
6400 force_ident_maybe_lex('@');
6403 case '/': /* may be division, defined-or, or pattern */
6404 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6405 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6406 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6411 else if (PL_expect == XOPERATOR) {
6413 if (*s == '=' && !PL_lex_allbrackets
6414 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6422 /* Disable warning on "study /blah/" */
6423 if (PL_oldoldbufptr == PL_last_uni
6424 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6425 || memNE(PL_last_uni, "study", 5)
6426 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6429 s = scan_pat(s,OP_MATCH);
6430 TERM(sublex_start());
6433 case '?': /* conditional */
6435 if (!PL_lex_allbrackets
6436 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6441 PL_lex_allbrackets++;
6445 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6446 #ifdef PERL_STRICT_CR
6449 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6451 && (s == PL_linestart || s[-1] == '\n') )
6454 formbrack = 2; /* dot seen where arguments expected */
6457 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6461 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6464 if (!PL_lex_allbrackets
6465 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6473 pl_yylval.ival = OPf_SPECIAL;
6479 if (*s == '=' && !PL_lex_allbrackets
6480 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6488 case '0': case '1': case '2': case '3': case '4':
6489 case '5': case '6': case '7': case '8': case '9':
6490 s = scan_num(s, &pl_yylval);
6491 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6492 if (PL_expect == XOPERATOR)
6497 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6500 COPLINE_SET_FROM_MULTI_END;
6501 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6502 if (PL_expect == XOPERATOR) {
6503 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6504 return deprecate_commaless_var_list();
6509 pl_yylval.ival = OP_CONST;
6510 TERM(sublex_start());
6513 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6516 printbuf("### Saw string before %s\n", s);
6518 PerlIO_printf(Perl_debug_log,
6519 "### Saw unterminated string\n");
6521 if (PL_expect == XOPERATOR) {
6522 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6523 return deprecate_commaless_var_list();
6530 pl_yylval.ival = OP_CONST;
6531 /* FIXME. I think that this can be const if char *d is replaced by
6532 more localised variables. */
6533 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6534 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6535 pl_yylval.ival = OP_STRINGIFY;
6539 if (pl_yylval.ival == OP_CONST)
6540 COPLINE_SET_FROM_MULTI_END;
6541 TERM(sublex_start());
6544 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6547 printbuf("### Saw backtick string before %s\n", s);
6549 PerlIO_printf(Perl_debug_log,
6550 "### Saw unterminated backtick string\n");
6552 if (PL_expect == XOPERATOR)
6553 no_op("Backticks",s);
6556 pl_yylval.ival = OP_BACKTICK;
6557 TERM(sublex_start());
6561 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6563 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6565 if (PL_expect == XOPERATOR)
6566 no_op("Backslash",s);
6570 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6571 char *start = s + 2;
6572 while (isDIGIT(*start) || *start == '_')
6574 if (*start == '.' && isDIGIT(start[1])) {
6575 s = scan_num(s, &pl_yylval);
6578 else if ((*start == ':' && start[1] == ':')
6579 || (PL_expect == XSTATE && *start == ':'))
6581 else if (PL_expect == XSTATE) {
6583 while (d < PL_bufend && isSPACE(*d)) d++;
6584 if (*d == ':') goto keylookup;
6586 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6587 if (!isALPHA(*start) && (PL_expect == XTERM
6588 || PL_expect == XREF || PL_expect == XSTATE
6589 || PL_expect == XTERMORDORDOR)) {
6590 GV *const gv = gv_fetchpvn_flags(s, start - s,
6591 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6593 s = scan_num(s, &pl_yylval);
6600 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6653 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6655 /* Some keywords can be followed by any delimiter, including ':' */
6656 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6658 /* x::* is just a word, unless x is "CORE" */
6659 if (!anydelim && *s == ':' && s[1] == ':') {
6660 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6665 while (d < PL_bufend && isSPACE(*d))
6666 d++; /* no comments skipped here, or s### is misparsed */
6668 /* Is this a word before a => operator? */
6669 if (*d == '=' && d[1] == '>') {
6673 = (OP*)newSVOP(OP_CONST, 0,
6674 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6675 pl_yylval.opval->op_private = OPpCONST_BARE;
6679 /* Check for plugged-in keyword */
6683 char *saved_bufptr = PL_bufptr;
6685 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6687 if (result == KEYWORD_PLUGIN_DECLINE) {
6688 /* not a plugged-in keyword */
6689 PL_bufptr = saved_bufptr;
6690 } else if (result == KEYWORD_PLUGIN_STMT) {
6691 pl_yylval.opval = o;
6693 if (!PL_nexttoke) PL_expect = XSTATE;
6694 return REPORT(PLUGSTMT);
6695 } else if (result == KEYWORD_PLUGIN_EXPR) {
6696 pl_yylval.opval = o;
6698 if (!PL_nexttoke) PL_expect = XOPERATOR;
6699 return REPORT(PLUGEXPR);
6701 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6706 /* Check for built-in keyword */
6707 tmp = keyword(PL_tokenbuf, len, 0);
6709 /* Is this a label? */
6710 if (!anydelim && PL_expect == XSTATE
6711 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6713 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6714 pl_yylval.pval[len] = '\0';
6715 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6720 /* Check for lexical sub */
6721 if (PL_expect != XOPERATOR) {
6722 char tmpbuf[sizeof PL_tokenbuf + 1];
6724 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6725 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6726 if (off != NOT_IN_PAD) {
6727 assert(off); /* we assume this is boolean-true below */
6728 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6729 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6730 HEK * const stashname = HvNAME_HEK(stash);
6731 sv = newSVhek(stashname);
6732 sv_catpvs(sv, "::");
6733 sv_catpvn_flags(sv, PL_tokenbuf, len,
6734 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6735 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6745 rv2cv_op = newOP(OP_PADANY, 0);
6746 rv2cv_op->op_targ = off;
6747 cv = find_lexical_cv(off);
6755 if (tmp < 0) { /* second-class keyword? */
6756 GV *ogv = NULL; /* override (winner) */
6757 GV *hgv = NULL; /* hidden (loser) */
6758 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6760 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6761 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6763 && (cv = GvCVu(gv)))
6765 if (GvIMPORTED_CV(gv))
6767 else if (! CvMETHOD(cv))
6771 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6774 && (isGV_with_GP(gv)
6775 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6776 : SvPCS_IMPORTED(gv)
6777 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6785 tmp = 0; /* overridden by import or by GLOBAL */
6788 && -tmp==KEY_lock /* XXX generalizable kludge */
6791 tmp = 0; /* any sub overrides "weak" keyword */
6793 else { /* no override */
6795 if (tmp == KEY_dump) {
6796 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6797 "dump() better written as CORE::dump()");
6801 if (hgv && tmp != KEY_x) /* never ambiguous */
6802 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6803 "Ambiguous call resolved as CORE::%s(), "
6804 "qualify as such or use &",
6809 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6810 && (!anydelim || *s != '#')) {
6811 /* no override, and not s### either; skipspace is safe here
6812 * check for => on following line */
6814 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6815 STRLEN soff = s - SvPVX(PL_linestr);
6816 s = skipspace_flags(s, LEX_NO_INCLINE);
6817 arrow = *s == '=' && s[1] == '>';
6818 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6819 s = SvPVX(PL_linestr) + soff;
6827 default: /* not a keyword */
6828 /* Trade off - by using this evil construction we can pull the
6829 variable gv into the block labelled keylookup. If not, then
6830 we have to give it function scope so that the goto from the
6831 earlier ':' case doesn't bypass the initialisation. */
6833 just_a_word_zero_gv:
6845 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6849 /* Get the rest if it looks like a package qualifier */
6851 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6853 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6856 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6857 UTF8fARG(UTF, len, PL_tokenbuf),
6858 *s == '\'' ? "'" : "::");
6863 if (PL_expect == XOPERATOR) {
6864 if (PL_bufptr == PL_linestart) {
6865 CopLINE_dec(PL_curcop);
6866 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6867 CopLINE_inc(PL_curcop);
6870 no_op("Bareword",s);
6873 /* See if the name is "Foo::",
6874 in which case Foo is a bareword
6875 (and a package name). */
6878 && PL_tokenbuf[len - 2] == ':'
6879 && PL_tokenbuf[len - 1] == ':')
6881 if (ckWARN(WARN_BAREWORD)
6882 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6883 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6884 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6885 UTF8fARG(UTF, len, PL_tokenbuf));
6887 PL_tokenbuf[len] = '\0';
6896 /* if we saw a global override before, get the right name */
6899 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6902 SV * const tmp_sv = sv;
6903 sv = newSVpvs("CORE::GLOBAL::");
6904 sv_catsv(sv, tmp_sv);
6905 SvREFCNT_dec(tmp_sv);
6909 /* Presume this is going to be a bareword of some sort. */
6911 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6912 pl_yylval.opval->op_private = OPpCONST_BARE;
6914 /* And if "Foo::", then that's what it certainly is. */
6920 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6921 const_op->op_private = OPpCONST_BARE;
6923 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6927 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6930 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6933 /* Use this var to track whether intuit_method has been
6934 called. intuit_method returns 0 or > 255. */
6937 /* See if it's the indirect object for a list operator. */
6940 && PL_oldoldbufptr < PL_bufptr
6941 && (PL_oldoldbufptr == PL_last_lop
6942 || PL_oldoldbufptr == PL_last_uni)
6943 && /* NO SKIPSPACE BEFORE HERE! */
6945 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
6948 bool immediate_paren = *s == '(';
6950 /* (Now we can afford to cross potential line boundary.) */
6953 /* Two barewords in a row may indicate method call. */
6955 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$')
6956 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
6961 /* If not a declared subroutine, it's an indirect object. */
6962 /* (But it's an indir obj regardless for sort.) */
6963 /* Also, if "_" follows a filetest operator, it's a bareword */
6966 ( !immediate_paren && (PL_last_lop_op == OP_SORT
6968 && (PL_last_lop_op != OP_MAPSTART
6969 && PL_last_lop_op != OP_GREPSTART))))
6970 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6971 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
6975 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6980 PL_expect = XOPERATOR;
6983 /* Is this a word before a => operator? */
6984 if (*s == '=' && s[1] == '>' && !pkgname) {
6987 if (gvp || (lex && !off)) {
6988 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6989 /* This is our own scalar, created a few lines
6990 above, so this is safe. */
6992 sv_setpv(sv, PL_tokenbuf);
6993 if (UTF && !IN_BYTES
6994 && is_utf8_string((U8*)PL_tokenbuf, len))
7001 /* If followed by a paren, it's certainly a subroutine. */
7006 while (SPACE_OR_TAB(*d))
7008 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7013 NEXTVAL_NEXTTOKE.opval =
7014 off ? rv2cv_op : pl_yylval.opval;
7016 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7017 else op_free(rv2cv_op), force_next(WORD);
7022 /* If followed by var or block, call it a method (unless sub) */
7024 if ((*s == '$' || *s == '{') && !cv) {
7026 PL_last_lop = PL_oldbufptr;
7027 PL_last_lop_op = OP_METHOD;
7028 if (!PL_lex_allbrackets
7029 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7031 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7033 PL_expect = XBLOCKTERM;
7035 return REPORT(METHOD);
7038 /* If followed by a bareword, see if it looks like indir obj. */
7040 if (tmp == 1 && !orig_keyword
7041 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7042 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
7045 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7047 sv_setpvn(sv, PL_tokenbuf, len);
7048 if (UTF && !IN_BYTES
7049 && is_utf8_string((U8*)PL_tokenbuf, len))
7051 else SvUTF8_off(sv);
7054 if (tmp == METHOD && !PL_lex_allbrackets
7055 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7057 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7062 /* Not a method, so call it a subroutine (if defined) */
7065 /* Check for a constant sub */
7066 if ((sv = cv_const_sv_or_av(cv))) {
7069 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7070 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7071 if (SvTYPE(sv) == SVt_PVAV)
7072 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7075 pl_yylval.opval->op_private = 0;
7076 pl_yylval.opval->op_folded = 1;
7077 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7082 op_free(pl_yylval.opval);
7084 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7085 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7086 PL_last_lop = PL_oldbufptr;
7087 PL_last_lop_op = OP_ENTERSUB;
7088 /* Is there a prototype? */
7092 STRLEN protolen = CvPROTOLEN(cv);
7093 const char *proto = CvPROTO(cv);
7095 proto = S_strip_spaces(aTHX_ proto, &protolen);
7098 if ((optional = *proto == ';'))
7101 while (*proto == ';');
7105 *proto == '$' || *proto == '_'
7106 || *proto == '*' || *proto == '+'
7111 *proto == '\\' && proto[1] && proto[2] == '\0'
7114 UNIPROTO(UNIOPSUB,optional);
7115 if (*proto == '\\' && proto[1] == '[') {
7116 const char *p = proto + 2;
7117 while(*p && *p != ']')
7119 if(*p == ']' && !p[1])
7120 UNIPROTO(UNIOPSUB,optional);
7122 if (*proto == '&' && *s == '{') {
7124 sv_setpvs(PL_subname, "__ANON__");
7126 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7127 if (!PL_lex_allbrackets
7128 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7130 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7135 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7137 force_next(off ? PRIVATEREF : WORD);
7138 if (!PL_lex_allbrackets
7139 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7141 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7146 /* Call it a bare word */
7148 if (PL_hints & HINT_STRICT_SUBS)
7149 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7152 /* after "print" and similar functions (corresponding to
7153 * "F? L" in opcode.pl), whatever wasn't already parsed as
7154 * a filehandle should be subject to "strict subs".
7155 * Likewise for the optional indirect-object argument to system
7156 * or exec, which can't be a bareword */
7157 if ((PL_last_lop_op == OP_PRINT
7158 || PL_last_lop_op == OP_PRTF
7159 || PL_last_lop_op == OP_SAY
7160 || PL_last_lop_op == OP_SYSTEM
7161 || PL_last_lop_op == OP_EXEC)
7162 && (PL_hints & HINT_STRICT_SUBS))
7163 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7164 if (lastchar != '-') {
7165 if (ckWARN(WARN_RESERVED)) {
7169 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7171 /* PL_warn_reserved is constant */
7172 GCC_DIAG_IGNORE(-Wformat-nonliteral);
7173 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7183 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7184 && saw_infix_sigil) {
7185 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7186 "Operator or semicolon missing before %c%"UTF8f,
7188 UTF8fARG(UTF, strlen(PL_tokenbuf),
7190 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7191 "Ambiguous use of %c resolved as operator %c",
7192 lastchar, lastchar);
7199 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7204 (OP*)newSVOP(OP_CONST, 0,
7205 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7208 case KEY___PACKAGE__:
7210 (OP*)newSVOP(OP_CONST, 0,
7212 ? newSVhek(HvNAME_HEK(PL_curstash))
7219 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7220 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7223 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7225 gv_init(gv,stash,"DATA",4,0);
7228 GvIOp(gv) = newIO();
7229 IoIFP(GvIOp(gv)) = PL_rsfp;
7230 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
7232 const int fd = PerlIO_fileno(PL_rsfp);
7234 fcntl(fd,F_SETFD, FD_CLOEXEC);
7238 /* Mark this internal pseudo-handle as clean */
7239 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7240 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7241 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7243 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7244 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7245 /* if the script was opened in binmode, we need to revert
7246 * it to text mode for compatibility; but only iff it has CRs
7247 * XXX this is a questionable hack at best. */
7248 if (PL_bufend-PL_bufptr > 2
7249 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7252 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7253 loc = PerlIO_tell(PL_rsfp);
7254 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7257 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7259 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7260 #endif /* NETWARE */
7262 PerlIO_seek(PL_rsfp, loc, 0);
7266 #ifdef PERLIO_LAYERS
7269 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7270 else if (IN_ENCODING) {
7276 XPUSHs(_get_encoding());
7278 call_method("name", G_SCALAR);
7282 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7283 Perl_form(aTHX_ ":encoding(%"SVf")",
7296 FUN0OP(CvCLONE(PL_compcv)
7297 ? newOP(OP_RUNCV, 0)
7298 : newPVOP(OP_RUNCV,0,NULL));
7307 if (PL_expect == XSTATE) {
7318 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7319 if ((*s == ':' && s[1] == ':')
7320 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7324 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7328 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7329 UTF8fARG(UTF, len, PL_tokenbuf));
7332 else if (tmp == KEY_require || tmp == KEY_do
7334 /* that's a way to remember we saw "CORE::" */
7346 LOP(OP_ACCEPT,XTERM);
7349 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7354 LOP(OP_ATAN2,XTERM);
7360 LOP(OP_BINMODE,XTERM);
7363 LOP(OP_BLESS,XTERM);
7372 /* We have to disambiguate the two senses of
7373 "continue". If the next token is a '{' then
7374 treat it as the start of a continue block;
7375 otherwise treat it as a control operator.
7385 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7395 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7404 if (!PL_cryptseen) {
7405 PL_cryptseen = TRUE;
7409 LOP(OP_CRYPT,XTERM);
7412 LOP(OP_CHMOD,XTERM);
7415 LOP(OP_CHOWN,XTERM);
7418 LOP(OP_CONNECT,XTERM);
7438 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7440 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7441 && !keyword(PL_tokenbuf + 1, len, 0)) {
7444 force_ident_maybe_lex('&');
7449 if (orig_keyword == KEY_do) {
7458 PL_hints |= HINT_BLOCK_SCOPE;
7468 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7469 STR_WITH_LEN("NDBM_File::"),
7470 STR_WITH_LEN("DB_File::"),
7471 STR_WITH_LEN("GDBM_File::"),
7472 STR_WITH_LEN("SDBM_File::"),
7473 STR_WITH_LEN("ODBM_File::"),
7475 LOP(OP_DBMOPEN,XTERM);
7487 pl_yylval.ival = CopLINE(PL_curcop);
7491 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7503 if (*s == '{') { /* block eval */
7504 PL_expect = XTERMBLOCK;
7505 UNIBRACK(OP_ENTERTRY);
7507 else { /* string eval */
7509 UNIBRACK(OP_ENTEREVAL);
7514 UNIBRACK(-OP_ENTEREVAL);
7528 case KEY_endhostent:
7534 case KEY_endservent:
7537 case KEY_endprotoent:
7548 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7550 pl_yylval.ival = CopLINE(PL_curcop);
7552 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7555 if ((PL_bufend - p) >= 3
7556 && strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7560 else if ((PL_bufend - p) >= 4
7561 && strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7564 /* skip optional package name, as in "for my abc $x (..)" */
7565 if (isIDFIRST_lazy_if(p,UTF)) {
7566 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7570 Perl_croak(aTHX_ "Missing $ on loop variable");
7575 LOP(OP_FORMLINE,XTERM);
7584 LOP(OP_FCNTL,XTERM);
7590 LOP(OP_FLOCK,XTERM);
7593 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7598 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7603 LOP(OP_GREPSTART, XREF);
7620 case KEY_getpriority:
7621 LOP(OP_GETPRIORITY,XTERM);
7623 case KEY_getprotobyname:
7626 case KEY_getprotobynumber:
7627 LOP(OP_GPBYNUMBER,XTERM);
7629 case KEY_getprotoent:
7641 case KEY_getpeername:
7642 UNI(OP_GETPEERNAME);
7644 case KEY_gethostbyname:
7647 case KEY_gethostbyaddr:
7648 LOP(OP_GHBYADDR,XTERM);
7650 case KEY_gethostent:
7653 case KEY_getnetbyname:
7656 case KEY_getnetbyaddr:
7657 LOP(OP_GNBYADDR,XTERM);
7662 case KEY_getservbyname:
7663 LOP(OP_GSBYNAME,XTERM);
7665 case KEY_getservbyport:
7666 LOP(OP_GSBYPORT,XTERM);
7668 case KEY_getservent:
7671 case KEY_getsockname:
7672 UNI(OP_GETSOCKNAME);
7674 case KEY_getsockopt:
7675 LOP(OP_GSOCKOPT,XTERM);
7690 pl_yylval.ival = CopLINE(PL_curcop);
7691 Perl_ck_warner_d(aTHX_
7692 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7693 "given is experimental");
7698 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7706 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7708 pl_yylval.ival = CopLINE(PL_curcop);
7712 LOP(OP_INDEX,XTERM);
7718 LOP(OP_IOCTL,XTERM);
7746 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7751 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7765 LOP(OP_LISTEN,XTERM);
7774 s = scan_pat(s,OP_MATCH);
7775 TERM(sublex_start());
7778 LOP(OP_MAPSTART, XREF);
7781 LOP(OP_MKDIR,XTERM);
7784 LOP(OP_MSGCTL,XTERM);
7787 LOP(OP_MSGGET,XTERM);
7790 LOP(OP_MSGRCV,XTERM);
7793 LOP(OP_MSGSND,XTERM);
7799 yyerror(Perl_form(aTHX_
7800 "Can't redeclare \"%s\" in \"%s\"",
7801 tmp == KEY_my ? "my" :
7802 tmp == KEY_state ? "state" : "our",
7803 PL_in_my == KEY_my ? "my" :
7804 PL_in_my == KEY_state ? "state" : "our"));
7806 PL_in_my = (U16)tmp;
7808 if (isIDFIRST_lazy_if(s,UTF)) {
7809 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7810 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7812 if (!FEATURE_LEXSUBS_IS_ENABLED)
7814 "Experimental \"%s\" subs not enabled",
7815 tmp == KEY_my ? "my" :
7816 tmp == KEY_state ? "state" : "our");
7817 Perl_ck_warner_d(aTHX_
7818 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7819 "The lexical_subs feature is experimental");
7822 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7823 if (!PL_in_my_stash) {
7827 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7828 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7829 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7839 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7844 s = tokenize_use(0, s);
7848 if (*s == '(' || (s = skipspace(s), *s == '('))
7851 if (!PL_lex_allbrackets
7852 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7854 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7861 if (isIDFIRST_lazy_if(s,UTF)) {
7863 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7865 for (t=d; isSPACE(*t);)
7867 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7869 && !(t[0] == '=' && t[1] == '>')
7870 && !(t[0] == ':' && t[1] == ':')
7871 && !keyword(s, d-s, 0)
7873 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7874 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7875 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7881 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7883 pl_yylval.ival = OP_OR;
7893 LOP(OP_OPEN_DIR,XTERM);
7896 checkcomma(s,PL_tokenbuf,"filehandle");
7900 checkcomma(s,PL_tokenbuf,"filehandle");
7919 s = force_word(s,WORD,FALSE,TRUE);
7921 s = force_strict_version(s);
7925 LOP(OP_PIPE_OP,XTERM);
7928 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7931 COPLINE_SET_FROM_MULTI_END;
7932 pl_yylval.ival = OP_CONST;
7933 TERM(sublex_start());
7940 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7943 COPLINE_SET_FROM_MULTI_END;
7944 PL_expect = XOPERATOR;
7945 if (SvCUR(PL_lex_stuff)) {
7946 int warned_comma = !ckWARN(WARN_QW);
7947 int warned_comment = warned_comma;
7948 d = SvPV_force(PL_lex_stuff, len);
7950 for (; isSPACE(*d) && len; --len, ++d)
7955 if (!warned_comma || !warned_comment) {
7956 for (; !isSPACE(*d) && len; --len, ++d) {
7957 if (!warned_comma && *d == ',') {
7958 Perl_warner(aTHX_ packWARN(WARN_QW),
7959 "Possible attempt to separate words with commas");
7962 else if (!warned_comment && *d == '#') {
7963 Perl_warner(aTHX_ packWARN(WARN_QW),
7964 "Possible attempt to put comments in qw() list");
7970 for (; !isSPACE(*d) && len; --len, ++d)
7973 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7974 words = op_append_elem(OP_LIST, words,
7975 newSVOP(OP_CONST, 0, tokeq(sv)));
7980 words = newNULLLIST();
7981 SvREFCNT_dec_NN(PL_lex_stuff);
7982 PL_lex_stuff = NULL;
7983 PL_expect = XOPERATOR;
7984 pl_yylval.opval = sawparens(words);
7989 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7992 pl_yylval.ival = OP_STRINGIFY;
7993 if (SvIVX(PL_lex_stuff) == '\'')
7994 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7995 TERM(sublex_start());
7998 s = scan_pat(s,OP_QR);
7999 TERM(sublex_start());
8002 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8005 pl_yylval.ival = OP_BACKTICK;
8006 TERM(sublex_start());
8014 s = force_version(s, FALSE);
8016 else if (*s != 'v' || !isDIGIT(s[1])
8017 || (s = force_version(s, TRUE), *s == 'v'))
8019 *PL_tokenbuf = '\0';
8020 s = force_word(s,WORD,TRUE,TRUE);
8021 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8022 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8023 GV_ADD | (UTF ? SVf_UTF8 : 0));
8025 yyerror("<> at require-statement should be quotes");
8027 if (orig_keyword == KEY_require) {
8033 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8035 PL_last_uni = PL_oldbufptr;
8036 PL_last_lop_op = OP_REQUIRE;
8038 return REPORT( (int)REQUIRE );
8047 LOP(OP_RENAME,XTERM);
8056 LOP(OP_RINDEX,XTERM);
8065 UNIDOR(OP_READLINE);
8068 UNIDOR(OP_BACKTICK);
8077 LOP(OP_REVERSE,XTERM);
8080 UNIDOR(OP_READLINK);
8087 if (pl_yylval.opval)
8088 TERM(sublex_start());
8090 TOKEN(1); /* force error */
8093 checkcomma(s,PL_tokenbuf,"filehandle");
8103 LOP(OP_SELECT,XTERM);
8109 LOP(OP_SEMCTL,XTERM);
8112 LOP(OP_SEMGET,XTERM);
8115 LOP(OP_SEMOP,XTERM);
8121 LOP(OP_SETPGRP,XTERM);
8123 case KEY_setpriority:
8124 LOP(OP_SETPRIORITY,XTERM);
8126 case KEY_sethostent:
8132 case KEY_setservent:
8135 case KEY_setprotoent:
8145 LOP(OP_SEEKDIR,XTERM);
8147 case KEY_setsockopt:
8148 LOP(OP_SSOCKOPT,XTERM);
8154 LOP(OP_SHMCTL,XTERM);
8157 LOP(OP_SHMGET,XTERM);
8160 LOP(OP_SHMREAD,XTERM);
8163 LOP(OP_SHMWRITE,XTERM);
8166 LOP(OP_SHUTDOWN,XTERM);
8175 LOP(OP_SOCKET,XTERM);
8177 case KEY_socketpair:
8178 LOP(OP_SOCKPAIR,XTERM);
8181 checkcomma(s,PL_tokenbuf,"subroutine name");
8184 s = force_word(s,WORD,TRUE,TRUE);
8188 LOP(OP_SPLIT,XTERM);
8191 LOP(OP_SPRINTF,XTERM);
8194 LOP(OP_SPLICE,XTERM);
8209 LOP(OP_SUBSTR,XTERM);
8215 char * const tmpbuf = PL_tokenbuf + 1;
8216 expectation attrful;
8217 bool have_name, have_proto;
8218 const int key = tmp;
8219 SV *format_name = NULL;
8224 if (isIDFIRST_lazy_if(s,UTF)
8226 || (*s == ':' && s[1] == ':'))
8230 attrful = XATTRBLOCK;
8231 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8233 if (key == KEY_format)
8234 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8236 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8238 PL_tokenbuf, len + 1, 0
8240 sv_setpvn(PL_subname, tmpbuf, len);
8242 sv_setsv(PL_subname,PL_curstname);
8243 sv_catpvs(PL_subname,"::");
8244 sv_catpvn(PL_subname,tmpbuf,len);
8246 if (SvUTF8(PL_linestr))
8247 SvUTF8_on(PL_subname);
8254 if (key == KEY_my || key == KEY_our || key==KEY_state)
8257 /* diag_listed_as: Missing name in "%s sub" */
8259 "Missing name in \"%s\"", PL_bufptr);
8261 PL_expect = XTERMBLOCK;
8262 attrful = XATTRTERM;
8263 sv_setpvs(PL_subname,"?");
8267 if (key == KEY_format) {
8269 NEXTVAL_NEXTTOKE.opval
8270 = (OP*)newSVOP(OP_CONST,0, format_name);
8271 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8277 /* Look for a prototype */
8278 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8279 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8280 COPLINE_SET_FROM_MULTI_END;
8282 Perl_croak(aTHX_ "Prototype not terminated");
8283 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8291 if (*s == ':' && s[1] != ':')
8292 PL_expect = attrful;
8293 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8294 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8295 key == KEY_DESTROY || key == KEY_BEGIN ||
8296 key == KEY_UNITCHECK || key == KEY_CHECK ||
8297 key == KEY_INIT || key == KEY_END ||
8298 key == KEY_my || key == KEY_state ||
8301 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8302 else if (*s != ';' && *s != '}')
8303 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8307 NEXTVAL_NEXTTOKE.opval =
8308 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8309 PL_lex_stuff = NULL;
8314 sv_setpvs(PL_subname, "__ANON__");
8316 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8319 force_ident_maybe_lex('&');
8324 LOP(OP_SYSTEM,XREF);
8327 LOP(OP_SYMLINK,XTERM);
8330 LOP(OP_SYSCALL,XTERM);
8333 LOP(OP_SYSOPEN,XTERM);
8336 LOP(OP_SYSSEEK,XTERM);
8339 LOP(OP_SYSREAD,XTERM);
8342 LOP(OP_SYSWRITE,XTERM);
8347 TERM(sublex_start());
8368 LOP(OP_TRUNCATE,XTERM);
8380 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8382 pl_yylval.ival = CopLINE(PL_curcop);
8386 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8388 pl_yylval.ival = CopLINE(PL_curcop);
8392 LOP(OP_UNLINK,XTERM);
8398 LOP(OP_UNPACK,XTERM);
8401 LOP(OP_UTIME,XTERM);
8407 LOP(OP_UNSHIFT,XTERM);
8410 s = tokenize_use(1, s);
8420 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8422 pl_yylval.ival = CopLINE(PL_curcop);
8423 Perl_ck_warner_d(aTHX_
8424 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8425 "when is experimental");
8429 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8431 pl_yylval.ival = CopLINE(PL_curcop);
8435 PL_hints |= HINT_BLOCK_SCOPE;
8442 LOP(OP_WAITPID,XTERM);
8448 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8449 * we use the same number on EBCDIC */
8450 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8454 if (PL_expect == XOPERATOR) {
8455 if (*s == '=' && !PL_lex_allbrackets
8456 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8466 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8468 pl_yylval.ival = OP_XOR;
8477 Looks up an identifier in the pad or in a package
8480 PRIVATEREF if this is a lexical name.
8481 WORD if this belongs to a package.
8484 if we're in a my declaration
8485 croak if they tried to say my($foo::bar)
8486 build the ops for a my() declaration
8487 if it's an access to a my() variable
8488 build ops for access to a my() variable
8489 if in a dq string, and they've said @foo and we can't find @foo
8491 build ops for a bareword
8495 S_pending_ident(pTHX)
8498 const char pit = (char)pl_yylval.ival;
8499 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8500 /* All routes through this function want to know if there is a colon. */
8501 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8503 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8504 "### Pending identifier '%s'\n", PL_tokenbuf); });
8506 /* if we're in a my(), we can't allow dynamics here.
8507 $foo'bar has already been turned into $foo::bar, so
8508 just check for colons.
8510 if it's a legal name, the OP is a PADANY.
8513 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8515 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8516 "variable %s in \"our\"",
8517 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8518 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8522 /* "my" variable %s can't be in a package */
8523 /* PL_no_myglob is constant */
8524 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8525 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8526 PL_in_my == KEY_my ? "my" : "state",
8527 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8529 UTF ? SVf_UTF8 : 0);
8533 pl_yylval.opval = newOP(OP_PADANY, 0);
8534 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8535 UTF ? SVf_UTF8 : 0);
8541 build the ops for accesses to a my() variable.
8546 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8548 if (tmp != NOT_IN_PAD) {
8549 /* might be an "our" variable" */
8550 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8551 /* build ops for a bareword */
8552 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8553 HEK * const stashname = HvNAME_HEK(stash);
8554 SV * const sym = newSVhek(stashname);
8555 sv_catpvs(sym, "::");
8556 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8557 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8558 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8562 ((PL_tokenbuf[0] == '$') ? SVt_PV
8563 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8568 pl_yylval.opval = newOP(OP_PADANY, 0);
8569 pl_yylval.opval->op_targ = tmp;
8575 Whine if they've said @foo in a doublequoted string,
8576 and @foo isn't a variable we can find in the symbol
8579 if (ckWARN(WARN_AMBIGUOUS)
8581 && PL_lex_state != LEX_NORMAL
8582 && !PL_lex_brackets)
8584 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8585 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8586 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8587 /* DO NOT warn for @- and @+ */
8588 && !( PL_tokenbuf[2] == '\0'
8589 && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8592 /* Downgraded from fatal to warning 20000522 mjd */
8593 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8594 "Possible unintended interpolation of %"UTF8f
8596 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8600 /* build ops for a bareword */
8601 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8602 newSVpvn_flags(PL_tokenbuf + 1,
8604 UTF ? SVf_UTF8 : 0 ));
8605 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8607 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8608 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8609 | ( UTF ? SVf_UTF8 : 0 ),
8610 ((PL_tokenbuf[0] == '$') ? SVt_PV
8611 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8617 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8619 PERL_ARGS_ASSERT_CHECKCOMMA;
8621 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8622 if (ckWARN(WARN_SYNTAX)) {
8625 for (w = s+2; *w && level; w++) {
8633 /* the list of chars below is for end of statements or
8634 * block / parens, boolean operators (&&, ||, //) and branch
8635 * constructs (or, and, if, until, unless, while, err, for).
8636 * Not a very solid hack... */
8637 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8638 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8639 "%s (...) interpreted as function",name);
8642 while (s < PL_bufend && isSPACE(*s))
8646 while (s < PL_bufend && isSPACE(*s))
8648 if (isIDFIRST_lazy_if(s,UTF)) {
8649 const char * const w = s;
8650 s += UTF ? UTF8SKIP(s) : 1;
8651 while (isWORDCHAR_lazy_if(s,UTF))
8652 s += UTF ? UTF8SKIP(s) : 1;
8653 while (s < PL_bufend && isSPACE(*s))
8658 if (keyword(w, s - w, 0))
8661 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8662 if (gv && GvCVu(gv))
8666 Copy(w, tmpbuf+1, s - w, char);
8668 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8669 if (off != NOT_IN_PAD) return;
8671 Perl_croak(aTHX_ "No comma allowed after %s", what);
8676 /* S_new_constant(): do any overload::constant lookup.
8678 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8679 Best used as sv=new_constant(..., sv, ...).
8680 If s, pv are NULL, calls subroutine with one argument,
8681 and <type> is used with error messages only.
8682 <type> is assumed to be well formed UTF-8 */
8685 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8686 SV *sv, SV *pv, const char *type, STRLEN typelen)
8689 HV * table = GvHV(PL_hintgv); /* ^H */
8694 const char *why1 = "", *why2 = "", *why3 = "";
8696 PERL_ARGS_ASSERT_NEW_CONSTANT;
8697 /* We assume that this is true: */
8698 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8701 /* charnames doesn't work well if there have been errors found */
8702 if (PL_error_count > 0 && *key == 'c')
8704 SvREFCNT_dec_NN(sv);
8705 return &PL_sv_undef;
8708 sv_2mortal(sv); /* Parent created it permanently */
8710 || ! (PL_hints & HINT_LOCALIZE_HH)
8711 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8716 /* Here haven't found what we're looking for. If it is charnames,
8717 * perhaps it needs to be loaded. Try doing that before giving up */
8719 Perl_load_module(aTHX_
8721 newSVpvs("_charnames"),
8722 /* version parameter; no need to specify it, as if
8723 * we get too early a version, will fail anyway,
8724 * not being able to find '_charnames' */
8729 assert(sp == PL_stack_sp);
8730 table = GvHV(PL_hintgv);
8732 && (PL_hints & HINT_LOCALIZE_HH)
8733 && (cvp = hv_fetch(table, key, keylen, FALSE))
8739 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8740 msg = Perl_form(aTHX_
8741 "Constant(%.*s) unknown",
8742 (int)(type ? typelen : len),
8748 why3 = "} is not defined";
8751 msg = Perl_form(aTHX_
8752 /* The +3 is for '\N{'; -4 for that, plus '}' */
8753 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8757 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8758 (int)(type ? typelen : len),
8759 (type ? type: s), why1, why2, why3);
8762 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8763 return SvREFCNT_inc_simple_NN(sv);
8768 pv = newSVpvn_flags(s, len, SVs_TEMP);
8770 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8772 typesv = &PL_sv_undef;
8774 PUSHSTACKi(PERLSI_OVERLOAD);
8786 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8790 /* Check the eval first */
8791 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8793 const char * errstr;
8794 sv_catpvs(errsv, "Propagated");
8795 errstr = SvPV_const(errsv, errlen);
8796 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8798 res = SvREFCNT_inc_simple_NN(sv);
8802 SvREFCNT_inc_simple_void_NN(res);
8811 why1 = "Call to &{$^H{";
8813 why3 = "}} did not return a defined value";
8815 (void)sv_2mortal(sv);
8822 PERL_STATIC_INLINE void
8823 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8824 PERL_ARGS_ASSERT_PARSE_IDENT;
8828 Perl_croak(aTHX_ "%s", ident_too_long);
8829 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8830 /* The UTF-8 case must come first, otherwise things
8831 * like c\N{COMBINING TILDE} would start failing, as the
8832 * isWORDCHAR_A case below would gobble the 'c' up.
8835 char *t = *s + UTF8SKIP(*s);
8836 while (isIDCONT_utf8((U8*)t))
8838 if (*d + (t - *s) > e)
8839 Perl_croak(aTHX_ "%s", ident_too_long);
8840 Copy(*s, *d, t - *s, char);
8844 else if ( isWORDCHAR_A(**s) ) {
8847 } while (isWORDCHAR_A(**s) && *d < e);
8849 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8854 else if (allow_package && **s == ':' && (*s)[1] == ':'
8855 /* Disallow things like Foo::$bar. For the curious, this is
8856 * the code path that triggers the "Bad name after" warning
8857 * when looking for barewords.
8859 && (*s)[2] != '$') {
8869 /* Returns a NUL terminated string, with the length of the string written to
8873 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8876 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8877 bool is_utf8 = cBOOL(UTF);
8879 PERL_ARGS_ASSERT_SCAN_WORD;
8881 parse_ident(&s, &d, e, allow_package, is_utf8);
8887 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8888 * iff Unicode semantics are to be used. The legal ones are any of:
8889 * a) all ASCII characters except:
8890 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
8892 * The final case currently doesn't get this far in the program, so we
8893 * don't test for it. If that were to change, it would be ok to allow it.
8894 * b) When not under Unicode rules, any upper Latin1 character
8895 * c) Otherwise, when unicode rules are used, all XIDS characters.
8897 * Because all ASCII characters have the same representation whether
8898 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8899 * '{' without knowing if is UTF-8 or not. */
8900 #define VALID_LEN_ONE_IDENT(s, is_utf8) \
8901 (isGRAPH_A(*(s)) || ((is_utf8) \
8902 ? isIDFIRST_utf8((U8*) (s)) \
8904 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8907 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8909 I32 herelines = PL_parser->herelines;
8910 SSize_t bracket = -1;
8913 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8914 bool is_utf8 = cBOOL(UTF);
8915 I32 orig_copline = 0, tmp_copline = 0;
8917 PERL_ARGS_ASSERT_SCAN_IDENT;
8919 if (isSPACE(*s) || !*s)
8922 while (isDIGIT(*s)) {
8924 Perl_croak(aTHX_ "%s", ident_too_long);
8928 else { /* See if it is a "normal" identifier */
8929 parse_ident(&s, &d, e, 1, is_utf8);
8934 /* Either a digit variable, or parse_ident() found an identifier
8935 (anything valid as a bareword), so job done and return. */
8936 if (PL_lex_state != LEX_NORMAL)
8937 PL_lex_state = LEX_INTERPENDMAYBE;
8941 /* Here, it is not a run-of-the-mill identifier name */
8943 if (*s == '$' && s[1]
8944 && (isIDFIRST_lazy_if(s+1,is_utf8)
8945 || isDIGIT_A((U8)s[1])
8948 || strnEQ(s+1,"::",2)) )
8950 /* Dereferencing a value in a scalar variable.
8951 The alternatives are different syntaxes for a scalar variable.
8952 Using ' as a leading package separator isn't allowed. :: is. */
8955 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8957 bracket = s - SvPVX(PL_linestr);
8959 orig_copline = CopLINE(PL_curcop);
8960 if (s < PL_bufend && isSPACE(*s)) {
8964 if ((s <= PL_bufend - (is_utf8)
8967 && VALID_LEN_ONE_IDENT(s, is_utf8))
8970 const STRLEN skip = UTF8SKIP(s);
8973 for ( i = 0; i < skip; i++ )
8981 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8982 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8986 /* Warn about ambiguous code after unary operators if {...} notation isn't
8987 used. There's no difference in ambiguity; it's merely a heuristic
8988 about when not to warn. */
8989 else if (ck_uni && bracket == -1)
8991 if (bracket != -1) {
8992 /* If we were processing {...} notation then... */
8993 if (isIDFIRST_lazy_if(d,is_utf8)) {
8994 /* if it starts as a valid identifier, assume that it is one.
8995 (the later check for } being at the expected point will trap
8996 cases where this doesn't pan out.) */
8997 d += is_utf8 ? UTF8SKIP(d) : 1;
8998 parse_ident(&s, &d, e, 1, is_utf8);
9000 tmp_copline = CopLINE(PL_curcop);
9001 if (s < PL_bufend && isSPACE(*s)) {
9004 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9005 /* ${foo[0]} and ${foo{bar}} notation. */
9006 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9007 const char * const brack =
9009 ((*s == '[') ? "[...]" : "{...}");
9010 orig_copline = CopLINE(PL_curcop);
9011 CopLINE_set(PL_curcop, tmp_copline);
9012 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9013 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9014 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9015 funny, dest, brack, funny, dest, brack);
9016 CopLINE_set(PL_curcop, orig_copline);
9019 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9020 PL_lex_allbrackets++;
9024 /* Handle extended ${^Foo} variables
9025 * 1999-02-27 mjd-perl-patch@plover.com */
9026 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9030 while (isWORDCHAR(*s) && d < e) {
9034 Perl_croak(aTHX_ "%s", ident_too_long);
9039 tmp_copline = CopLINE(PL_curcop);
9040 if (s < PL_bufend && isSPACE(*s)) {
9044 /* Expect to find a closing } after consuming any trailing whitespace.
9048 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9049 PL_lex_state = LEX_INTERPEND;
9052 if (PL_lex_state == LEX_NORMAL) {
9053 if (ckWARN(WARN_AMBIGUOUS)
9054 && (keyword(dest, d - dest, 0)
9055 || get_cvn_flags(dest, d - dest, is_utf8
9059 SV *tmp = newSVpvn_flags( dest, d - dest,
9060 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9063 orig_copline = CopLINE(PL_curcop);
9064 CopLINE_set(PL_curcop, tmp_copline);
9065 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9066 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9067 funny, SVfARG(tmp), funny, SVfARG(tmp));
9068 CopLINE_set(PL_curcop, orig_copline);
9073 /* Didn't find the closing } at the point we expected, so restore
9074 state such that the next thing to process is the opening { and */
9075 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9076 CopLINE_set(PL_curcop, orig_copline);
9077 PL_parser->herelines = herelines;
9081 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9082 PL_lex_state = LEX_INTERPEND;
9087 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9089 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9090 * found in the parse starting at 's', based on the subset that are valid
9091 * in this context input to this routine in 'valid_flags'. Advances s.
9092 * Returns TRUE if the input should be treated as a valid flag, so the next
9093 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9094 * upon first call on the current regex. This routine will set it to any
9095 * charset modifier found. The caller shouldn't change it. This way,
9096 * another charset modifier encountered in the parse can be detected as an
9097 * error, as we have decided to allow only one */
9100 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9102 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9103 if (isWORDCHAR_lazy_if(*s, UTF)) {
9104 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9105 UTF ? SVf_UTF8 : 0);
9107 /* Pretend that it worked, so will continue processing before
9116 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9117 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9118 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9119 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9120 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9121 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9122 case LOCALE_PAT_MOD:
9124 goto multiple_charsets;
9126 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9129 case UNICODE_PAT_MOD:
9131 goto multiple_charsets;
9133 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9136 case ASCII_RESTRICT_PAT_MOD:
9138 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9142 /* Error if previous modifier wasn't an 'a', but if it was, see
9143 * if, and accept, a second occurrence (only) */
9145 || get_regex_charset(*pmfl)
9146 != REGEX_ASCII_RESTRICTED_CHARSET)
9148 goto multiple_charsets;
9150 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9154 case DEPENDS_PAT_MOD:
9156 goto multiple_charsets;
9158 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9167 if (*charset != c) {
9168 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9170 else if (c == 'a') {
9171 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9172 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9175 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9178 /* Pretend that it worked, so will continue processing before dieing */
9184 S_scan_pat(pTHX_ char *start, I32 type)
9188 const char * const valid_flags =
9189 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9190 char charset = '\0'; /* character set modifier */
9191 unsigned int x_mod_count = 0;
9193 PERL_ARGS_ASSERT_SCAN_PAT;
9195 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9197 Perl_croak(aTHX_ "Search pattern not terminated");
9199 pm = (PMOP*)newPMOP(type, 0);
9200 if (PL_multi_open == '?') {
9201 /* This is the only point in the code that sets PMf_ONCE: */
9202 pm->op_pmflags |= PMf_ONCE;
9204 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9205 allows us to restrict the list needed by reset to just the ??
9207 assert(type != OP_TRANS);
9209 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9212 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9215 elements = mg->mg_len / sizeof(PMOP**);
9216 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9217 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9218 mg->mg_len = elements * sizeof(PMOP**);
9219 PmopSTASH_set(pm,PL_curstash);
9223 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9224 * anon CV. False positives like qr/[(?{]/ are harmless */
9226 if (type == OP_QR) {
9228 char *e, *p = SvPV(PL_lex_stuff, len);
9230 for (; p < e; p++) {
9231 if (p[0] == '(' && p[1] == '?'
9232 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9234 pm->op_pmflags |= PMf_HAS_CV;
9238 pm->op_pmflags |= PMf_IS_QR;
9241 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9242 &s, &charset, &x_mod_count))
9244 /* issue a warning if /c is specified,but /g is not */
9245 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9247 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9248 "Use of /c modifier is meaningless without /g" );
9251 if (UNLIKELY((x_mod_count) > 1)) {
9252 yyerror("Only one /x regex modifier is allowed");
9255 PL_lex_op = (OP*)pm;
9256 pl_yylval.ival = OP_MATCH;
9261 S_scan_subst(pTHX_ char *start)
9268 char charset = '\0'; /* character set modifier */
9269 unsigned int x_mod_count = 0;
9272 PERL_ARGS_ASSERT_SCAN_SUBST;
9274 pl_yylval.ival = OP_NULL;
9276 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9279 Perl_croak(aTHX_ "Substitution pattern not terminated");
9283 first_start = PL_multi_start;
9284 first_line = CopLINE(PL_curcop);
9285 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9287 SvREFCNT_dec_NN(PL_lex_stuff);
9288 PL_lex_stuff = NULL;
9289 Perl_croak(aTHX_ "Substitution replacement not terminated");
9291 PL_multi_start = first_start; /* so whole substitution is taken together */
9293 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9297 if (*s == EXEC_PAT_MOD) {
9301 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9302 &s, &charset, &x_mod_count))
9308 if (UNLIKELY((x_mod_count) > 1)) {
9309 yyerror("Only one /x regex modifier is allowed");
9312 if ((pm->op_pmflags & PMf_CONTINUE)) {
9313 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9317 SV * const repl = newSVpvs("");
9320 pm->op_pmflags |= PMf_EVAL;
9323 sv_catpvs(repl, "eval ");
9325 sv_catpvs(repl, "do ");
9327 sv_catpvs(repl, "{");
9328 sv_catsv(repl, PL_sublex_info.repl);
9329 sv_catpvs(repl, "}");
9331 SvREFCNT_dec(PL_sublex_info.repl);
9332 PL_sublex_info.repl = repl;
9334 if (CopLINE(PL_curcop) != first_line) {
9335 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9336 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9337 CopLINE(PL_curcop) - first_line;
9338 CopLINE_set(PL_curcop, first_line);
9341 PL_lex_op = (OP*)pm;
9342 pl_yylval.ival = OP_SUBST;
9347 S_scan_trans(pTHX_ char *start)
9354 bool nondestruct = 0;
9357 PERL_ARGS_ASSERT_SCAN_TRANS;
9359 pl_yylval.ival = OP_NULL;
9361 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9363 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9367 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9369 SvREFCNT_dec_NN(PL_lex_stuff);
9370 PL_lex_stuff = NULL;
9371 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9374 complement = del = squash = 0;
9378 complement = OPpTRANS_COMPLEMENT;
9381 del = OPpTRANS_DELETE;
9384 squash = OPpTRANS_SQUASH;
9396 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9397 o->op_private &= ~OPpTRANS_ALL;
9398 o->op_private |= del|squash|complement|
9399 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9400 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9403 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9410 Takes a pointer to the first < in <<FOO.
9411 Returns a pointer to the byte following <<FOO.
9413 This function scans a heredoc, which involves different methods
9414 depending on whether we are in a string eval, quoted construct, etc.
9415 This is because PL_linestr could containing a single line of input, or
9416 a whole string being evalled, or the contents of the current quote-
9419 The two basic methods are:
9420 - Steal lines from the input stream
9421 - Scan the heredoc in PL_linestr and remove it therefrom
9423 In a file scope or filtered eval, the first method is used; in a
9424 string eval, the second.
9426 In a quote-like operator, we have to choose between the two,
9427 depending on where we can find a newline. We peek into outer lex-
9428 ing scopes until we find one with a newline in it. If we reach the
9429 outermost lexing scope and it is a file, we use the stream method.
9430 Otherwise it is treated as an eval.
9434 S_scan_heredoc(pTHX_ char *s)
9436 I32 op_type = OP_SCALAR;
9443 const bool infile = PL_rsfp || PL_parser->filtered;
9444 const line_t origline = CopLINE(PL_curcop);
9445 LEXSHARED *shared = PL_parser->lex_shared;
9447 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9450 d = PL_tokenbuf + 1;
9451 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9452 *PL_tokenbuf = '\n';
9454 while (SPACE_OR_TAB(*peek))
9456 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9459 s = delimcpy(d, e, s, PL_bufend, term, &len);
9461 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9467 /* <<\FOO is equivalent to <<'FOO' */
9471 if (!isWORDCHAR_lazy_if(s,UTF))
9472 deprecate("bare << to mean <<\"\"");
9474 while (isWORDCHAR_lazy_if(peek,UTF)) {
9475 peek += UTF ? UTF8SKIP(peek) : 1;
9477 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9478 Copy(s, d, len, char);
9482 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9483 Perl_croak(aTHX_ "Delimiter for here document is too long");
9486 len = d - PL_tokenbuf;
9488 #ifndef PERL_STRICT_CR
9489 d = strchr(s, '\r');
9491 char * const olds = s;
9493 while (s < PL_bufend) {
9499 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9508 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9513 tmpstr = newSV_type(SVt_PVIV);
9517 SvIV_set(tmpstr, -1);
9519 else if (term == '`') {
9520 op_type = OP_BACKTICK;
9521 SvIV_set(tmpstr, '\\');
9524 PL_multi_start = origline + 1 + PL_parser->herelines;
9525 PL_multi_open = PL_multi_close = '<';
9526 /* inside a string eval or quote-like operator */
9527 if (!infile || PL_lex_inwhat) {
9530 char * const olds = s;
9531 PERL_CONTEXT * const cx = CX_CUR();
9532 /* These two fields are not set until an inner lexing scope is
9533 entered. But we need them set here. */
9534 shared->ls_bufptr = s;
9535 shared->ls_linestr = PL_linestr;
9537 /* Look for a newline. If the current buffer does not have one,
9538 peek into the line buffer of the parent lexing scope, going
9539 up as many levels as necessary to find one with a newline
9542 while (!(s = (char *)memchr(
9543 (void *)shared->ls_bufptr, '\n',
9544 SvEND(shared->ls_linestr)-shared->ls_bufptr
9546 shared = shared->ls_prev;
9547 /* shared is only null if we have gone beyond the outermost
9548 lexing scope. In a file, we will have broken out of the
9549 loop in the previous iteration. In an eval, the string buf-
9550 fer ends with "\n;", so the while condition above will have
9551 evaluated to false. So shared can never be null. Or so you
9552 might think. Odd syntax errors like s;@{<<; can gobble up
9553 the implicit semicolon at the end of a flie, causing the
9554 file handle to be closed even when we are not in a string
9555 eval. So shared may be null in that case. */
9556 if (UNLIKELY(!shared))
9558 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9559 most lexing scope. In a file, shared->ls_linestr at that
9560 level is just one line, so there is no body to steal. */
9561 if (infile && !shared->ls_prev) {
9566 else { /* eval or we've already hit EOF */
9567 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9571 linestr = shared->ls_linestr;
9572 bufend = SvEND(linestr);
9574 while (s < bufend - len + 1
9575 && memNE(s,PL_tokenbuf,len) )
9578 ++PL_parser->herelines;
9580 if (s >= bufend - len + 1) {
9583 sv_setpvn(tmpstr,d+1,s-d);
9585 /* the preceding stmt passes a newline */
9586 PL_parser->herelines++;
9588 /* s now points to the newline after the heredoc terminator.
9589 d points to the newline before the body of the heredoc.
9592 /* We are going to modify linestr in place here, so set
9593 aside copies of the string if necessary for re-evals or
9595 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9596 check shared->re_eval_str. */
9597 if (shared->re_eval_start || shared->re_eval_str) {
9598 /* Set aside the rest of the regexp */
9599 if (!shared->re_eval_str)
9600 shared->re_eval_str =
9601 newSVpvn(shared->re_eval_start,
9602 bufend - shared->re_eval_start);
9603 shared->re_eval_start -= s-d;
9606 && CxTYPE(cx) == CXt_EVAL
9607 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
9608 && cx->blk_eval.cur_text == linestr)
9610 cx->blk_eval.cur_text = newSVsv(linestr);
9611 SvSCREAM_on(cx->blk_eval.cur_text);
9613 /* Copy everything from s onwards back to d. */
9614 Move(s,d,bufend-s + 1,char);
9615 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9616 /* Setting PL_bufend only applies when we have not dug deeper
9617 into other scopes, because sublex_done sets PL_bufend to
9618 SvEND(PL_linestr). */
9619 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9625 char *oldbufptr_save;
9627 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9628 term = PL_tokenbuf[1];
9630 linestr_save = PL_linestr; /* must restore this afterwards */
9631 d = s; /* and this */
9632 oldbufptr_save = PL_oldbufptr;
9633 PL_linestr = newSVpvs("");
9634 PL_bufend = SvPVX(PL_linestr);
9636 PL_bufptr = PL_bufend;
9637 CopLINE_set(PL_curcop,
9638 origline + 1 + PL_parser->herelines);
9639 if (!lex_next_chunk(LEX_NO_TERM)
9640 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9641 /* Simply freeing linestr_save might seem simpler here, as it
9642 does not matter what PL_linestr points to, since we are
9643 about to croak; but in a quote-like op, linestr_save
9644 will have been prospectively freed already, via
9645 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9646 restore PL_linestr. */
9647 SvREFCNT_dec_NN(PL_linestr);
9648 PL_linestr = linestr_save;
9649 PL_oldbufptr = oldbufptr_save;
9652 CopLINE_set(PL_curcop, origline);
9653 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9654 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9655 /* ^That should be enough to avoid this needing to grow: */
9656 sv_catpvs(PL_linestr, "\n\0");
9657 assert(s == SvPVX(PL_linestr));
9658 PL_bufend = SvEND(PL_linestr);
9661 PL_parser->herelines++;
9662 PL_last_lop = PL_last_uni = NULL;
9663 #ifndef PERL_STRICT_CR
9664 if (PL_bufend - PL_linestart >= 2) {
9665 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
9666 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9668 PL_bufend[-2] = '\n';
9670 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9672 else if (PL_bufend[-1] == '\r')
9673 PL_bufend[-1] = '\n';
9675 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9676 PL_bufend[-1] = '\n';
9678 if (*s == term && PL_bufend-s >= len
9679 && memEQ(s,PL_tokenbuf + 1,len)) {
9680 SvREFCNT_dec(PL_linestr);
9681 PL_linestr = linestr_save;
9682 PL_linestart = SvPVX(linestr_save);
9683 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9684 PL_oldbufptr = oldbufptr_save;
9689 sv_catsv(tmpstr,PL_linestr);
9693 PL_multi_end = origline + PL_parser->herelines;
9694 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9695 SvPV_shrink_to_cur(tmpstr);
9698 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9700 else if (IN_ENCODING)
9701 sv_recode_to_utf8(tmpstr, _get_encoding());
9703 PL_lex_stuff = tmpstr;
9704 pl_yylval.ival = op_type;
9708 SvREFCNT_dec(tmpstr);
9709 CopLINE_set(PL_curcop, origline);
9710 missingterm(PL_tokenbuf + 1);
9714 takes: current position in input buffer
9715 returns: new position in input buffer
9716 side-effects: pl_yylval and lex_op are set.
9721 <<>> read from ARGV without magic open
9722 <FH> read from filehandle
9723 <pkg::FH> read from package qualified filehandle
9724 <pkg'FH> read from package qualified filehandle
9725 <$fh> read from filehandle in $fh
9731 S_scan_inputsymbol(pTHX_ char *start)
9733 char *s = start; /* current position in buffer */
9736 bool nomagicopen = FALSE;
9737 char *d = PL_tokenbuf; /* start of temp holding space */
9738 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9740 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9742 end = strchr(s, '\n');
9745 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9752 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9754 /* die if we didn't have space for the contents of the <>,
9755 or if it didn't end, or if we see a newline
9758 if (len >= (I32)sizeof PL_tokenbuf)
9759 Perl_croak(aTHX_ "Excessively long <> operator");
9761 Perl_croak(aTHX_ "Unterminated <> operator");
9766 Remember, only scalar variables are interpreted as filehandles by
9767 this code. Anything more complex (e.g., <$fh{$num}>) will be
9768 treated as a glob() call.
9769 This code makes use of the fact that except for the $ at the front,
9770 a scalar variable and a filehandle look the same.
9772 if (*d == '$' && d[1]) d++;
9774 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9775 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9776 d += UTF ? UTF8SKIP(d) : 1;
9778 /* If we've tried to read what we allow filehandles to look like, and
9779 there's still text left, then it must be a glob() and not a getline.
9780 Use scan_str to pull out the stuff between the <> and treat it
9781 as nothing more than a string.
9784 if (d - PL_tokenbuf != len) {
9785 pl_yylval.ival = OP_GLOB;
9786 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9788 Perl_croak(aTHX_ "Glob not terminated");
9792 bool readline_overriden = FALSE;
9794 /* we're in a filehandle read situation */
9797 /* turn <> into <ARGV> */
9799 Copy("ARGV",d,5,char);
9801 /* Check whether readline() is overriden */
9802 if ((gv_readline = gv_override("readline",8)))
9803 readline_overriden = TRUE;
9805 /* if <$fh>, create the ops to turn the variable into a
9809 /* try to find it in the pad for this block, otherwise find
9810 add symbol table ops
9812 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9813 if (tmp != NOT_IN_PAD) {
9814 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9815 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9816 HEK * const stashname = HvNAME_HEK(stash);
9817 SV * const sym = sv_2mortal(newSVhek(stashname));
9818 sv_catpvs(sym, "::");
9824 OP * const o = newOP(OP_PADSV, 0);
9826 PL_lex_op = readline_overriden
9827 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9828 op_append_elem(OP_LIST, o,
9829 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9830 : (OP*)newUNOP(OP_READLINE, 0, o);
9838 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9840 PL_lex_op = readline_overriden
9841 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9842 op_append_elem(OP_LIST,
9843 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9844 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9845 : (OP*)newUNOP(OP_READLINE, 0,
9846 newUNOP(OP_RV2SV, 0,
9847 newGVOP(OP_GV, 0, gv)));
9849 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9850 pl_yylval.ival = OP_NULL;
9853 /* If it's none of the above, it must be a literal filehandle
9854 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9856 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9857 PL_lex_op = readline_overriden
9858 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9859 op_append_elem(OP_LIST,
9860 newGVOP(OP_GV, 0, gv),
9861 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9862 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9863 pl_yylval.ival = OP_NULL;
9873 start position in buffer
9874 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9875 only if they are of the open/close form
9876 keep_delims preserve the delimiters around the string
9877 re_reparse compiling a run-time /(?{})/:
9878 collapse // to /, and skip encoding src
9879 delimp if non-null, this is set to the position of
9880 the closing delimiter, or just after it if
9881 the closing and opening delimiters differ
9882 (i.e., the opening delimiter of a substitu-
9884 returns: position to continue reading from buffer
9885 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9886 updates the read buffer.
9888 This subroutine pulls a string out of the input. It is called for:
9889 q single quotes q(literal text)
9890 ' single quotes 'literal text'
9891 qq double quotes qq(interpolate $here please)
9892 " double quotes "interpolate $here please"
9893 qx backticks qx(/bin/ls -l)
9894 ` backticks `/bin/ls -l`
9895 qw quote words @EXPORT_OK = qw( func() $spam )
9896 m// regexp match m/this/
9897 s/// regexp substitute s/this/that/
9898 tr/// string transliterate tr/this/that/
9899 y/// string transliterate y/this/that/
9900 ($*@) sub prototypes sub foo ($)
9901 (stuff) sub attr parameters sub foo : attr(stuff)
9902 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9904 In most of these cases (all but <>, patterns and transliterate)
9905 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9906 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9907 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9910 It skips whitespace before the string starts, and treats the first
9911 character as the delimiter. If the delimiter is one of ([{< then
9912 the corresponding "close" character )]}> is used as the closing
9913 delimiter. It allows quoting of delimiters, and if the string has
9914 balanced delimiters ([{<>}]) it allows nesting.
9916 On success, the SV with the resulting string is put into lex_stuff or,
9917 if that is already non-NULL, into lex_repl. The second case occurs only
9918 when parsing the RHS of the special constructs s/// and tr/// (y///).
9919 For convenience, the terminating delimiter character is stuffed into
9924 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9928 SV *sv; /* scalar value: string */
9929 const char *tmps; /* temp string, used for delimiter matching */
9930 char *s = start; /* current position in the buffer */
9931 char term; /* terminating character */
9932 char *to; /* current position in the sv's data */
9933 I32 brackets = 1; /* bracket nesting level */
9934 bool has_utf8 = FALSE; /* is there any utf8 content? */
9935 I32 termcode; /* terminating char. code */
9936 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9937 STRLEN termlen; /* length of terminating string */
9938 int last_off = 0; /* last position for nesting bracket */
9941 PERL_ARGS_ASSERT_SCAN_STR;
9943 /* skip space before the delimiter */
9948 /* mark where we are, in case we need to report errors */
9951 /* after skipping whitespace, the next character is the terminator */
9954 termcode = termstr[0] = term;
9958 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9959 Copy(s, termstr, termlen, U8);
9960 if (!UTF8_IS_INVARIANT(term))
9964 /* mark where we are */
9965 PL_multi_start = CopLINE(PL_curcop);
9966 PL_multi_open = term;
9967 herelines = PL_parser->herelines;
9969 /* find corresponding closing delimiter */
9970 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9971 termcode = termstr[0] = term = tmps[5];
9973 PL_multi_close = term;
9975 if (PL_multi_open == PL_multi_close) {
9976 keep_bracketed_quoted = FALSE;
9979 /* create a new SV to hold the contents. 79 is the SV's initial length.
9980 What a random number. */
9981 sv = newSV_type(SVt_PVIV);
9983 SvIV_set(sv, termcode);
9984 (void)SvPOK_only(sv); /* validate pointer */
9986 /* move past delimiter and try to read a complete string */
9988 sv_catpvn(sv, s, termlen);
9991 if (IN_ENCODING && !UTF && !re_reparse) {
9995 int offset = s - SvPVX_const(PL_linestr);
9996 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9997 &offset, (char*)termstr, termlen);
10001 if (SvIsCOW(PL_linestr)) {
10002 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
10003 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
10004 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
10005 char *buf = SvPVX(PL_linestr);
10006 bufend_pos = PL_parser->bufend - buf;
10007 bufptr_pos = PL_parser->bufptr - buf;
10008 oldbufptr_pos = PL_parser->oldbufptr - buf;
10009 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
10010 linestart_pos = PL_parser->linestart - buf;
10011 last_uni_pos = PL_parser->last_uni
10012 ? PL_parser->last_uni - buf
10014 last_lop_pos = PL_parser->last_lop
10015 ? PL_parser->last_lop - buf
10017 re_eval_start_pos =
10018 PL_parser->lex_shared->re_eval_start ?
10019 PL_parser->lex_shared->re_eval_start - buf : 0;
10022 sv_force_normal(PL_linestr);
10024 buf = SvPVX(PL_linestr);
10025 PL_parser->bufend = buf + bufend_pos;
10026 PL_parser->bufptr = buf + bufptr_pos;
10027 PL_parser->oldbufptr = buf + oldbufptr_pos;
10028 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
10029 PL_parser->linestart = buf + linestart_pos;
10030 if (PL_parser->last_uni)
10031 PL_parser->last_uni = buf + last_uni_pos;
10032 if (PL_parser->last_lop)
10033 PL_parser->last_lop = buf + last_lop_pos;
10034 if (PL_parser->lex_shared->re_eval_start)
10035 PL_parser->lex_shared->re_eval_start =
10036 buf + re_eval_start_pos;
10039 ns = SvPVX_const(PL_linestr) + offset;
10040 svlast = SvEND(sv) - 1;
10042 for (; s < ns; s++) {
10043 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10044 COPLINE_INC_WITH_HERELINES;
10047 goto read_more_line;
10049 /* handle quoted delimiters */
10050 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10052 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10054 if ((svlast-1 - t) % 2) {
10055 if (!keep_bracketed_quoted) {
10056 *(svlast-1) = term;
10058 SvCUR_set(sv, SvCUR(sv) - 1);
10063 if (PL_multi_open == PL_multi_close) {
10069 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10070 /* At here, all closes are "was quoted" one,
10071 so we don't check PL_multi_close. */
10073 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
10078 else if (*t == PL_multi_open)
10086 SvCUR_set(sv, w - SvPVX_const(sv));
10088 last_off = w - SvPVX(sv);
10089 if (--brackets <= 0)
10094 if (!keep_delims) {
10095 SvCUR_set(sv, SvCUR(sv) - 1);
10101 /* extend sv if need be */
10102 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10103 /* set 'to' to the next character in the sv's string */
10104 to = SvPVX(sv)+SvCUR(sv);
10106 /* if open delimiter is the close delimiter read unbridle */
10107 if (PL_multi_open == PL_multi_close) {
10108 for (; s < PL_bufend; s++,to++) {
10109 /* embedded newlines increment the current line number */
10110 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10111 COPLINE_INC_WITH_HERELINES;
10112 /* handle quoted delimiters */
10113 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10114 if (!keep_bracketed_quoted
10116 || (re_reparse && s[1] == '\\'))
10119 else /* any other quotes are simply copied straight through */
10122 /* terminate when run out of buffer (the for() condition), or
10123 have found the terminator */
10124 else if (*s == term) {
10127 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10130 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10136 /* if the terminator isn't the same as the start character (e.g.,
10137 matched brackets), we have to allow more in the quoting, and
10138 be prepared for nested brackets.
10141 /* read until we run out of string, or we find the terminator */
10142 for (; s < PL_bufend; s++,to++) {
10143 /* embedded newlines increment the line count */
10144 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10145 COPLINE_INC_WITH_HERELINES;
10146 /* backslashes can escape the open or closing characters */
10147 if (*s == '\\' && s+1 < PL_bufend) {
10148 if (!keep_bracketed_quoted
10149 && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10156 /* allow nested opens and closes */
10157 else if (*s == PL_multi_close && --brackets <= 0)
10159 else if (*s == PL_multi_open)
10161 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10166 /* terminate the copied string and update the sv's end-of-string */
10168 SvCUR_set(sv, to - SvPVX_const(sv));
10171 * this next chunk reads more into the buffer if we're not done yet
10175 break; /* handle case where we are done yet :-) */
10177 #ifndef PERL_STRICT_CR
10178 if (to - SvPVX_const(sv) >= 2) {
10179 if ( (to[-2] == '\r' && to[-1] == '\n')
10180 || (to[-2] == '\n' && to[-1] == '\r'))
10184 SvCUR_set(sv, to - SvPVX_const(sv));
10186 else if (to[-1] == '\r')
10189 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10194 /* if we're out of file, or a read fails, bail and reset the current
10195 line marker so we can report where the unterminated string began
10197 COPLINE_INC_WITH_HERELINES;
10198 PL_bufptr = PL_bufend;
10199 if (!lex_next_chunk(0)) {
10201 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10207 /* at this point, we have successfully read the delimited string */
10209 if (!IN_ENCODING || UTF || re_reparse) {
10212 sv_catpvn(sv, s, termlen);
10215 if (has_utf8 || (IN_ENCODING && !re_reparse))
10218 PL_multi_end = CopLINE(PL_curcop);
10219 CopLINE_set(PL_curcop, PL_multi_start);
10220 PL_parser->herelines = herelines;
10222 /* if we allocated too much space, give some back */
10223 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10224 SvLEN_set(sv, SvCUR(sv) + 1);
10225 SvPV_renew(sv, SvLEN(sv));
10228 /* decide whether this is the first or second quoted string we've read
10233 PL_sublex_info.repl = sv;
10236 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10242 takes: pointer to position in buffer
10243 returns: pointer to new position in buffer
10244 side-effects: builds ops for the constant in pl_yylval.op
10246 Read a number in any of the formats that Perl accepts:
10248 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10249 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10250 0b[01](_?[01])* binary integers
10251 0[0-7](_?[0-7])* octal integers
10252 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10253 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10255 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10258 If it reads a number without a decimal point or an exponent, it will
10259 try converting the number to an integer and see if it can do so
10260 without loss of precision.
10264 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10266 const char *s = start; /* current position in buffer */
10267 char *d; /* destination in temp buffer */
10268 char *e; /* end of temp buffer */
10269 NV nv; /* number read, as a double */
10270 SV *sv = NULL; /* place to put the converted number */
10271 bool floatit; /* boolean: int or float? */
10272 const char *lastub = NULL; /* position of last underbar */
10273 static const char* const number_too_long = "Number too long";
10274 /* Hexadecimal floating point.
10276 * In many places (where we have quads and NV is IEEE 754 double)
10277 * we can fit the mantissa bits of a NV into an unsigned quad.
10278 * (Note that UVs might not be quads even when we have quads.)
10279 * This will not work everywhere, though (either no quads, or
10280 * using long doubles), in which case we have to resort to NV,
10281 * which will probably mean horrible loss of precision due to
10282 * multiple fp operations. */
10283 bool hexfp = FALSE;
10284 int total_bits = 0;
10285 int significant_bits = 0;
10286 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10287 # define HEXFP_UQUAD
10288 Uquad_t hexfp_uquad = 0;
10289 int hexfp_frac_bits = 0;
10294 NV hexfp_mult = 1.0;
10295 UV high_non_zero = 0; /* highest digit */
10296 int non_zero_integer_digits = 0;
10298 PERL_ARGS_ASSERT_SCAN_NUM;
10300 /* We use the first character to decide what type of number this is */
10304 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10306 /* if it starts with a 0, it could be an octal number, a decimal in
10307 0.13 disguise, or a hexadecimal number, or a binary number. */
10311 u holds the "number so far"
10312 shift the power of 2 of the base
10313 (hex == 4, octal == 3, binary == 1)
10314 overflowed was the number more than we can hold?
10316 Shift is used when we add a digit. It also serves as an "are
10317 we in octal/hex/binary?" indicator to disallow hex characters
10318 when in octal mode.
10323 bool overflowed = FALSE;
10324 bool just_zero = TRUE; /* just plain 0 or binary number? */
10325 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10326 static const char* const bases[5] =
10327 { "", "binary", "", "octal", "hexadecimal" };
10328 static const char* const Bases[5] =
10329 { "", "Binary", "", "Octal", "Hexadecimal" };
10330 static const char* const maxima[5] =
10332 "0b11111111111111111111111111111111",
10336 const char *base, *Base, *max;
10338 /* check for hex */
10339 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10343 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10348 /* check for a decimal in disguise */
10349 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10351 /* so it must be octal */
10358 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10359 "Misplaced _ in number");
10363 base = bases[shift];
10364 Base = Bases[shift];
10365 max = maxima[shift];
10367 /* read the rest of the number */
10369 /* x is used in the overflow test,
10370 b is the digit we're adding on. */
10375 /* if we don't mention it, we're done */
10379 /* _ are ignored -- but warned about if consecutive */
10381 if (lastub && s == lastub + 1)
10382 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10383 "Misplaced _ in number");
10387 /* 8 and 9 are not octal */
10388 case '8': case '9':
10390 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10394 case '2': case '3': case '4':
10395 case '5': case '6': case '7':
10397 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10400 case '0': case '1':
10401 b = *s++ & 15; /* ASCII digit -> value of digit */
10405 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10406 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10407 /* make sure they said 0x */
10410 b = (*s++ & 7) + 9;
10412 /* Prepare to put the digit we have onto the end
10413 of the number so far. We check for overflows.
10419 x = u << shift; /* make room for the digit */
10421 total_bits += shift;
10423 if ((x >> shift) != u
10424 && !(PL_hints & HINT_NEW_BINARY)) {
10427 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10428 "Integer overflow in %s number",
10431 u = x | b; /* add the digit to the end */
10434 n *= nvshift[shift];
10435 /* If an NV has not enough bits in its
10436 * mantissa to represent an UV this summing of
10437 * small low-order numbers is a waste of time
10438 * (because the NV cannot preserve the
10439 * low-order bits anyway): we could just
10440 * remember when did we overflow and in the
10441 * end just multiply n by the right
10446 if (high_non_zero == 0 && b > 0)
10450 non_zero_integer_digits++;
10452 /* this could be hexfp, but peek ahead
10453 * to avoid matching ".." */
10454 if (UNLIKELY(HEXFP_PEEK(s))) {
10462 /* if we get here, we had success: make a scalar value from
10467 /* final misplaced underbar check */
10468 if (s[-1] == '_') {
10469 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10472 if (UNLIKELY(HEXFP_PEEK(s))) {
10473 /* Do sloppy (on the underbars) but quick detection
10474 * (and value construction) for hexfp, the decimal
10475 * detection will shortly be more thorough with the
10476 * underbar checks. */
10478 significant_bits = non_zero_integer_digits * shift;
10481 #else /* HEXFP_NV */
10484 /* Ignore the leading zero bits of
10485 * the high (first) non-zero digit. */
10486 if (high_non_zero) {
10487 if (high_non_zero < 0x8)
10488 significant_bits--;
10489 if (high_non_zero < 0x4)
10490 significant_bits--;
10491 if (high_non_zero < 0x2)
10492 significant_bits--;
10499 bool accumulate = TRUE;
10500 for (h++; (isXDIGIT(*h) || *h == '_'); h++) {
10501 if (isXDIGIT(*h)) {
10502 U8 b = XDIGIT_VALUE(*h);
10503 significant_bits += shift;
10506 if (significant_bits < NV_MANT_DIG) {
10507 /* We are in the long "run" of xdigits,
10508 * accumulate the full four bits. */
10509 hexfp_uquad <<= shift;
10511 hexfp_frac_bits += shift;
10513 /* We are at a hexdigit either at,
10514 * or straddling, the edge of mantissa.
10515 * We will try grabbing as many as
10516 * possible bits. */
10518 significant_bits - NV_MANT_DIG;
10521 hexfp_uquad <<= tail;
10522 hexfp_uquad |= b >> (shift - tail);
10523 hexfp_frac_bits += tail;
10525 /* Ignore the trailing zero bits
10526 * of the last non-zero xdigit.
10528 * The assumption here is that if
10529 * one has input of e.g. the xdigit
10530 * eight (0x8), there is only one
10531 * bit being input, not the full
10532 * four bits. Conversely, if one
10533 * specifies a zero xdigit, the
10534 * assumption is that one really
10535 * wants all those bits to be zero. */
10537 if ((b & 0x1) == 0x0) {
10538 significant_bits--;
10539 if ((b & 0x2) == 0x0) {
10540 significant_bits--;
10541 if ((b & 0x4) == 0x0) {
10542 significant_bits--;
10548 accumulate = FALSE;
10551 /* Keep skipping the xdigits, and
10552 * accumulating the significant bits,
10553 * but do not shift the uquad
10554 * (which would catastrophically drop
10555 * high-order bits) or accumulate the
10556 * xdigits anymore. */
10558 #else /* HEXFP_NV */
10562 hexfp_nv += b * nv_mult;
10564 accumulate = FALSE;
10568 if (significant_bits >= NV_MANT_DIG)
10569 accumulate = FALSE;
10573 if ((total_bits > 0 || significant_bits > 0) &&
10574 isALPHA_FOLD_EQ(*h, 'p')) {
10575 bool negexp = FALSE;
10579 else if (*h == '-') {
10585 while (isDIGIT(*h) || *h == '_') {
10588 hexfp_exp += *h - '0';
10591 && -hexfp_exp < NV_MIN_EXP - 1) {
10592 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10593 "Hexadecimal float: exponent underflow");
10599 && hexfp_exp > NV_MAX_EXP - 1) {
10600 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10601 "Hexadecimal float: exponent overflow");
10609 hexfp_exp = -hexfp_exp;
10611 hexfp_exp -= hexfp_frac_bits;
10613 hexfp_mult = pow(2.0, hexfp_exp);
10621 if (n > 4294967295.0)
10622 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10623 "%s number > %s non-portable",
10629 if (u > 0xffffffff)
10630 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10631 "%s number > %s non-portable",
10636 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10637 sv = new_constant(start, s - start, "integer",
10638 sv, NULL, NULL, 0);
10639 else if (PL_hints & HINT_NEW_BINARY)
10640 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10645 handle decimal numbers.
10646 we're also sent here when we read a 0 as the first digit
10648 case '1': case '2': case '3': case '4': case '5':
10649 case '6': case '7': case '8': case '9': case '.':
10652 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10661 /* read next group of digits and _ and copy into d */
10664 || UNLIKELY(hexfp && isXDIGIT(*s)))
10666 /* skip underscores, checking for misplaced ones
10670 if (lastub && s == lastub + 1)
10671 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10672 "Misplaced _ in number");
10676 /* check for end of fixed-length buffer */
10678 Perl_croak(aTHX_ "%s", number_too_long);
10679 /* if we're ok, copy the character */
10684 /* final misplaced underbar check */
10685 if (lastub && s == lastub + 1) {
10686 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10689 /* read a decimal portion if there is one. avoid
10690 3..5 being interpreted as the number 3. followed
10693 if (*s == '.' && s[1] != '.') {
10698 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10699 "Misplaced _ in number");
10703 /* copy, ignoring underbars, until we run out of digits.
10707 || UNLIKELY(hexfp && isXDIGIT(*s));
10710 /* fixed length buffer check */
10712 Perl_croak(aTHX_ "%s", number_too_long);
10714 if (lastub && s == lastub + 1)
10715 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10716 "Misplaced _ in number");
10722 /* fractional part ending in underbar? */
10723 if (s[-1] == '_') {
10724 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10725 "Misplaced _ in number");
10727 if (*s == '.' && isDIGIT(s[1])) {
10728 /* oops, it's really a v-string, but without the "v" */
10734 /* read exponent part, if present */
10735 if ((isALPHA_FOLD_EQ(*s, 'e')
10736 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10737 && strchr("+-0123456789_", s[1]))
10741 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10742 ditto for p (hexfloats) */
10743 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10744 /* At least some Mach atof()s don't grok 'E' */
10747 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10754 /* stray preinitial _ */
10756 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10757 "Misplaced _ in number");
10761 /* allow positive or negative exponent */
10762 if (*s == '+' || *s == '-')
10765 /* stray initial _ */
10767 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10768 "Misplaced _ in number");
10772 /* read digits of exponent */
10773 while (isDIGIT(*s) || *s == '_') {
10776 Perl_croak(aTHX_ "%s", number_too_long);
10780 if (((lastub && s == lastub + 1)
10781 || (!isDIGIT(s[1]) && s[1] != '_')))
10782 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10783 "Misplaced _ in number");
10791 We try to do an integer conversion first if no characters
10792 indicating "float" have been found.
10797 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10799 if (flags == IS_NUMBER_IN_UV) {
10801 sv = newSViv(uv); /* Prefer IVs over UVs. */
10804 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10805 if (uv <= (UV) IV_MIN)
10806 sv = newSViv(-(IV)uv);
10813 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10814 /* terminate the string */
10816 if (UNLIKELY(hexfp)) {
10817 # ifdef NV_MANT_DIG
10818 if (significant_bits > NV_MANT_DIG)
10819 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10820 "Hexadecimal float: mantissa overflow");
10823 nv = hexfp_uquad * hexfp_mult;
10824 #else /* HEXFP_NV */
10825 nv = hexfp_nv * hexfp_mult;
10828 nv = Atof(PL_tokenbuf);
10830 RESTORE_LC_NUMERIC_UNDERLYING();
10835 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10836 const char *const key = floatit ? "float" : "integer";
10837 const STRLEN keylen = floatit ? 5 : 7;
10838 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10839 key, keylen, sv, NULL, NULL, 0);
10843 /* if it starts with a v, it could be a v-string */
10846 sv = newSV(5); /* preallocate storage space */
10847 ENTER_with_name("scan_vstring");
10849 s = scan_vstring(s, PL_bufend, sv);
10850 SvREFCNT_inc_simple_void_NN(sv);
10851 LEAVE_with_name("scan_vstring");
10855 /* make the op for the constant and return */
10858 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10860 lvalp->opval = NULL;
10866 S_scan_formline(pTHX_ char *s)
10870 SV * const stuff = newSVpvs("");
10871 bool needargs = FALSE;
10872 bool eofmt = FALSE;
10874 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10876 while (!needargs) {
10879 #ifdef PERL_STRICT_CR
10880 while (SPACE_OR_TAB(*t))
10883 while (SPACE_OR_TAB(*t) || *t == '\r')
10886 if (*t == '\n' || t == PL_bufend) {
10891 eol = (char *) memchr(s,'\n',PL_bufend-s);
10895 for (t = s; t < eol; t++) {
10896 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10898 goto enough; /* ~~ must be first line in formline */
10900 if (*t == '@' || *t == '^')
10904 sv_catpvn(stuff, s, eol-s);
10905 #ifndef PERL_STRICT_CR
10906 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10907 char *end = SvPVX(stuff) + SvCUR(stuff);
10910 SvCUR_set(stuff, SvCUR(stuff) - 1);
10918 if ((PL_rsfp || PL_parser->filtered)
10919 && PL_parser->form_lex_state == LEX_NORMAL) {
10921 PL_bufptr = PL_bufend;
10922 COPLINE_INC_WITH_HERELINES;
10923 got_some = lex_next_chunk(0);
10924 CopLINE_dec(PL_curcop);
10932 if (!SvCUR(stuff) || needargs)
10933 PL_lex_state = PL_parser->form_lex_state;
10934 if (SvCUR(stuff)) {
10935 PL_expect = XSTATE;
10937 const char *s2 = s;
10938 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10942 PL_expect = XTERMBLOCK;
10943 NEXTVAL_NEXTTOKE.ival = 0;
10946 NEXTVAL_NEXTTOKE.ival = 0;
10947 force_next(FORMLBRACK);
10950 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10952 else if (IN_ENCODING)
10953 sv_recode_to_utf8(stuff, _get_encoding());
10955 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10959 SvREFCNT_dec(stuff);
10961 PL_lex_formbrack = 0;
10967 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10969 const I32 oldsavestack_ix = PL_savestack_ix;
10970 CV* const outsidecv = PL_compcv;
10972 SAVEI32(PL_subline);
10973 save_item(PL_subname);
10974 SAVESPTR(PL_compcv);
10976 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10977 CvFLAGS(PL_compcv) |= flags;
10979 PL_subline = CopLINE(PL_curcop);
10980 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10981 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10982 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10983 if (outsidecv && CvPADLIST(outsidecv))
10984 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10986 return oldsavestack_ix;
10990 S_yywarn(pTHX_ const char *const s, U32 flags)
10992 PERL_ARGS_ASSERT_YYWARN;
10994 PL_in_eval |= EVAL_WARNONLY;
10995 yyerror_pv(s, flags);
11000 Perl_yyerror(pTHX_ const char *const s)
11002 PERL_ARGS_ASSERT_YYERROR;
11003 return yyerror_pvn(s, strlen(s), 0);
11007 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11009 PERL_ARGS_ASSERT_YYERROR_PV;
11010 return yyerror_pvn(s, strlen(s), flags);
11014 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11016 const char *context = NULL;
11019 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11020 int yychar = PL_parser->yychar;
11022 PERL_ARGS_ASSERT_YYERROR_PVN;
11024 if (!yychar || (yychar == ';' && !PL_rsfp))
11025 sv_catpvs(where_sv, "at EOF");
11026 else if ( PL_oldoldbufptr
11027 && PL_bufptr > PL_oldoldbufptr
11028 && PL_bufptr - PL_oldoldbufptr < 200
11029 && PL_oldoldbufptr != PL_oldbufptr
11030 && PL_oldbufptr != PL_bufptr)
11034 The code below is removed for NetWare because it abends/crashes on NetWare
11035 when the script has error such as not having the closing quotes like:
11036 if ($var eq "value)
11037 Checking of white spaces is anyway done in NetWare code.
11040 while (isSPACE(*PL_oldoldbufptr))
11043 context = PL_oldoldbufptr;
11044 contlen = PL_bufptr - PL_oldoldbufptr;
11046 else if ( PL_oldbufptr
11047 && PL_bufptr > PL_oldbufptr
11048 && PL_bufptr - PL_oldbufptr < 200
11049 && PL_oldbufptr != PL_bufptr) {
11052 The code below is removed for NetWare because it abends/crashes on NetWare
11053 when the script has error such as not having the closing quotes like:
11054 if ($var eq "value)
11055 Checking of white spaces is anyway done in NetWare code.
11058 while (isSPACE(*PL_oldbufptr))
11061 context = PL_oldbufptr;
11062 contlen = PL_bufptr - PL_oldbufptr;
11064 else if (yychar > 255)
11065 sv_catpvs(where_sv, "next token ???");
11066 else if (yychar == YYEMPTY) {
11067 if ( PL_lex_state == LEX_NORMAL
11068 || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11069 sv_catpvs(where_sv, "at end of line");
11070 else if (PL_lex_inpat)
11071 sv_catpvs(where_sv, "within pattern");
11073 sv_catpvs(where_sv, "within string");
11076 sv_catpvs(where_sv, "next char ");
11078 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11079 else if (isPRINT_LC(yychar)) {
11080 const char string = yychar;
11081 sv_catpvn(where_sv, &string, 1);
11084 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11086 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11087 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11088 OutCopFILE(PL_curcop),
11089 (IV)(PL_parser->preambling == NOLINE
11090 ? CopLINE(PL_curcop)
11091 : PL_parser->preambling));
11093 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11094 UTF8fARG(UTF, contlen, context));
11096 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11097 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11098 Perl_sv_catpvf(aTHX_ msg,
11099 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11100 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11103 if (PL_in_eval & EVAL_WARNONLY) {
11104 PL_in_eval &= ~EVAL_WARNONLY;
11105 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11109 if (PL_error_count >= 10) {
11111 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11112 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11113 SVfARG(errsv), OutCopFILE(PL_curcop));
11115 Perl_croak(aTHX_ "%s has too many errors.\n",
11116 OutCopFILE(PL_curcop));
11119 PL_in_my_stash = NULL;
11124 S_swallow_bom(pTHX_ U8 *s)
11126 const STRLEN slen = SvCUR(PL_linestr);
11128 PERL_ARGS_ASSERT_SWALLOW_BOM;
11132 if (s[1] == 0xFE) {
11133 /* UTF-16 little-endian? (or UTF-32LE?) */
11134 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11135 /* diag_listed_as: Unsupported script encoding %s */
11136 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11137 #ifndef PERL_NO_UTF16_FILTER
11138 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11140 if (PL_bufend > (char*)s) {
11141 s = add_utf16_textfilter(s, TRUE);
11144 /* diag_listed_as: Unsupported script encoding %s */
11145 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11150 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11151 #ifndef PERL_NO_UTF16_FILTER
11152 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11154 if (PL_bufend > (char *)s) {
11155 s = add_utf16_textfilter(s, FALSE);
11158 /* diag_listed_as: Unsupported script encoding %s */
11159 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11163 case BOM_UTF8_FIRST_BYTE: {
11164 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
11165 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
11166 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11167 s += len + 1; /* UTF-8 */
11174 if (s[2] == 0xFE && s[3] == 0xFF) {
11175 /* UTF-32 big-endian */
11176 /* diag_listed_as: Unsupported script encoding %s */
11177 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11180 else if (s[2] == 0 && s[3] != 0) {
11183 * are a good indicator of UTF-16BE. */
11184 #ifndef PERL_NO_UTF16_FILTER
11185 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11186 s = add_utf16_textfilter(s, FALSE);
11188 /* diag_listed_as: Unsupported script encoding %s */
11189 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11196 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11199 * are a good indicator of UTF-16LE. */
11200 #ifndef PERL_NO_UTF16_FILTER
11201 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11202 s = add_utf16_textfilter(s, TRUE);
11204 /* diag_listed_as: Unsupported script encoding %s */
11205 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11213 #ifndef PERL_NO_UTF16_FILTER
11215 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11217 SV *const filter = FILTER_DATA(idx);
11218 /* We re-use this each time round, throwing the contents away before we
11220 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11221 SV *const utf8_buffer = filter;
11222 IV status = IoPAGE(filter);
11223 const bool reverse = cBOOL(IoLINES(filter));
11226 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11228 /* As we're automatically added, at the lowest level, and hence only called
11229 from this file, we can be sure that we're not called in block mode. Hence
11230 don't bother writing code to deal with block mode. */
11232 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11235 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11237 DEBUG_P(PerlIO_printf(Perl_debug_log,
11238 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11239 FPTR2DPTR(void *, S_utf16_textfilter),
11240 reverse ? 'l' : 'b', idx, maxlen, status,
11241 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11248 /* First, look in our buffer of existing UTF-8 data: */
11249 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11253 } else if (status == 0) {
11255 IoPAGE(filter) = 0;
11256 nl = SvEND(utf8_buffer);
11259 STRLEN got = nl - SvPVX(utf8_buffer);
11260 /* Did we have anything to append? */
11262 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11263 /* Everything else in this code works just fine if SVp_POK isn't
11264 set. This, however, needs it, and we need it to work, else
11265 we loop infinitely because the buffer is never consumed. */
11266 sv_chop(utf8_buffer, nl);
11270 /* OK, not a complete line there, so need to read some more UTF-16.
11271 Read an extra octect if the buffer currently has an odd number. */
11275 if (SvCUR(utf16_buffer) >= 2) {
11276 /* Location of the high octet of the last complete code point.
11277 Gosh, UTF-16 is a pain. All the benefits of variable length,
11278 *coupled* with all the benefits of partial reads and
11280 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11281 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11283 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11287 /* We have the first half of a surrogate. Read more. */
11288 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11291 status = FILTER_READ(idx + 1, utf16_buffer,
11292 160 + (SvCUR(utf16_buffer) & 1));
11293 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11294 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11297 IoPAGE(filter) = status;
11302 chars = SvCUR(utf16_buffer) >> 1;
11303 have = SvCUR(utf8_buffer);
11304 SvGROW(utf8_buffer, have + chars * 3 + 1);
11307 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11308 (U8*)SvPVX_const(utf8_buffer) + have,
11309 chars * 2, &newlen);
11311 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11312 (U8*)SvPVX_const(utf8_buffer) + have,
11313 chars * 2, &newlen);
11315 SvCUR_set(utf8_buffer, have + newlen);
11318 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11319 it's private to us, and utf16_to_utf8{,reversed} take a
11320 (pointer,length) pair, rather than a NUL-terminated string. */
11321 if(SvCUR(utf16_buffer) & 1) {
11322 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11323 SvCUR_set(utf16_buffer, 1);
11325 SvCUR_set(utf16_buffer, 0);
11328 DEBUG_P(PerlIO_printf(Perl_debug_log,
11329 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11331 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11332 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11337 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11339 SV *filter = filter_add(S_utf16_textfilter, NULL);
11341 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11343 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11344 sv_setpvs(filter, "");
11345 IoLINES(filter) = reversed;
11346 IoPAGE(filter) = 1; /* Not EOF */
11348 /* Sadly, we have to return a valid pointer, come what may, so we have to
11349 ignore any error return from this. */
11350 SvCUR_set(PL_linestr, 0);
11351 if (FILTER_READ(0, PL_linestr, 0)) {
11352 SvUTF8_on(PL_linestr);
11354 SvUTF8_on(PL_linestr);
11356 PL_bufend = SvEND(PL_linestr);
11357 return (U8*)SvPVX(PL_linestr);
11362 Returns a pointer to the next character after the parsed
11363 vstring, as well as updating the passed in sv.
11365 Function must be called like
11367 sv = sv_2mortal(newSV(5));
11368 s = scan_vstring(s,e,sv);
11370 where s and e are the start and end of the string.
11371 The sv should already be large enough to store the vstring
11372 passed in, for performance reasons.
11374 This function may croak if fatal warnings are enabled in the
11375 calling scope, hence the sv_2mortal in the example (to prevent
11376 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11382 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11384 const char *pos = s;
11385 const char *start = s;
11387 PERL_ARGS_ASSERT_SCAN_VSTRING;
11389 if (*pos == 'v') pos++; /* get past 'v' */
11390 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11392 if ( *pos != '.') {
11393 /* this may not be a v-string if followed by => */
11394 const char *next = pos;
11395 while (next < e && isSPACE(*next))
11397 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11398 /* return string not v-string */
11399 sv_setpvn(sv,(char *)s,pos-s);
11400 return (char *)pos;
11404 if (!isALPHA(*pos)) {
11405 U8 tmpbuf[UTF8_MAXBYTES+1];
11408 s++; /* get past 'v' */
11413 /* this is atoi() that tolerates underscores */
11416 const char *end = pos;
11418 while (--end >= s) {
11420 const UV orev = rev;
11421 rev += (*end - '0') * mult;
11424 /* diag_listed_as: Integer overflow in %s number */
11425 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11426 "Integer overflow in decimal number");
11430 /* Append native character for the rev point */
11431 tmpend = uvchr_to_utf8(tmpbuf, rev);
11432 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11433 if (!UVCHR_IS_INVARIANT(rev))
11435 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11441 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11445 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11452 Perl_keyword_plugin_standard(pTHX_
11453 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11455 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11456 PERL_UNUSED_CONTEXT;
11457 PERL_UNUSED_ARG(keyword_ptr);
11458 PERL_UNUSED_ARG(keyword_len);
11459 PERL_UNUSED_ARG(op_ptr);
11460 return KEYWORD_PLUGIN_DECLINE;
11463 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11465 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11467 SAVEI32(PL_lex_brackets);
11468 if (PL_lex_brackets > 100)
11469 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11470 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11471 SAVEI32(PL_lex_allbrackets);
11472 PL_lex_allbrackets = 0;
11473 SAVEI8(PL_lex_fakeeof);
11474 PL_lex_fakeeof = (U8)fakeeof;
11475 if(yyparse(gramtype) && !PL_parser->error_count)
11476 qerror(Perl_mess(aTHX_ "Parse error"));
11479 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11481 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11485 SAVEVPTR(PL_eval_root);
11486 PL_eval_root = NULL;
11487 parse_recdescent(gramtype, fakeeof);
11493 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11495 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11498 if (flags & ~PARSE_OPTIONAL)
11499 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11500 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11501 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11502 if (!PL_parser->error_count)
11503 qerror(Perl_mess(aTHX_ "Parse error"));
11504 exprop = newOP(OP_NULL, 0);
11510 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11512 Parse a Perl arithmetic expression. This may contain operators of precedence
11513 down to the bit shift operators. The expression must be followed (and thus
11514 terminated) either by a comparison or lower-precedence operator or by
11515 something that would normally terminate an expression such as semicolon.
11516 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11517 otherwise it is mandatory. It is up to the caller to ensure that the
11518 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11519 the source of the code to be parsed and the lexical context for the
11522 The op tree representing the expression is returned. If an optional
11523 expression is absent, a null pointer is returned, otherwise the pointer
11526 If an error occurs in parsing or compilation, in most cases a valid op
11527 tree is returned anyway. The error is reflected in the parser state,
11528 normally resulting in a single exception at the top level of parsing
11529 which covers all the compilation errors that occurred. Some compilation
11530 errors, however, will throw an exception immediately.
11536 Perl_parse_arithexpr(pTHX_ U32 flags)
11538 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11542 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11544 Parse a Perl term expression. This may contain operators of precedence
11545 down to the assignment operators. The expression must be followed (and thus
11546 terminated) either by a comma or lower-precedence operator or by
11547 something that would normally terminate an expression such as semicolon.
11548 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11549 otherwise it is mandatory. It is up to the caller to ensure that the
11550 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11551 the source of the code to be parsed and the lexical context for the
11554 The op tree representing the expression is returned. If an optional
11555 expression is absent, a null pointer is returned, otherwise the pointer
11558 If an error occurs in parsing or compilation, in most cases a valid op
11559 tree is returned anyway. The error is reflected in the parser state,
11560 normally resulting in a single exception at the top level of parsing
11561 which covers all the compilation errors that occurred. Some compilation
11562 errors, however, will throw an exception immediately.
11568 Perl_parse_termexpr(pTHX_ U32 flags)
11570 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11574 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11576 Parse a Perl list expression. This may contain operators of precedence
11577 down to the comma operator. The expression must be followed (and thus
11578 terminated) either by a low-precedence logic operator such as C<or> or by
11579 something that would normally terminate an expression such as semicolon.
11580 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11581 otherwise it is mandatory. It is up to the caller to ensure that the
11582 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11583 the source of the code to be parsed and the lexical context for the
11586 The op tree representing the expression is returned. If an optional
11587 expression is absent, a null pointer is returned, otherwise the pointer
11590 If an error occurs in parsing or compilation, in most cases a valid op
11591 tree is returned anyway. The error is reflected in the parser state,
11592 normally resulting in a single exception at the top level of parsing
11593 which covers all the compilation errors that occurred. Some compilation
11594 errors, however, will throw an exception immediately.
11600 Perl_parse_listexpr(pTHX_ U32 flags)
11602 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11606 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11608 Parse a single complete Perl expression. This allows the full
11609 expression grammar, including the lowest-precedence operators such
11610 as C<or>. The expression must be followed (and thus terminated) by a
11611 token that an expression would normally be terminated by: end-of-file,
11612 closing bracketing punctuation, semicolon, or one of the keywords that
11613 signals a postfix expression-statement modifier. If C<flags> has the
11614 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
11615 mandatory. It is up to the caller to ensure that the dynamic parser
11616 state (L</PL_parser> et al) is correctly set to reflect the source of
11617 the code to be parsed and the lexical context for the expression.
11619 The op tree representing the expression is returned. If an optional
11620 expression is absent, a null pointer is returned, otherwise the pointer
11623 If an error occurs in parsing or compilation, in most cases a valid op
11624 tree is returned anyway. The error is reflected in the parser state,
11625 normally resulting in a single exception at the top level of parsing
11626 which covers all the compilation errors that occurred. Some compilation
11627 errors, however, will throw an exception immediately.
11633 Perl_parse_fullexpr(pTHX_ U32 flags)
11635 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11639 =for apidoc Amx|OP *|parse_block|U32 flags
11641 Parse a single complete Perl code block. This consists of an opening
11642 brace, a sequence of statements, and a closing brace. The block
11643 constitutes a lexical scope, so C<my> variables and various compile-time
11644 effects can be contained within it. It is up to the caller to ensure
11645 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11646 reflect the source of the code to be parsed and the lexical context for
11649 The op tree representing the code block is returned. This is always a
11650 real op, never a null pointer. It will normally be a C<lineseq> list,
11651 including C<nextstate> or equivalent ops. No ops to construct any kind
11652 of runtime scope are included by virtue of it being a block.
11654 If an error occurs in parsing or compilation, in most cases a valid op
11655 tree (most likely null) is returned anyway. The error is reflected in
11656 the parser state, normally resulting in a single exception at the top
11657 level of parsing which covers all the compilation errors that occurred.
11658 Some compilation errors, however, will throw an exception immediately.
11660 The C<flags> parameter is reserved for future use, and must always
11667 Perl_parse_block(pTHX_ U32 flags)
11670 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11671 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11675 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11677 Parse a single unadorned Perl statement. This may be a normal imperative
11678 statement or a declaration that has compile-time effect. It does not
11679 include any label or other affixture. It is up to the caller to ensure
11680 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11681 reflect the source of the code to be parsed and the lexical context for
11684 The op tree representing the statement is returned. This may be a
11685 null pointer if the statement is null, for example if it was actually
11686 a subroutine definition (which has compile-time side effects). If not
11687 null, it will be ops directly implementing the statement, suitable to
11688 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11689 equivalent op (except for those embedded in a scope contained entirely
11690 within the statement).
11692 If an error occurs in parsing or compilation, in most cases a valid op
11693 tree (most likely null) is returned anyway. The error is reflected in
11694 the parser state, normally resulting in a single exception at the top
11695 level of parsing which covers all the compilation errors that occurred.
11696 Some compilation errors, however, will throw an exception immediately.
11698 The C<flags> parameter is reserved for future use, and must always
11705 Perl_parse_barestmt(pTHX_ U32 flags)
11708 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11709 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11713 =for apidoc Amx|SV *|parse_label|U32 flags
11715 Parse a single label, possibly optional, of the type that may prefix a
11716 Perl statement. It is up to the caller to ensure that the dynamic parser
11717 state (L</PL_parser> et al) is correctly set to reflect the source of
11718 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
11719 label is optional, otherwise it is mandatory.
11721 The name of the label is returned in the form of a fresh scalar. If an
11722 optional label is absent, a null pointer is returned.
11724 If an error occurs in parsing, which can only occur if the label is
11725 mandatory, a valid label is returned anyway. The error is reflected in
11726 the parser state, normally resulting in a single exception at the top
11727 level of parsing which covers all the compilation errors that occurred.
11733 Perl_parse_label(pTHX_ U32 flags)
11735 if (flags & ~PARSE_OPTIONAL)
11736 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11737 if (PL_lex_state == LEX_KNOWNEXT) {
11738 PL_parser->yychar = yylex();
11739 if (PL_parser->yychar == LABEL) {
11740 char * const lpv = pl_yylval.pval;
11741 STRLEN llen = strlen(lpv);
11742 PL_parser->yychar = YYEMPTY;
11743 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11750 STRLEN wlen, bufptr_pos;
11753 if (!isIDFIRST_lazy_if(s, UTF))
11755 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11756 if (word_takes_any_delimeter(s, wlen))
11758 bufptr_pos = s - SvPVX(PL_linestr);
11760 lex_read_space(LEX_KEEP_PREVIOUS);
11762 s = SvPVX(PL_linestr) + bufptr_pos;
11763 if (t[0] == ':' && t[1] != ':') {
11764 PL_oldoldbufptr = PL_oldbufptr;
11767 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11771 if (flags & PARSE_OPTIONAL) {
11774 qerror(Perl_mess(aTHX_ "Parse error"));
11775 return newSVpvs("x");
11782 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11784 Parse a single complete Perl statement. This may be a normal imperative
11785 statement or a declaration that has compile-time effect, and may include
11786 optional labels. It is up to the caller to ensure that the dynamic
11787 parser state (L</PL_parser> et al) is correctly set to reflect the source
11788 of the code to be parsed and the lexical context for the statement.
11790 The op tree representing the statement is returned. This may be a
11791 null pointer if the statement is null, for example if it was actually
11792 a subroutine definition (which has compile-time side effects). If not
11793 null, it will be the result of a L</newSTATEOP> call, normally including
11794 a C<nextstate> or equivalent op.
11796 If an error occurs in parsing or compilation, in most cases a valid op
11797 tree (most likely null) is returned anyway. The error is reflected in
11798 the parser state, normally resulting in a single exception at the top
11799 level of parsing which covers all the compilation errors that occurred.
11800 Some compilation errors, however, will throw an exception immediately.
11802 The C<flags> parameter is reserved for future use, and must always
11809 Perl_parse_fullstmt(pTHX_ U32 flags)
11812 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11813 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11817 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11819 Parse a sequence of zero or more Perl statements. These may be normal
11820 imperative statements, including optional labels, or declarations
11821 that have compile-time effect, or any mixture thereof. The statement
11822 sequence ends when a closing brace or end-of-file is encountered in a
11823 place where a new statement could have validly started. It is up to
11824 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11825 is correctly set to reflect the source of the code to be parsed and the
11826 lexical context for the statements.
11828 The op tree representing the statement sequence is returned. This may
11829 be a null pointer if the statements were all null, for example if there
11830 were no statements or if there were only subroutine definitions (which
11831 have compile-time side effects). If not null, it will be a C<lineseq>
11832 list, normally including C<nextstate> or equivalent ops.
11834 If an error occurs in parsing or compilation, in most cases a valid op
11835 tree is returned anyway. The error is reflected in the parser state,
11836 normally resulting in a single exception at the top level of parsing
11837 which covers all the compilation errors that occurred. Some compilation
11838 errors, however, will throw an exception immediately.
11840 The C<flags> parameter is reserved for future use, and must always
11847 Perl_parse_stmtseq(pTHX_ U32 flags)
11852 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11853 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11854 c = lex_peek_unichar(0);
11855 if (c != -1 && c != /*{*/'}')
11856 qerror(Perl_mess(aTHX_ "Parse error"));
11860 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11862 S_lex_token_boundary(pTHX)
11864 PL_oldoldbufptr = PL_oldbufptr;
11865 PL_oldbufptr = PL_bufptr;
11868 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11870 S_parse_opt_lexvar(pTHX)
11875 lex_token_boundary();
11876 sigil = lex_read_unichar(0);
11877 if (lex_peek_unichar(0) == '#') {
11878 qerror(Perl_mess(aTHX_ "Parse error"));
11882 c = lex_peek_unichar(0);
11883 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11886 d = PL_tokenbuf + 1;
11887 PL_tokenbuf[0] = (char)sigil;
11888 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11890 if (d == PL_tokenbuf+1)
11892 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11893 OPf_MOD | (OPpLVAL_INTRO<<8));
11894 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11899 Perl_parse_subsignature(pTHX)
11902 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11903 OP *initops = NULL;
11905 c = lex_peek_unichar(0);
11906 while (c != /*(*/')') {
11910 if (prev_type == 2)
11911 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11912 var = parse_opt_lexvar();
11914 newBINOP(OP_AELEM, 0,
11915 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11917 newSVOP(OP_CONST, 0, newSViv(pos))) :
11920 c = lex_peek_unichar(0);
11922 lex_token_boundary();
11923 lex_read_unichar(0);
11925 c = lex_peek_unichar(0);
11926 if (c == ',' || c == /*(*/')') {
11928 qerror(Perl_mess(aTHX_ "Optional parameter "
11929 "lacks default expression"));
11931 OP *defexpr = parse_termexpr(0);
11932 if (defexpr->op_type == OP_UNDEF
11933 && !(defexpr->op_flags & OPf_KIDS))
11939 scalar(newUNOP(OP_RV2AV, 0,
11940 newGVOP(OP_GV, 0, PL_defgv))),
11941 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11943 newCONDOP(0, ifop, expr, defexpr) :
11944 newLOGOP(OP_OR, 0, ifop, defexpr);
11949 if (prev_type == 1)
11950 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11951 "follows optional parameter"));
11953 min_arity = pos + 1;
11955 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11957 initops = op_append_list(OP_LINESEQ, initops,
11958 newSTATEOP(0, NULL, expr));
11964 if (prev_type == 2)
11965 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11966 var = parse_opt_lexvar();
11968 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11969 newBINOP(OP_BIT_AND, 0,
11970 scalar(newUNOP(OP_RV2AV, 0,
11971 newGVOP(OP_GV, 0, PL_defgv))),
11972 newSVOP(OP_CONST, 0, newSViv(1))),
11973 op_convert_list(OP_DIE, 0,
11974 op_convert_list(OP_SPRINTF, 0,
11975 op_append_list(OP_LIST,
11976 newSVOP(OP_CONST, 0,
11977 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11979 op_append_list(OP_LIST,
11980 newSVOP(OP_CONST, 0, newSViv(1)),
11981 newSVOP(OP_CONST, 0, newSViv(2))),
11982 newOP(OP_CALLER, 0))))));
11983 if (pos != min_arity)
11984 chkop = newLOGOP(OP_AND, 0,
11986 scalar(newUNOP(OP_RV2AV, 0,
11987 newGVOP(OP_GV, 0, PL_defgv))),
11988 newSVOP(OP_CONST, 0, newSViv(pos))),
11990 initops = op_append_list(OP_LINESEQ,
11991 newSTATEOP(0, NULL, chkop),
11996 op_prepend_elem(OP_ASLICE,
11997 newOP(OP_PUSHMARK, 0),
11998 newLISTOP(OP_ASLICE, 0,
12000 newSVOP(OP_CONST, 0, newSViv(pos)),
12001 newUNOP(OP_AV2ARYLEN, 0,
12002 ref(newUNOP(OP_RV2AV, 0,
12003 newGVOP(OP_GV, 0, PL_defgv)),
12005 ref(newUNOP(OP_RV2AV, 0,
12006 newGVOP(OP_GV, 0, PL_defgv)),
12008 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
12009 initops = op_append_list(OP_LINESEQ, initops,
12010 newSTATEOP(0, NULL,
12011 newASSIGNOP(OPf_STACKED, var, 0, slice)));
12018 qerror(Perl_mess(aTHX_ "Parse error"));
12022 c = lex_peek_unichar(0);
12024 case /*(*/')': break;
12027 lex_token_boundary();
12028 lex_read_unichar(0);
12030 c = lex_peek_unichar(0);
12031 } while (c == ',');
12037 if (min_arity != 0) {
12038 initops = op_append_list(OP_LINESEQ,
12039 newSTATEOP(0, NULL,
12042 scalar(newUNOP(OP_RV2AV, 0,
12043 newGVOP(OP_GV, 0, PL_defgv))),
12044 newSVOP(OP_CONST, 0, newSViv(min_arity))),
12045 op_convert_list(OP_DIE, 0,
12046 op_convert_list(OP_SPRINTF, 0,
12047 op_append_list(OP_LIST,
12048 newSVOP(OP_CONST, 0,
12049 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
12051 op_append_list(OP_LIST,
12052 newSVOP(OP_CONST, 0, newSViv(1)),
12053 newSVOP(OP_CONST, 0, newSViv(2))),
12054 newOP(OP_CALLER, 0))))))),
12057 if (max_arity != -1) {
12058 initops = op_append_list(OP_LINESEQ,
12059 newSTATEOP(0, NULL,
12062 scalar(newUNOP(OP_RV2AV, 0,
12063 newGVOP(OP_GV, 0, PL_defgv))),
12064 newSVOP(OP_CONST, 0, newSViv(max_arity))),
12065 op_convert_list(OP_DIE, 0,
12066 op_convert_list(OP_SPRINTF, 0,
12067 op_append_list(OP_LIST,
12068 newSVOP(OP_CONST, 0,
12069 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
12071 op_append_list(OP_LIST,
12072 newSVOP(OP_CONST, 0, newSViv(1)),
12073 newSVOP(OP_CONST, 0, newSViv(2))),
12074 newOP(OP_CALLER, 0))))))),
12081 * ex: set ts=8 sts=4 sw=4 et: