3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_static.c"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_sublex_info (PL_parser->sublex_info)
69 #define PL_linestr (PL_parser->linestr)
70 #define PL_expect (PL_parser->expect)
71 #define PL_copline (PL_parser->copline)
72 #define PL_bufptr (PL_parser->bufptr)
73 #define PL_oldbufptr (PL_parser->oldbufptr)
74 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
75 #define PL_linestart (PL_parser->linestart)
76 #define PL_bufend (PL_parser->bufend)
77 #define PL_last_uni (PL_parser->last_uni)
78 #define PL_last_lop (PL_parser->last_lop)
79 #define PL_last_lop_op (PL_parser->last_lop_op)
80 #define PL_lex_state (PL_parser->lex_state)
81 #define PL_rsfp (PL_parser->rsfp)
82 #define PL_rsfp_filters (PL_parser->rsfp_filters)
83 #define PL_in_my (PL_parser->in_my)
84 #define PL_in_my_stash (PL_parser->in_my_stash)
85 #define PL_tokenbuf (PL_parser->tokenbuf)
86 #define PL_multi_end (PL_parser->multi_end)
87 #define PL_error_count (PL_parser->error_count)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_nexttype (PL_parser->nexttype)
91 # define PL_nextval (PL_parser->nextval)
93 static const char* const ident_too_long = "Identifier too long";
95 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
97 #define XENUMMASK 0x3f
99 #define XFAKEBRACK 0x80
101 #ifdef USE_UTF8_SCRIPTS
102 # define UTF cBOOL(!IN_BYTES)
104 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
107 /* The maximum number of characters preceding the unrecognized one to display */
108 #define UNRECOGNIZED_PRECEDE_COUNT 10
110 /* In variables named $^X, these are the legal values for X.
111 * 1999-02-27 mjd-perl-patch@plover.com */
112 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
114 #define SPACE_OR_TAB(c) isBLANK_A(c)
116 #define HEXFP_PEEK(s) \
118 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
119 isALPHA_FOLD_EQ(s[0], 'p'))
121 /* LEX_* are values for PL_lex_state, the state of the lexer.
122 * They are arranged oddly so that the guard on the switch statement
123 * can get by with a single comparison (if the compiler is smart enough).
125 * These values refer to the various states within a sublex parse,
126 * i.e. within a double quotish string
129 /* #define LEX_NOTPARSING 11 is done in perl.h. */
131 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
132 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
133 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
134 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
135 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
137 /* at end of code, eg "$x" followed by: */
138 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
139 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
141 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
142 string or after \E, $foo, etc */
143 #define LEX_INTERPCONST 2 /* NOT USED */
144 #define LEX_FORMLINE 1 /* expecting a format line */
145 #define LEX_KNOWNEXT 0 /* next token known; just return it */
149 static const char* const lex_state_names[] = {
164 #include "keywords.h"
166 /* CLINE is a macro that ensures PL_copline has a sane value */
168 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 * Convenience functions to return different tokens and prime the
172 * lexer for the next token. They all take an argument.
174 * TOKEN : generic token (used for '(', DOLSHARP, etc)
175 * OPERATOR : generic operator
176 * AOPERATOR : assignment operator
177 * PREBLOCK : beginning the block after an if, while, foreach, ...
178 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
179 * PREREF : *EXPR where EXPR is not a simple identifier
180 * TERM : expression term
181 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
182 * LOOPX : loop exiting command (goto, last, dump, etc)
183 * FTST : file test operator
184 * FUN0 : zero-argument function
185 * FUN0OP : zero-argument function, with its op created in this file
186 * FUN1 : not used, except for not, which isn't a UNIOP
187 * BOop : bitwise or or xor
189 * BCop : bitwise complement
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
194 * AopNOASSIGN : addition-level operator that is never part of .=
195 * Mop : multiplication-level operator
196 * Eop : equality-testing operator
197 * Rop : relational operator <= != gt
199 * Also see LOP and lop() below.
202 #ifdef DEBUGGING /* Serve -DT. */
203 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
205 # define REPORT(retval) (retval)
208 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
209 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
210 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
211 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
213 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
214 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
215 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
216 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
218 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
220 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
221 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
222 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
223 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
224 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
225 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
226 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
228 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
229 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
230 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
231 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
232 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
233 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
234 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
235 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
237 /* This bit of chicanery makes a unary function followed by
238 * a parenthesis into a function with one argument, highest precedence.
239 * The UNIDOR macro is for unary functions that can be followed by the //
240 * operator (such as C<shift // 0>).
242 #define UNI3(f,x,have_x) { \
243 pl_yylval.ival = f; \
244 if (have_x) PL_expect = x; \
246 PL_last_uni = PL_oldbufptr; \
247 PL_last_lop_op = f; \
249 return REPORT( (int)FUNC1 ); \
251 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
253 #define UNI(f) UNI3(f,XTERM,1)
254 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
255 #define UNIPROTO(f,optional) { \
256 if (optional) PL_last_uni = PL_oldbufptr; \
260 #define UNIBRACK(f) UNI3(f,0,0)
262 /* grandfather return to old style */
265 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
266 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
267 pl_yylval.ival = (f); \
273 #define COPLINE_INC_WITH_HERELINES \
275 CopLINE_inc(PL_curcop); \
276 if (PL_parser->herelines) \
277 CopLINE(PL_curcop) += PL_parser->herelines, \
278 PL_parser->herelines = 0; \
280 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
281 * is no sublex_push to follow. */
282 #define COPLINE_SET_FROM_MULTI_END \
284 CopLINE_set(PL_curcop, PL_multi_end); \
285 if (PL_multi_end != PL_multi_start) \
286 PL_parser->herelines = 0; \
292 /* how to interpret the pl_yylval associated with the token */
296 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
301 static struct debug_tokens {
303 enum token_type type;
305 } const debug_tokens[] =
307 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
308 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
309 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
310 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
311 { ARROW, TOKENTYPE_NONE, "ARROW" },
312 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
313 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
314 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
315 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
316 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
317 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
318 { DO, TOKENTYPE_NONE, "DO" },
319 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
320 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
321 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
322 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
323 { ELSE, TOKENTYPE_NONE, "ELSE" },
324 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
325 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
326 { FOR, TOKENTYPE_IVAL, "FOR" },
327 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
328 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
329 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
330 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
331 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
332 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
333 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
334 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
335 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
336 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
337 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
338 { IF, TOKENTYPE_IVAL, "IF" },
339 { LABEL, TOKENTYPE_PVAL, "LABEL" },
340 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
341 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
342 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
343 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
344 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
345 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
346 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
347 { MY, TOKENTYPE_IVAL, "MY" },
348 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
349 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
350 { OROP, TOKENTYPE_IVAL, "OROP" },
351 { OROR, TOKENTYPE_NONE, "OROR" },
352 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
353 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
354 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
355 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
356 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
357 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
358 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
359 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
360 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
361 { PREINC, TOKENTYPE_NONE, "PREINC" },
362 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
363 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
364 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
365 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
366 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
367 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
368 { SUB, TOKENTYPE_NONE, "SUB" },
369 { THING, TOKENTYPE_OPVAL, "THING" },
370 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
371 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
372 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
373 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
374 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
375 { USE, TOKENTYPE_IVAL, "USE" },
376 { WHEN, TOKENTYPE_IVAL, "WHEN" },
377 { WHILE, TOKENTYPE_IVAL, "WHILE" },
378 { WORD, TOKENTYPE_OPVAL, "WORD" },
379 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
380 { 0, TOKENTYPE_NONE, NULL }
383 /* dump the returned token in rv, plus any optional arg in pl_yylval */
386 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
388 PERL_ARGS_ASSERT_TOKEREPORT;
391 const char *name = NULL;
392 enum token_type type = TOKENTYPE_NONE;
393 const struct debug_tokens *p;
394 SV* const report = newSVpvs("<== ");
396 for (p = debug_tokens; p->token; p++) {
397 if (p->token == (int)rv) {
404 Perl_sv_catpv(aTHX_ report, name);
405 else if (isGRAPH(rv))
407 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
409 sv_catpvs(report, " (pending identifier)");
412 sv_catpvs(report, "EOF");
414 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
419 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
421 case TOKENTYPE_OPNUM:
422 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
423 PL_op_name[lvalp->ival]);
426 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
428 case TOKENTYPE_OPVAL:
430 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
431 PL_op_name[lvalp->opval->op_type]);
432 if (lvalp->opval->op_type == OP_CONST) {
433 Perl_sv_catpvf(aTHX_ report, " %s",
434 SvPEEK(cSVOPx_sv(lvalp->opval)));
439 sv_catpvs(report, "(opval=null)");
442 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
448 /* print the buffer with suitable escapes */
451 S_printbuf(pTHX_ const char *const fmt, const char *const s)
453 SV* const tmp = newSVpvs("");
455 PERL_ARGS_ASSERT_PRINTBUF;
457 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
458 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
466 S_deprecate_commaless_var_list(pTHX) {
468 deprecate("comma-less variable list");
469 return REPORT(','); /* grandfather non-comma-format format */
475 * This subroutine looks for an '=' next to the operator that has just been
476 * parsed and turns it into an ASSIGNOP if it finds one.
480 S_ao(pTHX_ int toketype)
482 if (*PL_bufptr == '=') {
484 if (toketype == ANDAND)
485 pl_yylval.ival = OP_ANDASSIGN;
486 else if (toketype == OROR)
487 pl_yylval.ival = OP_ORASSIGN;
488 else if (toketype == DORDOR)
489 pl_yylval.ival = OP_DORASSIGN;
492 return REPORT(toketype);
497 * When Perl expects an operator and finds something else, no_op
498 * prints the warning. It always prints "<something> found where
499 * operator expected. It prints "Missing semicolon on previous line?"
500 * if the surprise occurs at the start of the line. "do you need to
501 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
502 * where the compiler doesn't know if foo is a method call or a function.
503 * It prints "Missing operator before end of line" if there's nothing
504 * after the missing operator, or "... before <...>" if there is something
505 * after the missing operator.
507 * PL_bufptr is expected to point to the start of the thing that was found,
508 * and s after the next token or partial token.
512 S_no_op(pTHX_ const char *const what, char *s)
514 char * const oldbp = PL_bufptr;
515 const bool is_first = (PL_oldbufptr == PL_linestart);
517 PERL_ARGS_ASSERT_NO_OP;
523 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
524 if (ckWARN_d(WARN_SYNTAX)) {
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
527 "\t(Missing semicolon on previous line?)\n");
528 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
530 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
531 t += UTF ? UTF8SKIP(t) : 1)
533 if (t < PL_bufptr && isSPACE(*t))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Do you need to predeclare %"UTF8f"?)\n",
536 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing operator before %"UTF8f"?)\n",
542 UTF8fARG(UTF, s - oldbp, oldbp));
550 * Complain about missing quote/regexp/heredoc terminator.
551 * If it's called with NULL then it cauterizes the line buffer.
552 * If we're in a delimited string and the delimiter is a control
553 * character, it's reformatted into a two-char sequence like ^C.
558 S_missingterm(pTHX_ char *s)
563 char * const nl = strrchr(s,'\n');
567 else if ((U8) PL_multi_close < 32) {
569 tmpbuf[1] = (char)toCTRL(PL_multi_close);
574 *tmpbuf = (char)PL_multi_close;
578 q = strchr(s,'"') ? '\'' : '"';
579 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
585 * Check whether the named feature is enabled.
588 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
590 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
592 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
594 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
596 if (namelen > MAX_FEATURE_LEN)
598 memcpy(&he_name[8], name, namelen);
600 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
601 REFCOUNTED_HE_EXISTS));
605 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
606 * utf16-to-utf8-reversed.
609 #ifdef PERL_CR_FILTER
613 const char *s = SvPVX_const(sv);
614 const char * const e = s + SvCUR(sv);
616 PERL_ARGS_ASSERT_STRIP_RETURN;
618 /* outer loop optimized to do nothing if there are no CR-LFs */
620 if (*s++ == '\r' && *s == '\n') {
621 /* hit a CR-LF, need to copy the rest */
625 if (*s == '\r' && s[1] == '\n')
636 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
639 if (count > 0 && !maxlen)
646 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
648 Creates and initialises a new lexer/parser state object, supplying
649 a context in which to lex and parse from a new source of Perl code.
650 A pointer to the new state object is placed in L</PL_parser>. An entry
651 is made on the save stack so that upon unwinding the new state object
652 will be destroyed and the former value of L</PL_parser> will be restored.
653 Nothing else need be done to clean up the parsing context.
655 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
656 non-null, provides a string (in SV form) containing code to be parsed.
657 A copy of the string is made, so subsequent modification of I<line>
658 does not affect parsing. I<rsfp>, if non-null, provides an input stream
659 from which code will be read to be parsed. If both are non-null, the
660 code in I<line> comes first and must consist of complete lines of input,
661 and I<rsfp> supplies the remainder of the source.
663 The I<flags> parameter is reserved for future use. Currently it is only
664 used by perl internally, so extensions should always pass zero.
669 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
670 can share filters with the current parser.
671 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
672 caller, hence isn't owned by the parser, so shouldn't be closed on parser
673 destruction. This is used to handle the case of defaulting to reading the
674 script from the standard input because no filename was given on the command
675 line (without getting confused by situation where STDIN has been closed, so
676 the script handle is opened on fd 0) */
679 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
681 const char *s = NULL;
682 yy_parser *parser, *oparser;
683 if (flags && flags & ~LEX_START_FLAGS)
684 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
686 /* create and initialise a parser */
688 Newxz(parser, 1, yy_parser);
689 parser->old_parser = oparser = PL_parser;
692 parser->stack = NULL;
694 parser->stack_size = 0;
696 /* on scope exit, free this parser and restore any outer one */
698 parser->saved_curcop = PL_curcop;
700 /* initialise lexer state */
702 parser->nexttoke = 0;
703 parser->error_count = oparser ? oparser->error_count : 0;
704 parser->copline = parser->preambling = NOLINE;
705 parser->lex_state = LEX_NORMAL;
706 parser->expect = XSTATE;
708 parser->rsfp_filters =
709 !(flags & LEX_START_SAME_FILTER) || !oparser
711 : MUTABLE_AV(SvREFCNT_inc(
712 oparser->rsfp_filters
713 ? oparser->rsfp_filters
714 : (oparser->rsfp_filters = newAV())
717 Newx(parser->lex_brackstack, 120, char);
718 Newx(parser->lex_casestack, 12, char);
719 *parser->lex_casestack = '\0';
720 Newxz(parser->lex_shared, 1, LEXSHARED);
724 s = SvPV_const(line, len);
725 parser->linestr = flags & LEX_START_COPIED
726 ? SvREFCNT_inc_simple_NN(line)
727 : newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
730 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
732 parser->oldoldbufptr =
735 parser->linestart = SvPVX(parser->linestr);
736 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
737 parser->last_lop = parser->last_uni = NULL;
739 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
740 |LEX_DONT_CLOSE_RSFP));
741 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
742 |LEX_DONT_CLOSE_RSFP));
744 parser->in_pod = parser->filtered = 0;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser ||
761 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
764 SvREFCNT_dec(parser->lex_stuff);
765 SvREFCNT_dec(parser->sublex_info.repl);
767 Safefree(parser->lex_brackstack);
768 Safefree(parser->lex_casestack);
769 Safefree(parser->lex_shared);
770 PL_parser = parser->old_parser;
775 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
777 I32 nexttoke = parser->nexttoke;
778 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
780 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
781 && parser->nextval[nexttoke].opval
782 && parser->nextval[nexttoke].opval->op_slabbed
783 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
784 op_free(parser->nextval[nexttoke].opval);
785 parser->nextval[nexttoke].opval = NULL;
792 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
794 Buffer scalar containing the chunk currently under consideration of the
795 text currently being lexed. This is always a plain string scalar (for
796 which C<SvPOK> is true). It is not intended to be used as a scalar by
797 normal scalar means; instead refer to the buffer directly by the pointer
798 variables described below.
800 The lexer maintains various C<char*> pointers to things in the
801 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
802 reallocated, all of these pointers must be updated. Don't attempt to
803 do this manually, but rather use L</lex_grow_linestr> if you need to
804 reallocate the buffer.
806 The content of the text chunk in the buffer is commonly exactly one
807 complete line of input, up to and including a newline terminator,
808 but there are situations where it is otherwise. The octets of the
809 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
810 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
811 flag on this scalar, which may disagree with it.
813 For direct examination of the buffer, the variable
814 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
815 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
816 of these pointers is usually preferable to examination of the scalar
817 through normal scalar means.
819 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
821 Direct pointer to the end of the chunk of text currently being lexed, the
822 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
823 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
824 always located at the end of the buffer, and does not count as part of
825 the buffer's contents.
827 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
829 Points to the current position of lexing inside the lexer buffer.
830 Characters around this point may be freely examined, within
831 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
832 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
833 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
835 Lexing code (whether in the Perl core or not) moves this pointer past
836 the characters that it consumes. It is also expected to perform some
837 bookkeeping whenever a newline character is consumed. This movement
838 can be more conveniently performed by the function L</lex_read_to>,
839 which handles newlines appropriately.
841 Interpretation of the buffer's octets can be abstracted out by
842 using the slightly higher-level functions L</lex_peek_unichar> and
843 L</lex_read_unichar>.
845 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
847 Points to the start of the current line inside the lexer buffer.
848 This is useful for indicating at which column an error occurred, and
849 not much else. This must be updated by any lexing code that consumes
850 a newline; the function L</lex_read_to> handles this detail.
856 =for apidoc Amx|bool|lex_bufutf8
858 Indicates whether the octets in the lexer buffer
859 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
860 of Unicode characters. If not, they should be interpreted as Latin-1
861 characters. This is analogous to the C<SvUTF8> flag for scalars.
863 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
864 contains valid UTF-8. Lexing code must be robust in the face of invalid
867 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
868 is significant, but not the whole story regarding the input character
869 encoding. Normally, when a file is being read, the scalar contains octets
870 and its C<SvUTF8> flag is off, but the octets should be interpreted as
871 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
872 however, the scalar may have the C<SvUTF8> flag on, and in this case its
873 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
874 is in effect. This logic may change in the future; use this function
875 instead of implementing the logic yourself.
881 Perl_lex_bufutf8(pTHX)
887 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
889 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
890 at least I<len> octets (including terminating C<NUL>). Returns a
891 pointer to the reallocated buffer. This is necessary before making
892 any direct modification of the buffer that would increase its length.
893 L</lex_stuff_pvn> provides a more convenient way to insert text into
896 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
897 this function updates all of the lexer's variables that point directly
904 Perl_lex_grow_linestr(pTHX_ STRLEN len)
908 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
909 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
910 linestr = PL_parser->linestr;
911 buf = SvPVX(linestr);
912 if (len <= SvLEN(linestr))
914 bufend_pos = PL_parser->bufend - buf;
915 bufptr_pos = PL_parser->bufptr - buf;
916 oldbufptr_pos = PL_parser->oldbufptr - buf;
917 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
918 linestart_pos = PL_parser->linestart - buf;
919 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
920 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
921 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
922 PL_parser->lex_shared->re_eval_start - buf : 0;
924 buf = sv_grow(linestr, len);
926 PL_parser->bufend = buf + bufend_pos;
927 PL_parser->bufptr = buf + bufptr_pos;
928 PL_parser->oldbufptr = buf + oldbufptr_pos;
929 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
930 PL_parser->linestart = buf + linestart_pos;
931 if (PL_parser->last_uni)
932 PL_parser->last_uni = buf + last_uni_pos;
933 if (PL_parser->last_lop)
934 PL_parser->last_lop = buf + last_lop_pos;
935 if (PL_parser->lex_shared->re_eval_start)
936 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
941 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
943 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
944 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
945 reallocating the buffer if necessary. This means that lexing code that
946 runs later will see the characters as if they had appeared in the input.
947 It is not recommended to do this as part of normal parsing, and most
948 uses of this facility run the risk of the inserted characters being
949 interpreted in an unintended manner.
951 The string to be inserted is represented by I<len> octets starting
952 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
953 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
954 The characters are recoded for the lexer buffer, according to how the
955 buffer is currently being interpreted (L</lex_bufutf8>). If a string
956 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
957 function is more convenient.
963 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
967 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
968 if (flags & ~(LEX_STUFF_UTF8))
969 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
971 if (flags & LEX_STUFF_UTF8) {
974 STRLEN highhalf = 0; /* Count of variants */
975 const char *p, *e = pv+len;
976 for (p = pv; p != e; p++) {
977 if (! UTF8_IS_INVARIANT(*p)) {
983 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
984 bufptr = PL_parser->bufptr;
985 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
986 SvCUR_set(PL_parser->linestr,
987 SvCUR(PL_parser->linestr) + len+highhalf);
988 PL_parser->bufend += len+highhalf;
989 for (p = pv; p != e; p++) {
991 if (! UTF8_IS_INVARIANT(c)) {
992 *bufptr++ = UTF8_TWO_BYTE_HI(c);
993 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1000 if (flags & LEX_STUFF_UTF8) {
1001 STRLEN highhalf = 0;
1002 const char *p, *e = pv+len;
1003 for (p = pv; p != e; p++) {
1005 if (UTF8_IS_ABOVE_LATIN1(c)) {
1006 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1007 "non-Latin-1 character into Latin-1 input");
1008 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1011 } else if (! UTF8_IS_INVARIANT(c)) {
1012 /* malformed UTF-8 */
1014 SAVESPTR(PL_warnhook);
1015 PL_warnhook = PERL_WARNHOOK_FATAL;
1016 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1022 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1023 bufptr = PL_parser->bufptr;
1024 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1025 SvCUR_set(PL_parser->linestr,
1026 SvCUR(PL_parser->linestr) + len-highhalf);
1027 PL_parser->bufend += len-highhalf;
1030 if (UTF8_IS_INVARIANT(*p)) {
1036 *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1042 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1043 bufptr = PL_parser->bufptr;
1044 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1045 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1046 PL_parser->bufend += len;
1047 Copy(pv, bufptr, len, char);
1053 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1055 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1056 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1057 reallocating the buffer if necessary. This means that lexing code that
1058 runs later will see the characters as if they had appeared in the input.
1059 It is not recommended to do this as part of normal parsing, and most
1060 uses of this facility run the risk of the inserted characters being
1061 interpreted in an unintended manner.
1063 The string to be inserted is represented by octets starting at I<pv>
1064 and continuing to the first nul. These octets are interpreted as either
1065 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1066 in I<flags>. The characters are recoded for the lexer buffer, according
1067 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1068 If it is not convenient to nul-terminate a string to be inserted, the
1069 L</lex_stuff_pvn> function is more appropriate.
1075 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1077 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1078 lex_stuff_pvn(pv, strlen(pv), flags);
1082 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1084 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1085 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1086 reallocating the buffer if necessary. This means that lexing code that
1087 runs later will see the characters as if they had appeared in the input.
1088 It is not recommended to do this as part of normal parsing, and most
1089 uses of this facility run the risk of the inserted characters being
1090 interpreted in an unintended manner.
1092 The string to be inserted is the string value of I<sv>. The characters
1093 are recoded for the lexer buffer, according to how the buffer is currently
1094 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1095 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1096 need to construct a scalar.
1102 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1106 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1110 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1114 =for apidoc Amx|void|lex_unstuff|char *ptr
1116 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1117 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1118 This hides the discarded text from any lexing code that runs later,
1119 as if the text had never appeared.
1121 This is not the normal way to consume lexed text. For that, use
1128 Perl_lex_unstuff(pTHX_ char *ptr)
1132 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1133 buf = PL_parser->bufptr;
1135 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 bufend = PL_parser->bufend;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1141 unstuff_len = ptr - buf;
1142 Move(ptr, buf, bufend+1-ptr, char);
1143 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1144 PL_parser->bufend = bufend - unstuff_len;
1148 =for apidoc Amx|void|lex_read_to|char *ptr
1150 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1151 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1152 performing the correct bookkeeping whenever a newline character is passed.
1153 This is the normal way to consume lexed text.
1155 Interpretation of the buffer's octets can be abstracted out by
1156 using the slightly higher-level functions L</lex_peek_unichar> and
1157 L</lex_read_unichar>.
1163 Perl_lex_read_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_READ_TO;
1167 s = PL_parser->bufptr;
1168 if (ptr < s || ptr > PL_parser->bufend)
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1170 for (; s != ptr; s++)
1172 COPLINE_INC_WITH_HERELINES;
1173 PL_parser->linestart = s+1;
1175 PL_parser->bufptr = ptr;
1179 =for apidoc Amx|void|lex_discard_to|char *ptr
1181 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1182 up to I<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. I<ptr> must not
1184 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1185 it is not permitted to discard text that has yet to be lexed.
1187 Normally it is not necessarily to do this directly, because it suffices to
1188 use the implicit discarding behaviour of L</lex_next_chunk> and things
1189 based on it. However, if a token stretches across multiple lines,
1190 and the lexing code has kept multiple lines of text in the buffer for
1191 that purpose, then after completion of the token it would be wise to
1192 explicitly discard the now-unneeded earlier lines, to avoid future
1193 multi-line tokens growing the buffer without bound.
1199 Perl_lex_discard_to(pTHX_ char *ptr)
1203 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1204 buf = SvPVX(PL_parser->linestr);
1206 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1209 if (ptr > PL_parser->bufptr)
1210 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1211 discard_len = ptr - buf;
1212 if (PL_parser->oldbufptr < ptr)
1213 PL_parser->oldbufptr = ptr;
1214 if (PL_parser->oldoldbufptr < ptr)
1215 PL_parser->oldoldbufptr = ptr;
1216 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1217 PL_parser->last_uni = NULL;
1218 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1219 PL_parser->last_lop = NULL;
1220 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1221 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1222 PL_parser->bufend -= discard_len;
1223 PL_parser->bufptr -= discard_len;
1224 PL_parser->oldbufptr -= discard_len;
1225 PL_parser->oldoldbufptr -= discard_len;
1226 if (PL_parser->last_uni)
1227 PL_parser->last_uni -= discard_len;
1228 if (PL_parser->last_lop)
1229 PL_parser->last_lop -= discard_len;
1233 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1235 Reads in the next chunk of text to be lexed, appending it to
1236 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1237 looked to the end of the current chunk and wants to know more. It is
1238 usual, but not necessary, for lexing to have consumed the entirety of
1239 the current chunk at this time.
1241 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1242 chunk (i.e., the current chunk has been entirely consumed), normally the
1243 current chunk will be discarded at the same time that the new chunk is
1244 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1245 will not be discarded. If the current chunk has not been entirely
1246 consumed, then it will not be discarded regardless of the flag.
1248 Returns true if some new text was added to the buffer, or false if the
1249 buffer has reached the end of the input text.
1254 #define LEX_FAKE_EOF 0x80000000
1255 #define LEX_NO_TERM 0x40000000
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 linestr = PL_parser->linestr;
1270 buf = SvPVX(linestr);
1271 if (!(flags & LEX_KEEP_PREVIOUS) &&
1272 PL_parser->bufptr == PL_parser->bufend) {
1273 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1275 if (PL_parser->last_uni != PL_parser->bufend)
1276 PL_parser->last_uni = NULL;
1277 if (PL_parser->last_lop != PL_parser->bufend)
1278 PL_parser->last_lop = NULL;
1279 last_uni_pos = last_lop_pos = 0;
1283 old_bufend_pos = PL_parser->bufend - buf;
1284 bufptr_pos = PL_parser->bufptr - buf;
1285 oldbufptr_pos = PL_parser->oldbufptr - buf;
1286 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1287 linestart_pos = PL_parser->linestart - buf;
1288 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1289 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1291 if (flags & LEX_FAKE_EOF) {
1293 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1295 } else if (filter_gets(linestr, old_bufend_pos)) {
1297 got_some_for_debugger = 1;
1298 } else if (flags & LEX_NO_TERM) {
1301 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1302 sv_setpvs(linestr, "");
1304 /* End of real input. Close filehandle (unless it was STDIN),
1305 * then add implicit termination.
1307 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1308 PerlIO_clearerr(PL_parser->rsfp);
1309 else if (PL_parser->rsfp)
1310 (void)PerlIO_close(PL_parser->rsfp);
1311 PL_parser->rsfp = NULL;
1312 PL_parser->in_pod = PL_parser->filtered = 0;
1313 if (!PL_in_eval && PL_minus_p) {
1315 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1316 PL_minus_n = PL_minus_p = 0;
1317 } else if (!PL_in_eval && PL_minus_n) {
1318 sv_catpvs(linestr, /*{*/";}");
1321 sv_catpvs(linestr, ";");
1324 buf = SvPVX(linestr);
1325 new_bufend_pos = SvCUR(linestr);
1326 PL_parser->bufend = buf + new_bufend_pos;
1327 PL_parser->bufptr = buf + bufptr_pos;
1328 PL_parser->oldbufptr = buf + oldbufptr_pos;
1329 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1330 PL_parser->linestart = buf + linestart_pos;
1331 if (PL_parser->last_uni)
1332 PL_parser->last_uni = buf + last_uni_pos;
1333 if (PL_parser->last_lop)
1334 PL_parser->last_lop = buf + last_lop_pos;
1335 if (PL_parser->preambling != NOLINE) {
1336 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1337 PL_parser->preambling = NOLINE;
1339 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1340 PL_curstash != PL_debstash) {
1341 /* debugger active and we're not compiling the debugger code,
1342 * so store the line into the debugger's array of lines
1344 update_debugger_info(NULL, buf+old_bufend_pos,
1345 new_bufend_pos-old_bufend_pos);
1351 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1353 Looks ahead one (Unicode) character in the text currently being lexed.
1354 Returns the codepoint (unsigned integer value) of the next character,
1355 or -1 if lexing has reached the end of the input text. To consume the
1356 peeked character, use L</lex_read_unichar>.
1358 If the next character is in (or extends into) the next chunk of input
1359 text, the next chunk will be read in. Normally the current chunk will be
1360 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1361 then the current chunk will not be discarded.
1363 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1364 is encountered, an exception is generated.
1370 Perl_lex_peek_unichar(pTHX_ U32 flags)
1374 if (flags & ~(LEX_KEEP_PREVIOUS))
1375 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1376 s = PL_parser->bufptr;
1377 bufend = PL_parser->bufend;
1383 if (!lex_next_chunk(flags))
1385 s = PL_parser->bufptr;
1386 bufend = PL_parser->bufend;
1389 if (UTF8_IS_INVARIANT(head))
1391 if (UTF8_IS_START(head)) {
1392 len = UTF8SKIP(&head);
1393 while ((STRLEN)(bufend-s) < len) {
1394 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1396 s = PL_parser->bufptr;
1397 bufend = PL_parser->bufend;
1400 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1401 if (retlen == (STRLEN)-1) {
1402 /* malformed UTF-8 */
1404 SAVESPTR(PL_warnhook);
1405 PL_warnhook = PERL_WARNHOOK_FATAL;
1406 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1412 if (!lex_next_chunk(flags))
1414 s = PL_parser->bufptr;
1421 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1423 Reads the next (Unicode) character in the text currently being lexed.
1424 Returns the codepoint (unsigned integer value) of the character read,
1425 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1426 if lexing has reached the end of the input text. To non-destructively
1427 examine the next character, use L</lex_peek_unichar> instead.
1429 If the next character is in (or extends into) the next chunk of input
1430 text, the next chunk will be read in. Normally the current chunk will be
1431 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1432 then the current chunk will not be discarded.
1434 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1435 is encountered, an exception is generated.
1441 Perl_lex_read_unichar(pTHX_ U32 flags)
1444 if (flags & ~(LEX_KEEP_PREVIOUS))
1445 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1446 c = lex_peek_unichar(flags);
1449 COPLINE_INC_WITH_HERELINES;
1451 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1453 ++(PL_parser->bufptr);
1459 =for apidoc Amx|void|lex_read_space|U32 flags
1461 Reads optional spaces, in Perl style, in the text currently being
1462 lexed. The spaces may include ordinary whitespace characters and
1463 Perl-style comments. C<#line> directives are processed if encountered.
1464 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1465 at a non-space character (or the end of the input text).
1467 If spaces extend into the next chunk of input text, the next chunk will
1468 be read in. Normally the current chunk will be discarded at the same
1469 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1470 chunk will not be discarded.
1475 #define LEX_NO_INCLINE 0x40000000
1476 #define LEX_NO_NEXT_CHUNK 0x80000000
1479 Perl_lex_read_space(pTHX_ U32 flags)
1482 const bool can_incline = !(flags & LEX_NO_INCLINE);
1483 bool need_incline = 0;
1484 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1485 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1486 s = PL_parser->bufptr;
1487 bufend = PL_parser->bufend;
1493 } while (!(c == '\n' || (c == 0 && s == bufend)));
1494 } else if (c == '\n') {
1497 PL_parser->linestart = s;
1503 } else if (isSPACE(c)) {
1505 } else if (c == 0 && s == bufend) {
1508 if (flags & LEX_NO_NEXT_CHUNK)
1510 PL_parser->bufptr = s;
1511 l = CopLINE(PL_curcop);
1512 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1513 got_more = lex_next_chunk(flags);
1514 CopLINE_set(PL_curcop, l);
1515 s = PL_parser->bufptr;
1516 bufend = PL_parser->bufend;
1519 if (can_incline && need_incline && PL_parser->rsfp) {
1529 PL_parser->bufptr = s;
1534 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1536 This function performs syntax checking on a prototype, C<proto>.
1537 If C<warn> is true, any illegal characters or mismatched brackets
1538 will trigger illegalproto warnings, declaring that they were
1539 detected in the prototype for C<name>.
1541 The return value is C<true> if this is a valid prototype, and
1542 C<false> if it is not, regardless of whether C<warn> was C<true> or
1545 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1552 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1554 STRLEN len, origlen;
1555 char *p = proto ? SvPV(proto, len) : NULL;
1556 bool bad_proto = FALSE;
1557 bool in_brackets = FALSE;
1558 bool after_slash = FALSE;
1559 char greedy_proto = ' ';
1560 bool proto_after_greedy_proto = FALSE;
1561 bool must_be_last = FALSE;
1562 bool underscore = FALSE;
1563 bool bad_proto_after_underscore = FALSE;
1565 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1571 for (; len--; p++) {
1574 proto_after_greedy_proto = TRUE;
1576 if (!strchr(";@%", *p))
1577 bad_proto_after_underscore = TRUE;
1580 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1587 in_brackets = FALSE;
1588 else if ((*p == '@' || *p == '%') &&
1591 must_be_last = TRUE;
1600 after_slash = FALSE;
1605 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1608 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1609 origlen, UNI_DISPLAY_ISPRINT)
1610 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1612 if (proto_after_greedy_proto)
1613 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1614 "Prototype after '%c' for %"SVf" : %s",
1615 greedy_proto, SVfARG(name), p);
1617 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1618 "Missing ']' in prototype for %"SVf" : %s",
1621 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1622 "Illegal character in prototype for %"SVf" : %s",
1624 if (bad_proto_after_underscore)
1625 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1626 "Illegal character after '_' in prototype for %"SVf" : %s",
1630 return (! (proto_after_greedy_proto || bad_proto) );
1635 * This subroutine has nothing to do with tilting, whether at windmills
1636 * or pinball tables. Its name is short for "increment line". It
1637 * increments the current line number in CopLINE(PL_curcop) and checks
1638 * to see whether the line starts with a comment of the form
1639 * # line 500 "foo.pm"
1640 * If so, it sets the current line number and file to the values in the comment.
1644 S_incline(pTHX_ const char *s)
1651 PERL_ARGS_ASSERT_INCLINE;
1653 COPLINE_INC_WITH_HERELINES;
1654 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1655 && s+1 == PL_bufend && *s == ';') {
1656 /* fake newline in string eval */
1657 CopLINE_dec(PL_curcop);
1662 while (SPACE_OR_TAB(*s))
1664 if (strnEQ(s, "line", 4))
1668 if (SPACE_OR_TAB(*s))
1672 while (SPACE_OR_TAB(*s))
1680 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1682 while (SPACE_OR_TAB(*s))
1684 if (*s == '"' && (t = strchr(s+1, '"'))) {
1690 while (!isSPACE(*t))
1694 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1696 if (*e != '\n' && *e != '\0')
1697 return; /* false alarm */
1699 line_num = grok_atou(n, &e) - 1;
1702 const STRLEN len = t - s;
1704 if (!PL_rsfp && !PL_parser->filtered) {
1705 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1706 * to *{"::_<newfilename"} */
1707 /* However, the long form of evals is only turned on by the
1708 debugger - usually they're "(eval %lu)" */
1709 GV * const cfgv = CopFILEGV(PL_curcop);
1712 STRLEN tmplen2 = len;
1716 if (tmplen2 + 2 <= sizeof smallbuf)
1719 Newx(tmpbuf2, tmplen2 + 2, char);
1724 memcpy(tmpbuf2 + 2, s, tmplen2);
1727 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1729 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1730 /* adjust ${"::_<newfilename"} to store the new file name */
1731 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1732 /* The line number may differ. If that is the case,
1733 alias the saved lines that are in the array.
1734 Otherwise alias the whole array. */
1735 if (CopLINE(PL_curcop) == line_num) {
1736 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1737 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1739 else if (GvAV(cfgv)) {
1740 AV * const av = GvAV(cfgv);
1741 const I32 start = CopLINE(PL_curcop)+1;
1742 I32 items = AvFILLp(av) - start;
1744 AV * const av2 = GvAVn(gv2);
1745 SV **svp = AvARRAY(av) + start;
1746 I32 l = (I32)line_num+1;
1748 av_store(av2, l++, SvREFCNT_inc(*svp++));
1753 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1756 CopFILE_free(PL_curcop);
1757 CopFILE_setn(PL_curcop, s, len);
1759 CopLINE_set(PL_curcop, line_num);
1762 #define skipspace(s) skipspace_flags(s, 0)
1766 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1768 AV *av = CopFILEAVx(PL_curcop);
1771 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1773 sv = *av_fetch(av, 0, 1);
1774 SvUPGRADE(sv, SVt_PVMG);
1776 if (!SvPOK(sv)) sv_setpvs(sv,"");
1778 sv_catsv(sv, orig_sv);
1780 sv_catpvn(sv, buf, len);
1785 if (PL_parser->preambling == NOLINE)
1786 av_store(av, CopLINE(PL_curcop), sv);
1792 * Called to gobble the appropriate amount and type of whitespace.
1793 * Skips comments as well.
1797 S_skipspace_flags(pTHX_ char *s, U32 flags)
1799 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1800 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1801 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1804 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1806 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1807 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1808 LEX_NO_NEXT_CHUNK : 0));
1810 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1811 if (PL_linestart > PL_bufptr)
1812 PL_bufptr = PL_linestart;
1820 * Check the unary operators to ensure there's no ambiguity in how they're
1821 * used. An ambiguous piece of code would be:
1823 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1824 * the +5 is its argument.
1833 if (PL_oldoldbufptr != PL_last_uni)
1835 while (isSPACE(*PL_last_uni))
1838 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1840 if ((t = strchr(s, '(')) && t < PL_bufptr)
1843 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1844 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1845 (int)(s - PL_last_uni), PL_last_uni);
1849 * LOP : macro to build a list operator. Its behaviour has been replaced
1850 * with a subroutine, S_lop() for which LOP is just another name.
1853 #define LOP(f,x) return lop(f,x,s)
1857 * Build a list operator (or something that might be one). The rules:
1858 * - if we have a next token, then it's a list operator (no parens) for
1859 * which the next token has already been parsed; e.g.,
1862 * - if the next thing is an opening paren, then it's a function
1863 * - else it's a list operator
1867 S_lop(pTHX_ I32 f, int x, char *s)
1869 PERL_ARGS_ASSERT_LOP;
1874 PL_last_lop = PL_oldbufptr;
1875 PL_last_lop_op = (OPCODE)f;
1880 return REPORT(FUNC);
1883 return REPORT(FUNC);
1886 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1887 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1888 return REPORT(LSTOP);
1894 * When the lexer realizes it knows the next token (for instance,
1895 * it is reordering tokens for the parser) then it can call S_force_next
1896 * to know what token to return the next time the lexer is called. Caller
1897 * will need to set PL_nextval[] and possibly PL_expect to ensure
1898 * the lexer handles the token correctly.
1902 S_force_next(pTHX_ I32 type)
1906 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1907 tokereport(type, &NEXTVAL_NEXTTOKE);
1910 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1911 PL_nexttype[PL_nexttoke] = type;
1913 if (PL_lex_state != LEX_KNOWNEXT) {
1914 PL_lex_defer = PL_lex_state;
1915 PL_lex_state = LEX_KNOWNEXT;
1922 * This subroutine handles postfix deref syntax after the arrow has already
1923 * been emitted. @* $* etc. are emitted as two separate token right here.
1924 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1925 * only the first, leaving yylex to find the next.
1929 S_postderef(pTHX_ int const funny, char const next)
1931 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1932 assert(strchr("*[{", next));
1934 PL_expect = XOPERATOR;
1935 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1936 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1937 PL_lex_state = LEX_INTERPEND;
1938 force_next(POSTJOIN);
1944 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1945 && !PL_lex_brackets)
1947 PL_expect = XOPERATOR;
1956 int yyc = PL_parser->yychar;
1957 if (yyc != YYEMPTY) {
1959 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1960 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1961 PL_lex_allbrackets--;
1963 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1964 } else if (yyc == '('/*)*/) {
1965 PL_lex_allbrackets--;
1970 PL_parser->yychar = YYEMPTY;
1975 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1977 SV * const sv = newSVpvn_utf8(start, len,
1980 && !is_invariant_string((const U8*)start, len)
1981 && is_utf8_string((const U8*)start, len));
1987 * When the lexer knows the next thing is a word (for instance, it has
1988 * just seen -> and it knows that the next char is a word char, then
1989 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1993 * char *start : buffer position (must be within PL_linestr)
1994 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1995 * int check_keyword : if true, Perl checks to make sure the word isn't
1996 * a keyword (do this if the word is a label, e.g. goto FOO)
1997 * int allow_pack : if true, : characters will also be allowed (require,
1998 * use, etc. do this)
2002 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2007 PERL_ARGS_ASSERT_FORCE_WORD;
2009 start = skipspace(start);
2011 if (isIDFIRST_lazy_if(s,UTF) ||
2012 (allow_pack && *s == ':') )
2014 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2015 if (check_keyword) {
2016 char *s2 = PL_tokenbuf;
2018 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2020 if (keyword(s2, len2, 0))
2023 if (token == METHOD) {
2028 PL_expect = XOPERATOR;
2031 NEXTVAL_NEXTTOKE.opval
2032 = (OP*)newSVOP(OP_CONST,0,
2033 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2034 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2042 * Called when the lexer wants $foo *foo &foo etc, but the program
2043 * text only contains the "foo" portion. The first argument is a pointer
2044 * to the "foo", and the second argument is the type symbol to prefix.
2045 * Forces the next token to be a "WORD".
2046 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2050 S_force_ident(pTHX_ const char *s, int kind)
2052 PERL_ARGS_ASSERT_FORCE_IDENT;
2055 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2056 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2057 UTF ? SVf_UTF8 : 0));
2058 NEXTVAL_NEXTTOKE.opval = o;
2061 o->op_private = OPpCONST_ENTERED;
2062 /* XXX see note in pp_entereval() for why we forgo typo
2063 warnings if the symbol must be introduced in an eval.
2065 gv_fetchpvn_flags(s, len,
2066 (PL_in_eval ? GV_ADDMULTI
2067 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2068 kind == '$' ? SVt_PV :
2069 kind == '@' ? SVt_PVAV :
2070 kind == '%' ? SVt_PVHV :
2078 S_force_ident_maybe_lex(pTHX_ char pit)
2080 NEXTVAL_NEXTTOKE.ival = pit;
2085 Perl_str_to_version(pTHX_ SV *sv)
2090 const char *start = SvPV_const(sv,len);
2091 const char * const end = start + len;
2092 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2094 PERL_ARGS_ASSERT_STR_TO_VERSION;
2096 while (start < end) {
2100 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2105 retval += ((NV)n)/nshift;
2114 * Forces the next token to be a version number.
2115 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2116 * and if "guessing" is TRUE, then no new token is created (and the caller
2117 * must use an alternative parsing method).
2121 S_force_version(pTHX_ char *s, int guessing)
2126 PERL_ARGS_ASSERT_FORCE_VERSION;
2134 while (isDIGIT(*d) || *d == '_' || *d == '.')
2136 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2138 s = scan_num(s, &pl_yylval);
2139 version = pl_yylval.opval;
2140 ver = cSVOPx(version)->op_sv;
2141 if (SvPOK(ver) && !SvNIOK(ver)) {
2142 SvUPGRADE(ver, SVt_PVNV);
2143 SvNV_set(ver, str_to_version(ver));
2144 SvNOK_on(ver); /* hint that it is a version */
2147 else if (guessing) {
2152 /* NOTE: The parser sees the package name and the VERSION swapped */
2153 NEXTVAL_NEXTTOKE.opval = version;
2160 * S_force_strict_version
2161 * Forces the next token to be a version number using strict syntax rules.
2165 S_force_strict_version(pTHX_ char *s)
2168 const char *errstr = NULL;
2170 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2172 while (isSPACE(*s)) /* leading whitespace */
2175 if (is_STRICT_VERSION(s,&errstr)) {
2177 s = (char *)scan_version(s, ver, 0);
2178 version = newSVOP(OP_CONST, 0, ver);
2180 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2181 (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2185 yyerror(errstr); /* version required */
2189 /* NOTE: The parser sees the package name and the VERSION swapped */
2190 NEXTVAL_NEXTTOKE.opval = version;
2198 * Tokenize a quoted string passed in as an SV. It finds the next
2199 * chunk, up to end of string or a backslash. It may make a new
2200 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2205 S_tokeq(pTHX_ SV *sv)
2212 PERL_ARGS_ASSERT_TOKEQ;
2216 assert (!SvIsCOW(sv));
2217 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2221 /* This is relying on the SV being "well formed" with a trailing '\0' */
2222 while (s < send && !(*s == '\\' && s[1] == '\\'))
2227 if ( PL_hints & HINT_NEW_STRING ) {
2228 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2229 SVs_TEMP | SvUTF8(sv));
2233 if (s + 1 < send && (s[1] == '\\'))
2234 s++; /* all that, just for this */
2239 SvCUR_set(sv, d - SvPVX_const(sv));
2241 if ( PL_hints & HINT_NEW_STRING )
2242 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2247 * Now come three functions related to double-quote context,
2248 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2249 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2250 * interact with PL_lex_state, and create fake ( ... ) argument lists
2251 * to handle functions and concatenation.
2255 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2260 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2262 * Pattern matching will set PL_lex_op to the pattern-matching op to
2263 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2265 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2267 * Everything else becomes a FUNC.
2269 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2270 * had an OP_CONST or OP_READLINE). This just sets us up for a
2271 * call to S_sublex_push().
2275 S_sublex_start(pTHX)
2277 const I32 op_type = pl_yylval.ival;
2279 if (op_type == OP_NULL) {
2280 pl_yylval.opval = PL_lex_op;
2284 if (op_type == OP_CONST) {
2285 SV *sv = PL_lex_stuff;
2286 PL_lex_stuff = NULL;
2289 if (SvTYPE(sv) == SVt_PVIV) {
2290 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2292 const char * const p = SvPV_const(sv, len);
2293 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2297 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2301 PL_sublex_info.super_state = PL_lex_state;
2302 PL_sublex_info.sub_inwhat = (U16)op_type;
2303 PL_sublex_info.sub_op = PL_lex_op;
2304 PL_lex_state = LEX_INTERPPUSH;
2308 pl_yylval.opval = PL_lex_op;
2318 * Create a new scope to save the lexing state. The scope will be
2319 * ended in S_sublex_done. Returns a '(', starting the function arguments
2320 * to the uc, lc, etc. found before.
2321 * Sets PL_lex_state to LEX_INTERPCONCAT.
2328 const bool is_heredoc = PL_multi_close == '<';
2331 PL_lex_state = PL_sublex_info.super_state;
2332 SAVEI8(PL_lex_dojoin);
2333 SAVEI32(PL_lex_brackets);
2334 SAVEI32(PL_lex_allbrackets);
2335 SAVEI32(PL_lex_formbrack);
2336 SAVEI8(PL_lex_fakeeof);
2337 SAVEI32(PL_lex_casemods);
2338 SAVEI32(PL_lex_starts);
2339 SAVEI8(PL_lex_state);
2340 SAVESPTR(PL_lex_repl);
2341 SAVEVPTR(PL_lex_inpat);
2342 SAVEI16(PL_lex_inwhat);
2345 SAVECOPLINE(PL_curcop);
2346 SAVEI32(PL_multi_end);
2347 SAVEI32(PL_parser->herelines);
2348 PL_parser->herelines = 0;
2350 SAVEI8(PL_multi_close);
2351 SAVEPPTR(PL_bufptr);
2352 SAVEPPTR(PL_bufend);
2353 SAVEPPTR(PL_oldbufptr);
2354 SAVEPPTR(PL_oldoldbufptr);
2355 SAVEPPTR(PL_last_lop);
2356 SAVEPPTR(PL_last_uni);
2357 SAVEPPTR(PL_linestart);
2358 SAVESPTR(PL_linestr);
2359 SAVEGENERICPV(PL_lex_brackstack);
2360 SAVEGENERICPV(PL_lex_casestack);
2361 SAVEGENERICPV(PL_parser->lex_shared);
2362 SAVEBOOL(PL_parser->lex_re_reparsing);
2363 SAVEI32(PL_copline);
2365 /* The here-doc parser needs to be able to peek into outer lexing
2366 scopes to find the body of the here-doc. So we put PL_linestr and
2367 PL_bufptr into lex_shared, to ‘share’ those values.
2369 PL_parser->lex_shared->ls_linestr = PL_linestr;
2370 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2372 PL_linestr = PL_lex_stuff;
2373 PL_lex_repl = PL_sublex_info.repl;
2374 PL_lex_stuff = NULL;
2375 PL_sublex_info.repl = NULL;
2377 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2378 set for an inner quote-like operator and then an error causes scope-
2379 popping. We must not have a PL_lex_stuff value left dangling, as
2380 that breaks assumptions elsewhere. See bug #123617. */
2381 SAVEGENERICSV(PL_lex_stuff);
2383 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2384 = SvPVX(PL_linestr);
2385 PL_bufend += SvCUR(PL_linestr);
2386 PL_last_lop = PL_last_uni = NULL;
2387 SAVEFREESV(PL_linestr);
2388 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2390 PL_lex_dojoin = FALSE;
2391 PL_lex_brackets = PL_lex_formbrack = 0;
2392 PL_lex_allbrackets = 0;
2393 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2394 Newx(PL_lex_brackstack, 120, char);
2395 Newx(PL_lex_casestack, 12, char);
2396 PL_lex_casemods = 0;
2397 *PL_lex_casestack = '\0';
2399 PL_lex_state = LEX_INTERPCONCAT;
2401 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2402 PL_copline = NOLINE;
2404 Newxz(shared, 1, LEXSHARED);
2405 shared->ls_prev = PL_parser->lex_shared;
2406 PL_parser->lex_shared = shared;
2408 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2409 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2410 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2411 PL_lex_inpat = PL_sublex_info.sub_op;
2413 PL_lex_inpat = NULL;
2415 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2416 PL_in_eval &= ~EVAL_RE_REPARSING;
2423 * Restores lexer state after a S_sublex_push.
2429 if (!PL_lex_starts++) {
2430 SV * const sv = newSVpvs("");
2431 if (SvUTF8(PL_linestr))
2433 PL_expect = XOPERATOR;
2434 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2438 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2439 PL_lex_state = LEX_INTERPCASEMOD;
2443 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2444 assert(PL_lex_inwhat != OP_TRANSR);
2446 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2447 PL_linestr = PL_lex_repl;
2449 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2450 PL_bufend += SvCUR(PL_linestr);
2451 PL_last_lop = PL_last_uni = NULL;
2452 PL_lex_dojoin = FALSE;
2453 PL_lex_brackets = 0;
2454 PL_lex_allbrackets = 0;
2455 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2456 PL_lex_casemods = 0;
2457 *PL_lex_casestack = '\0';
2459 if (SvEVALED(PL_lex_repl)) {
2460 PL_lex_state = LEX_INTERPNORMAL;
2462 /* we don't clear PL_lex_repl here, so that we can check later
2463 whether this is an evalled subst; that means we rely on the
2464 logic to ensure sublex_done() is called again only via the
2465 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2468 PL_lex_state = LEX_INTERPCONCAT;
2471 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2472 CopLINE(PL_curcop) +=
2473 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2474 + PL_parser->herelines;
2475 PL_parser->herelines = 0;
2480 const line_t l = CopLINE(PL_curcop);
2482 if (PL_multi_close == '<')
2483 PL_parser->herelines += l - PL_multi_end;
2484 PL_bufend = SvPVX(PL_linestr);
2485 PL_bufend += SvCUR(PL_linestr);
2486 PL_expect = XOPERATOR;
2487 PL_sublex_info.sub_inwhat = 0;
2492 PERL_STATIC_INLINE SV*
2493 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2495 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2496 * interior, hence to the "}". Finds what the name resolves to, returning
2497 * an SV* containing it; NULL if no valid one found */
2499 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2506 const U8* first_bad_char_loc;
2507 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2509 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2514 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2516 &first_bad_char_loc))
2518 /* If warnings are on, this will print a more detailed analysis of what
2519 * is wrong than the error message below */
2520 utf8n_to_uvchr(first_bad_char_loc,
2521 e - ((char *) first_bad_char_loc),
2524 /* We deliberately don't try to print the malformed character, which
2525 * might not print very well; it also may be just the first of many
2526 * malformations, so don't print what comes after it */
2527 yyerror(Perl_form(aTHX_
2528 "Malformed UTF-8 character immediately after '%.*s'",
2529 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2533 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2534 /* include the <}> */
2535 e - backslash_ptr + 1);
2537 SvREFCNT_dec_NN(res);
2541 /* See if the charnames handler is the Perl core's, and if so, we can skip
2542 * the validation needed for a user-supplied one, as Perl's does its own
2544 table = GvHV(PL_hintgv); /* ^H */
2545 cvp = hv_fetchs(table, "charnames", FALSE);
2546 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2547 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2549 const char * const name = HvNAME(stash);
2550 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2551 && strEQ(name, "_charnames")) {
2556 /* Here, it isn't Perl's charname handler. We can't rely on a
2557 * user-supplied handler to validate the input name. For non-ut8 input,
2558 * look to see that the first character is legal. Then loop through the
2559 * rest checking that each is a continuation */
2561 /* This code makes the reasonable assumption that the only Latin1-range
2562 * characters that begin a character name alias are alphabetic, otherwise
2563 * would have to create a isCHARNAME_BEGIN macro */
2566 if (! isALPHAU(*s)) {
2571 if (! isCHARNAME_CONT(*s)) {
2574 if (*s == ' ' && *(s-1) == ' ') {
2577 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2578 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2579 "NO-BREAK SPACE in a charnames "
2580 "alias definition is deprecated");
2586 /* Similarly for utf8. For invariants can check directly; for other
2587 * Latin1, can calculate their code point and check; otherwise use a
2589 if (UTF8_IS_INVARIANT(*s)) {
2590 if (! isALPHAU(*s)) {
2594 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2595 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2601 if (! PL_utf8_charname_begin) {
2602 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2603 PL_utf8_charname_begin = _core_swash_init("utf8",
2604 "_Perl_Charname_Begin",
2606 1, 0, NULL, &flags);
2608 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2615 if (UTF8_IS_INVARIANT(*s)) {
2616 if (! isCHARNAME_CONT(*s)) {
2619 if (*s == ' ' && *(s-1) == ' ') {
2624 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2625 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2629 if (*s == *NBSP_UTF8
2630 && *(s+1) == *(NBSP_UTF8+1)
2631 && ckWARN_d(WARN_DEPRECATED))
2633 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2634 "NO-BREAK SPACE in a charnames "
2635 "alias definition is deprecated");
2640 if (! PL_utf8_charname_continue) {
2641 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2642 PL_utf8_charname_continue = _core_swash_init("utf8",
2643 "_Perl_Charname_Continue",
2645 1, 0, NULL, &flags);
2647 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2654 if (*(s-1) == ' ') {
2657 "charnames alias definitions may not contain trailing "
2658 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2659 (int)(s - backslash_ptr + 1), backslash_ptr,
2660 (int)(e - s + 1), s + 1
2662 UTF ? SVf_UTF8 : 0);
2666 if (SvUTF8(res)) { /* Don't accept malformed input */
2667 const U8* first_bad_char_loc;
2669 const char* const str = SvPV_const(res, len);
2670 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2671 /* If warnings are on, this will print a more detailed analysis of
2672 * what is wrong than the error message below */
2673 utf8n_to_uvchr(first_bad_char_loc,
2674 (char *) first_bad_char_loc - str,
2677 /* We deliberately don't try to print the malformed character,
2678 * which might not print very well; it also may be just the first
2679 * of many malformations, so don't print what comes after it */
2682 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2683 (int) (e - backslash_ptr + 1), backslash_ptr,
2684 (int) ((char *) first_bad_char_loc - str), str
2695 /* The final %.*s makes sure that should the trailing NUL be missing
2696 * that this print won't run off the end of the string */
2699 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2700 (int)(s - backslash_ptr + 1), backslash_ptr,
2701 (int)(e - s + 1), s + 1
2703 UTF ? SVf_UTF8 : 0);
2710 "charnames alias definitions may not contain a sequence of "
2711 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2712 (int)(s - backslash_ptr + 1), backslash_ptr,
2713 (int)(e - s + 1), s + 1
2715 UTF ? SVf_UTF8 : 0);
2722 Extracts the next constant part of a pattern, double-quoted string,
2723 or transliteration. This is terrifying code.
2725 For example, in parsing the double-quoted string "ab\x63$d", it would
2726 stop at the '$' and return an OP_CONST containing 'abc'.
2728 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2729 processing a pattern (PL_lex_inpat is true), a transliteration
2730 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2732 Returns a pointer to the character scanned up to. If this is
2733 advanced from the start pointer supplied (i.e. if anything was
2734 successfully parsed), will leave an OP_CONST for the substring scanned
2735 in pl_yylval. Caller must intuit reason for not parsing further
2736 by looking at the next characters herself.
2740 \N{FOO} => \N{U+hex_for_character_FOO}
2741 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2744 all other \-char, including \N and \N{ apart from \N{ABC}
2747 @ 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 */
2827 /* Note on sizing: The scanned constant is placed into sv, which is
2828 * initialized by newSV() assuming one byte of output for every byte of
2829 * input. This routine expects newSV() to allocate an extra byte for a
2830 * trailing NUL, which this routine will append if it gets to the end of
2831 * the input. There may be more bytes of input than output (eg., \N{LATIN
2832 * CAPITAL LETTER A}), or more output than input if the constant ends up
2833 * recoded to utf8, but each time a construct is found that might increase
2834 * the needed size, SvGROW() is called. Its size parameter each time is
2835 * based on the best guess estimate at the time, namely the length used so
2836 * far, plus the length the current construct will occupy, plus room for
2837 * the trailing NUL, plus one byte for every input byte still unscanned */
2839 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2842 UV literal_endpoint = 0;
2843 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2846 PERL_ARGS_ASSERT_SCAN_CONST;
2848 assert(PL_lex_inwhat != OP_TRANSR);
2849 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2850 /* If we are doing a trans and we know we want UTF8 set expectation */
2851 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2852 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2855 /* Protect sv from errors and fatal warnings. */
2856 ENTER_with_name("scan_const");
2859 while (s < send || dorange) {
2861 /* get transliterations out of the way (they're most literal) */
2862 if (PL_lex_inwhat == OP_TRANS) {
2863 /* expand a range A-Z to the full set of characters. AIE! */
2865 I32 i; /* current expanded character */
2866 I32 min; /* first character in range */
2867 I32 max; /* last character in range */
2878 char * const c = (char*)utf8_hop((U8*)d, -1);
2882 *c = (char) ILLEGAL_UTF8_BYTE;
2883 /* mark the range as done, and continue */
2889 i = d - SvPVX_const(sv); /* remember current offset */
2892 SvLEN(sv) + ((has_utf8)
2893 ? (512 - UTF_CONTINUATION_MARK
2896 /* How many two-byte within 0..255: 128 in UTF-8,
2897 * 96 in UTF-8-mod. */
2899 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2901 d = SvPVX(sv) + i; /* refresh d after realloc */
2905 for (j = 0; j <= 1; j++) {
2906 char * const c = (char*)utf8_hop((U8*)d, -1);
2907 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2913 max = (U8)0xff; /* only to \xff */
2914 uvmax = uv; /* \x{100} to uvmax */
2916 d = c; /* eat endpoint chars */
2921 d -= 2; /* eat the first char and the - */
2922 min = (U8)*d; /* first char in range */
2923 max = (U8)d[1]; /* last char in range */
2930 "Invalid range \"%c-%c\" in transliteration operator",
2931 (char)min, (char)max);
2935 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2936 * any subsets of these ranges into individual characters */
2937 if (literal_endpoint == 2 &&
2938 ((isLOWER_A(min) && isLOWER_A(max)) ||
2939 (isUPPER_A(min) && isUPPER_A(max))))
2941 for (i = min; i <= max; i++) {
2948 for (i = min; i <= max; i++)
2951 append_utf8_from_native_byte(i, &d);
2959 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2961 *d++ = (char) ILLEGAL_UTF8_BYTE;
2963 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2967 /* mark the range as done, and continue */
2971 literal_endpoint = 0;
2976 /* range begins (ignore - as first or last char) */
2977 else if (*s == '-' && s+1 < send && s != start) {
2979 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2986 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2996 literal_endpoint = 0;
2997 native_range = TRUE;
3002 /* if we get here, we're not doing a transliteration */
3004 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3007 while (s1 >= start && *s1-- == '\\')
3010 in_charclass = TRUE;
3013 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3016 while (s1 >= start && *s1-- == '\\')
3019 in_charclass = FALSE;
3022 /* skip for regexp comments /(?#comment)/, except for the last
3023 * char, which will be done separately.
3024 * Stop on (?{..}) and friends */
3026 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3028 while (s+1 < send && *s != ')')
3031 else if (!PL_lex_casemods &&
3032 ( s[2] == '{' /* This should match regcomp.c */
3033 || (s[2] == '?' && s[3] == '{')))
3039 /* likewise skip #-initiated comments in //x patterns */
3040 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3041 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3042 while (s+1 < send && *s != '\n')
3046 /* no further processing of single-quoted regex */
3047 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3048 goto default_action;
3050 /* check for embedded arrays
3051 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3053 else if (*s == '@' && s[1]) {
3054 if (isWORDCHAR_lazy_if(s+1,UTF))
3056 if (strchr(":'{$", s[1]))
3058 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3059 break; /* in regexp, neither @+ nor @- are interpolated */
3062 /* check for embedded scalars. only stop if we're sure it's a
3065 else if (*s == '$') {
3066 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3068 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3070 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3071 "Possible unintended interpolation of $\\ in regex");
3073 break; /* in regexp, $ might be tail anchor */
3077 /* End of else if chain - OP_TRANS rejoin rest */
3080 if (*s == '\\' && s+1 < send) {
3081 char* e; /* Can be used for ending '}', etc. */
3085 /* warn on \1 - \9 in substitution replacements, but note that \11
3086 * is an octal; and \19 is \1 followed by '9' */
3087 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3088 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3090 /* diag_listed_as: \%d better written as $%d */
3091 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3096 /* string-change backslash escapes */
3097 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3101 /* In a pattern, process \N, but skip any other backslash escapes.
3102 * This is because we don't want to translate an escape sequence
3103 * into a meta symbol and have the regex compiler use the meta
3104 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3105 * in spite of this, we do have to process \N here while the proper
3106 * charnames handler is in scope. See bugs #56444 and #62056.
3108 * There is a complication because \N in a pattern may also stand
3109 * for 'match a non-nl', and not mean a charname, in which case its
3110 * processing should be deferred to the regex compiler. To be a
3111 * charname it must be followed immediately by a '{', and not look
3112 * like \N followed by a curly quantifier, i.e., not something like
3113 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3115 else if (PL_lex_inpat
3118 || regcurly(s + 1)))
3121 goto default_action;
3126 /* quoted - in transliterations */
3128 if (PL_lex_inwhat == OP_TRANS) {
3135 if ((isALPHANUMERIC(*s)))
3136 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3137 "Unrecognized escape \\%c passed through",
3139 /* default action is to copy the quoted character */
3140 goto default_action;
3143 /* eg. \132 indicates the octal constant 0132 */
3144 case '0': case '1': case '2': case '3':
3145 case '4': case '5': case '6': case '7':
3147 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3149 uv = grok_oct(s, &len, &flags, NULL);
3151 if (len < 3 && s < send && isDIGIT(*s)
3152 && ckWARN(WARN_MISC))
3154 Perl_warner(aTHX_ packWARN(WARN_MISC),
3155 "%s", form_short_octal_warning(s, len));
3158 goto NUM_ESCAPE_INSERT;
3160 /* eg. \o{24} indicates the octal constant \024 */
3165 bool valid = grok_bslash_o(&s, &uv, &error,
3166 TRUE, /* Output warning */
3167 FALSE, /* Not strict */
3168 TRUE, /* Output warnings for
3175 goto NUM_ESCAPE_INSERT;
3178 /* eg. \x24 indicates the hex constant 0x24 */
3183 bool valid = grok_bslash_x(&s, &uv, &error,
3184 TRUE, /* Output warning */
3185 FALSE, /* Not strict */
3186 TRUE, /* Output warnings for
3196 /* Insert oct or hex escaped character. There will always be
3197 * enough room in sv since such escapes will be longer than any
3198 * UTF-8 sequence they can end up as, except if they force us
3199 * to recode the rest of the string into utf8 */
3201 /* Here uv is the ordinal of the next character being added */
3202 if (!UVCHR_IS_INVARIANT(uv)) {
3203 if (!has_utf8 && uv > 255) {
3204 /* Might need to recode whatever we have accumulated so
3205 * far if it contains any chars variant in utf8 or
3208 SvCUR_set(sv, d - SvPVX_const(sv));
3211 /* See Note on sizing above. */
3212 sv_utf8_upgrade_flags_grow(
3214 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3215 /* Above-latin1 in string
3216 * implies no encoding */
3217 |SV_UTF8_NO_ENCODING,
3218 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3219 d = SvPVX(sv) + SvCUR(sv);
3224 d = (char*)uvchr_to_utf8((U8*)d, uv);
3225 if (PL_lex_inwhat == OP_TRANS &&
3226 PL_sublex_info.sub_op) {
3227 PL_sublex_info.sub_op->op_private |=
3228 (PL_lex_repl ? OPpTRANS_FROM_UTF
3232 if (uv > 255 && !dorange)
3233 native_range = FALSE;
3246 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3247 * named character, like \N{LATIN SMALL LETTER A}, or a named
3248 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3249 * GRAVE}. For convenience all three forms are referred to as
3250 * "named characters" below.
3252 * For patterns, \N also can mean to match a non-newline. Code
3253 * before this 'switch' statement should already have handled
3254 * this situation, and hence this code only has to deal with
3255 * the named character cases.
3257 * For non-patterns, the named characters are converted to
3258 * their string equivalents. In patterns, named characters are
3259 * not converted to their ultimate forms for the same reasons
3260 * that other escapes aren't. Instead, they are converted to
3261 * the \N{U+...} form to get the value from the charnames that
3262 * is in effect right now, while preserving the fact that it
3263 * was a named character, so that the regex compiler knows
3266 * The structure of this section of code (besides checking for
3267 * errors and upgrading to utf8) is:
3268 * If the named character is of the form \N{U+...}, pass it
3269 * through if a pattern; otherwise convert the code point
3271 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3272 * if a pattern; otherwise convert to utf8
3274 * If the regex compiler should ever need to differentiate
3275 * between the \N{U+...} and \N{name} forms, that could easily
3276 * be done here by stripping any leading zeros from the
3277 * \N{U+...} case, and adding them to the other one. */
3279 /* Here, 's' points to the 'N'; the test below is guaranteed to
3280 * succeed if we are being called on a pattern, as we already
3281 * know from a test above that the next character is a '{'. A
3282 * non-pattern \N must mean 'named character', which requires
3286 yyerror("Missing braces on \\N{}");
3291 /* If there is no matching '}', it is an error. */
3292 if (! (e = strchr(s, '}'))) {
3293 if (! PL_lex_inpat) {
3294 yyerror("Missing right brace on \\N{}");
3296 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3301 /* Here it looks like a named character */
3303 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3304 s += 2; /* Skip to next char after the 'U+' */
3307 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3308 /* Check the syntax. */
3311 if (!isXDIGIT(*s)) {
3314 "Invalid hexadecimal number in \\N{U+...}"
3322 else if ((*s == '.' || *s == '_')
3328 /* Pass everything through unchanged.
3329 * +1 is for the '}' */
3330 Copy(orig_s, d, e - orig_s + 1, char);
3331 d += e - orig_s + 1;
3333 else { /* Not a pattern: convert the hex to string */
3334 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3335 | PERL_SCAN_SILENT_ILLDIGIT
3336 | PERL_SCAN_DISALLOW_PREFIX;
3338 uv = grok_hex(s, &len, &flags, NULL);
3339 if (len == 0 || (len != (STRLEN)(e - s)))
3342 /* If the destination is not in utf8, unconditionally
3343 * recode it to be so. This is because \N{} implies
3344 * Unicode semantics, and scalars have to be in utf8
3345 * to guarantee those semantics */
3347 SvCUR_set(sv, d - SvPVX_const(sv));
3350 /* See Note on sizing above. */
3351 sv_utf8_upgrade_flags_grow(
3353 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3354 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3355 d = SvPVX(sv) + SvCUR(sv);
3359 /* Add the (Unicode) code point to the output. */
3360 if (UNI_IS_INVARIANT(uv)) {
3361 *d++ = (char) LATIN1_TO_NATIVE(uv);
3364 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3368 else /* Here is \N{NAME} but not \N{U+...}. */
3369 if ((res = get_and_check_backslash_N_name(s, e)))
3372 const char *str = SvPV_const(res, len);
3375 if (! len) { /* The name resolved to an empty string */
3376 Copy("\\N{}", d, 4, char);
3380 /* In order to not lose information for the regex
3381 * compiler, pass the result in the specially made
3382 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3383 * the code points in hex of each character
3384 * returned by charnames */
3386 const char *str_end = str + len;
3387 const STRLEN off = d - SvPVX_const(sv);
3389 if (! SvUTF8(res)) {
3390 /* For the non-UTF-8 case, we can determine the
3391 * exact length needed without having to parse
3392 * through the string. Each character takes up
3393 * 2 hex digits plus either a trailing dot or
3395 const char initial_text[] = "\\N{U+";
3396 const STRLEN initial_len = sizeof(initial_text)
3398 d = off + SvGROW(sv, off
3401 /* +1 for trailing NUL */
3404 + (STRLEN)(send - e));
3405 Copy(initial_text, d, initial_len, char);
3407 while (str < str_end) {
3410 my_snprintf(hex_string,
3412 "%02X.", (U8) *str);
3413 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3414 Copy(hex_string, d, 3, char);
3418 d--; /* Below, we will overwrite the final
3419 dot with a right brace */
3422 STRLEN char_length; /* cur char's byte length */
3424 /* and the number of bytes after this is
3425 * translated into hex digits */
3426 STRLEN output_length;
3428 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3429 * for max('U+', '.'); and 1 for NUL */
3430 char hex_string[2 * UTF8_MAXBYTES + 5];
3432 /* Get the first character of the result. */
3433 U32 uv = utf8n_to_uvchr((U8 *) str,
3437 /* Convert first code point to hex, including
3438 * the boiler plate before it. */
3440 my_snprintf(hex_string, sizeof(hex_string),
3444 /* Make sure there is enough space to hold it */
3445 d = off + SvGROW(sv, off
3447 + (STRLEN)(send - e)
3448 + 2); /* '}' + NUL */
3450 Copy(hex_string, d, output_length, char);
3453 /* For each subsequent character, append dot and
3454 * its ordinal in hex */
3455 while ((str += char_length) < str_end) {
3456 const STRLEN off = d - SvPVX_const(sv);
3457 U32 uv = utf8n_to_uvchr((U8 *) str,
3462 my_snprintf(hex_string,
3467 d = off + SvGROW(sv, off
3469 + (STRLEN)(send - e)
3470 + 2); /* '}' + NUL */
3471 Copy(hex_string, d, output_length, char);
3476 *d++ = '}'; /* Done. Add the trailing brace */
3479 else { /* Here, not in a pattern. Convert the name to a
3482 /* If destination is not in utf8, unconditionally
3483 * recode it to be so. This is because \N{} implies
3484 * Unicode semantics, and scalars have to be in utf8
3485 * to guarantee those semantics */
3487 SvCUR_set(sv, d - SvPVX_const(sv));
3490 /* See Note on sizing above. */
3491 sv_utf8_upgrade_flags_grow(sv,
3492 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3493 len + (STRLEN)(send - s) + 1);
3494 d = SvPVX(sv) + SvCUR(sv);
3496 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3498 /* See Note on sizing above. (NOTE: SvCUR() is not
3499 * set correctly here). */
3500 const STRLEN off = d - SvPVX_const(sv);
3501 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3503 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3504 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3505 str = SvPV_const(res, len);
3507 Copy(str, d, len, char);
3513 } /* End \N{NAME} */
3516 native_range = FALSE; /* \N{} is defined to be Unicode */
3518 s = e + 1; /* Point to just after the '}' */
3521 /* \c is a control character */
3525 *d++ = grok_bslash_c(*s++, 1);
3528 yyerror("Missing control char name in \\c");
3532 /* printf-style backslashes, formfeeds, newlines, etc */
3558 } /* end if (backslash) */
3565 /* If we started with encoded form, or already know we want it,
3566 then encode the next character */
3567 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3571 /* One might think that it is wasted effort in the case of the
3572 * source being utf8 (this_utf8 == TRUE) to take the next character
3573 * in the source, convert it to an unsigned value, and then convert
3574 * it back again. But the source has not been validated here. The
3575 * routine that does the conversion checks for errors like
3578 const UV nextuv = (this_utf8)
3579 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3581 const STRLEN need = UNISKIP(nextuv);
3583 SvCUR_set(sv, d - SvPVX_const(sv));
3586 /* See Note on sizing above. */
3587 sv_utf8_upgrade_flags_grow(sv,
3588 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3589 need + (STRLEN)(send - s) + 1);
3590 d = SvPVX(sv) + SvCUR(sv);
3592 } else if (need > len) {
3593 /* encoded value larger than old, may need extra space (NOTE:
3594 * SvCUR() is not set correctly here). See Note on sizing
3596 const STRLEN off = d - SvPVX_const(sv);
3597 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3601 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3603 if (uv > 255 && !dorange)
3604 native_range = FALSE;
3610 } /* while loop to process each character */
3612 /* terminate the string and set up the sv */
3614 SvCUR_set(sv, d - SvPVX_const(sv));
3615 if (SvCUR(sv) >= SvLEN(sv))
3616 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3617 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3620 if (IN_ENCODING && !has_utf8) {
3621 sv_recode_to_utf8(sv, _get_encoding());
3627 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3628 PL_sublex_info.sub_op->op_private |=
3629 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3633 /* shrink the sv if we allocated more than we used */
3634 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3635 SvPV_shrink_to_cur(sv);
3638 /* return the substring (via pl_yylval) only if we parsed anything */
3641 for (; s2 < s; s2++) {
3643 COPLINE_INC_WITH_HERELINES;
3645 SvREFCNT_inc_simple_void_NN(sv);
3646 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3647 && ! PL_parser->lex_re_reparsing)
3649 const char *const key = PL_lex_inpat ? "qr" : "q";
3650 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3654 if (PL_lex_inwhat == OP_TRANS) {
3657 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3660 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3668 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3671 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3673 LEAVE_with_name("scan_const");
3678 * Returns TRUE if there's more to the expression (e.g., a subscript),
3681 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3683 * ->[ and ->{ return TRUE
3684 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3685 * { and [ outside a pattern are always subscripts, so return TRUE
3686 * if we're outside a pattern and it's not { or [, then return FALSE
3687 * if we're in a pattern and the first char is a {
3688 * {4,5} (any digits around the comma) returns FALSE
3689 * if we're in a pattern and the first char is a [
3691 * [SOMETHING] has a funky algorithm to decide whether it's a
3692 * character class or not. It has to deal with things like
3693 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3694 * anything else returns TRUE
3697 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3700 S_intuit_more(pTHX_ char *s)
3702 PERL_ARGS_ASSERT_INTUIT_MORE;
3704 if (PL_lex_brackets)
3706 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3708 if (*s == '-' && s[1] == '>'
3709 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3710 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3711 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3713 if (*s != '{' && *s != '[')
3718 /* In a pattern, so maybe we have {n,m}. */
3726 /* On the other hand, maybe we have a character class */
3729 if (*s == ']' || *s == '^')
3732 /* this is terrifying, and it works */
3735 const char * const send = strchr(s,']');
3736 unsigned char un_char, last_un_char;
3737 char tmpbuf[sizeof PL_tokenbuf * 4];
3739 if (!send) /* has to be an expression */
3741 weight = 2; /* let's weigh the evidence */
3745 else if (isDIGIT(*s)) {
3747 if (isDIGIT(s[1]) && s[2] == ']')
3753 Zero(seen,256,char);
3755 for (; s < send; s++) {
3756 last_un_char = un_char;
3757 un_char = (unsigned char)*s;
3762 weight -= seen[un_char] * 10;
3763 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3765 char *tmp = PL_bufend;
3766 PL_bufend = (char*)send;
3767 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3769 len = (int)strlen(tmpbuf);
3770 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3771 UTF ? SVf_UTF8 : 0, SVt_PV))
3776 else if (*s == '$' && s[1] &&
3777 strchr("[#!%*<>()-=",s[1])) {
3778 if (/*{*/ strchr("])} =",s[2]))
3787 if (strchr("wds]",s[1]))
3789 else if (seen[(U8)'\''] || seen[(U8)'"'])
3791 else if (strchr("rnftbxcav",s[1]))
3793 else if (isDIGIT(s[1])) {
3795 while (s[1] && isDIGIT(s[1]))
3805 if (strchr("aA01! ",last_un_char))
3807 if (strchr("zZ79~",s[1]))
3809 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3810 weight -= 5; /* cope with negative subscript */
3813 if (!isWORDCHAR(last_un_char)
3814 && !(last_un_char == '$' || last_un_char == '@'
3815 || last_un_char == '&')
3816 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3820 if (keyword(d, s - d, 0))
3823 if (un_char == last_un_char + 1)
3825 weight -= seen[un_char];
3830 if (weight >= 0) /* probably a character class */
3840 * Does all the checking to disambiguate
3842 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3843 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3845 * First argument is the stuff after the first token, e.g. "bar".
3847 * Not a method if foo is a filehandle.
3848 * Not a method if foo is a subroutine prototyped to take a filehandle.
3849 * Not a method if it's really "Foo $bar"
3850 * Method if it's "foo $bar"
3851 * Not a method if it's really "print foo $bar"
3852 * Method if it's really "foo package::" (interpreted as package->foo)
3853 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3854 * Not a method if bar is a filehandle or package, but is quoted with
3859 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3861 char *s = start + (*start == '$');
3862 char tmpbuf[sizeof PL_tokenbuf];
3865 /* Mustn't actually add anything to a symbol table.
3866 But also don't want to "initialise" any placeholder
3867 constants that might already be there into full
3868 blown PVGVs with attached PVCV. */
3870 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3872 PERL_ARGS_ASSERT_INTUIT_METHOD;
3874 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3876 if (cv && SvPOK(cv)) {
3877 const char *proto = CvPROTO(cv);
3879 while (*proto && (isSPACE(*proto) || *proto == ';'))
3886 if (*start == '$') {
3887 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3888 isUPPER(*PL_tokenbuf))
3893 return *s == '(' ? FUNCMETH : METHOD;
3896 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3897 /* start is the beginning of the possible filehandle/object,
3898 * and s is the end of it
3899 * tmpbuf is a copy of it (but with single quotes as double colons)
3902 if (!keyword(tmpbuf, len, 0)) {
3903 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3908 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3909 if (indirgv && GvCVu(indirgv))
3911 /* filehandle or package name makes it a method */
3912 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3914 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3915 return 0; /* no assumptions -- "=>" quotes bareword */
3917 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3918 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3919 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3923 return *s == '(' ? FUNCMETH : METHOD;
3929 /* Encoded script support. filter_add() effectively inserts a
3930 * 'pre-processing' function into the current source input stream.
3931 * Note that the filter function only applies to the current source file
3932 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3934 * The datasv parameter (which may be NULL) can be used to pass
3935 * private data to this instance of the filter. The filter function
3936 * can recover the SV using the FILTER_DATA macro and use it to
3937 * store private buffers and state information.
3939 * The supplied datasv parameter is upgraded to a PVIO type
3940 * and the IoDIRP/IoANY field is used to store the function pointer,
3941 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3942 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3943 * private use must be set using malloc'd pointers.
3947 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3955 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3956 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3958 if (!PL_rsfp_filters)
3959 PL_rsfp_filters = newAV();
3962 SvUPGRADE(datasv, SVt_PVIO);
3963 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3964 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3965 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3966 FPTR2DPTR(void *, IoANY(datasv)),
3967 SvPV_nolen(datasv)));
3968 av_unshift(PL_rsfp_filters, 1);
3969 av_store(PL_rsfp_filters, 0, datasv) ;
3971 !PL_parser->filtered
3972 && PL_parser->lex_flags & LEX_EVALBYTES
3973 && PL_bufptr < PL_bufend
3975 const char *s = PL_bufptr;
3976 while (s < PL_bufend) {
3978 SV *linestr = PL_parser->linestr;
3979 char *buf = SvPVX(linestr);
3980 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3981 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3982 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3983 STRLEN const linestart_pos = PL_parser->linestart - buf;
3984 STRLEN const last_uni_pos =
3985 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3986 STRLEN const last_lop_pos =
3987 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3988 av_push(PL_rsfp_filters, linestr);
3989 PL_parser->linestr =
3990 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3991 buf = SvPVX(PL_parser->linestr);
3992 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3993 PL_parser->bufptr = buf + bufptr_pos;
3994 PL_parser->oldbufptr = buf + oldbufptr_pos;
3995 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3996 PL_parser->linestart = buf + linestart_pos;
3997 if (PL_parser->last_uni)
3998 PL_parser->last_uni = buf + last_uni_pos;
3999 if (PL_parser->last_lop)
4000 PL_parser->last_lop = buf + last_lop_pos;
4001 SvLEN(linestr) = SvCUR(linestr);
4002 SvCUR(linestr) = s-SvPVX(linestr);
4003 PL_parser->filtered = 1;
4013 /* Delete most recently added instance of this filter function. */
4015 Perl_filter_del(pTHX_ filter_t funcp)
4019 PERL_ARGS_ASSERT_FILTER_DEL;
4022 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4023 FPTR2DPTR(void*, funcp)));
4025 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4027 /* if filter is on top of stack (usual case) just pop it off */
4028 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4029 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4030 sv_free(av_pop(PL_rsfp_filters));
4034 /* we need to search for the correct entry and clear it */
4035 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4039 /* Invoke the idxth filter function for the current rsfp. */
4040 /* maxlen 0 = read one text line */
4042 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4046 /* This API is bad. It should have been using unsigned int for maxlen.
4047 Not sure if we want to change the API, but if not we should sanity
4048 check the value here. */
4049 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4051 PERL_ARGS_ASSERT_FILTER_READ;
4053 if (!PL_parser || !PL_rsfp_filters)
4055 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4056 /* Provide a default input filter to make life easy. */
4057 /* Note that we append to the line. This is handy. */
4058 DEBUG_P(PerlIO_printf(Perl_debug_log,
4059 "filter_read %d: from rsfp\n", idx));
4060 if (correct_length) {
4063 const int old_len = SvCUR(buf_sv);
4065 /* ensure buf_sv is large enough */
4066 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4067 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4068 correct_length)) <= 0) {
4069 if (PerlIO_error(PL_rsfp))
4070 return -1; /* error */
4072 return 0 ; /* end of file */
4074 SvCUR_set(buf_sv, old_len + len) ;
4075 SvPVX(buf_sv)[old_len + len] = '\0';
4078 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4079 if (PerlIO_error(PL_rsfp))
4080 return -1; /* error */
4082 return 0 ; /* end of file */
4085 return SvCUR(buf_sv);
4087 /* Skip this filter slot if filter has been deleted */
4088 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4089 DEBUG_P(PerlIO_printf(Perl_debug_log,
4090 "filter_read %d: skipped (filter deleted)\n",
4092 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4094 if (SvTYPE(datasv) != SVt_PVIO) {
4095 if (correct_length) {
4097 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4098 if (!remainder) return 0; /* eof */
4099 if (correct_length > remainder) correct_length = remainder;
4100 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4101 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4104 const char *s = SvEND(datasv);
4105 const char *send = SvPVX(datasv) + SvLEN(datasv);
4113 if (s == send) return 0; /* eof */
4114 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4115 SvCUR_set(datasv, s-SvPVX(datasv));
4117 return SvCUR(buf_sv);
4119 /* Get function pointer hidden within datasv */
4120 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4121 DEBUG_P(PerlIO_printf(Perl_debug_log,
4122 "filter_read %d: via function %p (%s)\n",
4123 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4124 /* Call function. The function is expected to */
4125 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4126 /* Return: <0:error, =0:eof, >0:not eof */
4127 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4131 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4133 PERL_ARGS_ASSERT_FILTER_GETS;
4135 #ifdef PERL_CR_FILTER
4136 if (!PL_rsfp_filters) {
4137 filter_add(S_cr_textfilter,NULL);
4140 if (PL_rsfp_filters) {
4142 SvCUR_set(sv, 0); /* start with empty line */
4143 if (FILTER_READ(0, sv, 0) > 0)
4144 return ( SvPVX(sv) ) ;
4149 return (sv_gets(sv, PL_rsfp, append));
4153 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4157 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4159 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4163 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4164 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4166 return GvHV(gv); /* Foo:: */
4169 /* use constant CLASS => 'MyClass' */
4170 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4171 if (gv && GvCV(gv)) {
4172 SV * const sv = cv_const_sv(GvCV(gv));
4174 return gv_stashsv(sv, 0);
4177 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4182 S_tokenize_use(pTHX_ int is_use, char *s) {
4183 PERL_ARGS_ASSERT_TOKENIZE_USE;
4185 if (PL_expect != XSTATE)
4186 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4187 is_use ? "use" : "no"));
4190 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4191 s = force_version(s, TRUE);
4192 if (*s == ';' || *s == '}'
4193 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4194 NEXTVAL_NEXTTOKE.opval = NULL;
4197 else if (*s == 'v') {
4198 s = force_word(s,WORD,FALSE,TRUE);
4199 s = force_version(s, FALSE);
4203 s = force_word(s,WORD,FALSE,TRUE);
4204 s = force_version(s, FALSE);
4206 pl_yylval.ival = is_use;
4210 static const char* const exp_name[] =
4211 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4212 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4217 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4219 S_word_takes_any_delimeter(char *p, STRLEN len)
4221 return (len == 1 && strchr("msyq", p[0])) ||
4223 (p[0] == 't' && p[1] == 'r') ||
4224 (p[0] == 'q' && strchr("qwxr", p[1]))));
4228 S_check_scalar_slice(pTHX_ char *s)
4231 while (*s == ' ' || *s == '\t') s++;
4232 if (*s == 'q' && s[1] == 'w'
4233 && !isWORDCHAR_lazy_if(s+2,UTF))
4235 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4236 s += UTF ? UTF8SKIP(s) : 1;
4237 if (*s == '}' || *s == ']')
4238 pl_yylval.ival = OPpSLICEWARNING;
4244 Works out what to call the token just pulled out of the input
4245 stream. The yacc parser takes care of taking the ops we return and
4246 stitching them into a tree.
4249 The type of the next token
4252 Switch based on the current state:
4253 - if we already built the token before, use it
4254 - if we have a case modifier in a string, deal with that
4255 - handle other cases of interpolation inside a string
4256 - scan the next line if we are inside a format
4257 In the normal state switch on the next character:
4259 if alphabetic, go to key lookup
4260 unrecoginized character - croak
4261 - 0/4/26: handle end-of-line or EOF
4262 - cases for whitespace
4263 - \n and #: handle comments and line numbers
4264 - various operators, brackets and sigils
4267 - 'v': vstrings (or go to key lookup)
4268 - 'x' repetition operator (or go to key lookup)
4269 - other ASCII alphanumerics (key lookup begins here):
4272 scan built-in keyword (but do nothing with it yet)
4273 check for statement label
4274 check for lexical subs
4275 goto just_a_word if there is one
4276 see whether built-in keyword is overridden
4277 switch on keyword number:
4278 - default: just_a_word:
4279 not a built-in keyword; handle bareword lookup
4280 disambiguate between method and sub call
4281 fall back to bareword
4282 - cases for built-in keywords
4290 char *s = PL_bufptr;
4294 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4298 /* orig_keyword, gvp, and gv are initialized here because
4299 * jump to the label just_a_word_zero can bypass their
4300 * initialization later. */
4301 I32 orig_keyword = 0;
4306 SV* tmp = newSVpvs("");
4307 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4308 (IV)CopLINE(PL_curcop),
4309 lex_state_names[PL_lex_state],
4310 exp_name[PL_expect],
4311 pv_display(tmp, s, strlen(s), 0, 60));
4315 /* when we've already built the next token, just pull it out of the queue */
4318 pl_yylval = PL_nextval[PL_nexttoke];
4320 PL_lex_state = PL_lex_defer;
4321 PL_lex_defer = LEX_NORMAL;
4325 next_type = PL_nexttype[PL_nexttoke];
4326 if (next_type & (7<<24)) {
4327 if (next_type & (1<<24)) {
4328 if (PL_lex_brackets > 100)
4329 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4330 PL_lex_brackstack[PL_lex_brackets++] =
4331 (char) ((next_type >> 16) & 0xff);
4333 if (next_type & (2<<24))
4334 PL_lex_allbrackets++;
4335 if (next_type & (4<<24))
4336 PL_lex_allbrackets--;
4337 next_type &= 0xffff;
4339 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4343 switch (PL_lex_state) {
4345 case LEX_INTERPNORMAL:
4348 /* interpolated case modifiers like \L \U, including \Q and \E.
4349 when we get here, PL_bufptr is at the \
4351 case LEX_INTERPCASEMOD:
4353 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4355 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4356 PL_bufptr, PL_bufend, *PL_bufptr);
4358 /* handle \E or end of string */
4359 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4361 if (PL_lex_casemods) {
4362 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4363 PL_lex_casestack[PL_lex_casemods] = '\0';
4365 if (PL_bufptr != PL_bufend
4366 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4367 || oldmod == 'F')) {
4369 PL_lex_state = LEX_INTERPCONCAT;
4371 PL_lex_allbrackets--;
4374 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4375 /* Got an unpaired \E */
4376 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4377 "Useless use of \\E");
4379 if (PL_bufptr != PL_bufend)
4381 PL_lex_state = LEX_INTERPCONCAT;
4385 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4386 "### Saw case modifier\n"); });
4388 if (s[1] == '\\' && s[2] == 'E') {
4390 PL_lex_state = LEX_INTERPCONCAT;
4395 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4396 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4397 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4398 (strchr(PL_lex_casestack, 'L')
4399 || strchr(PL_lex_casestack, 'U')
4400 || strchr(PL_lex_casestack, 'F'))) {
4401 PL_lex_casestack[--PL_lex_casemods] = '\0';
4402 PL_lex_allbrackets--;
4405 if (PL_lex_casemods > 10)
4406 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4407 PL_lex_casestack[PL_lex_casemods++] = *s;
4408 PL_lex_casestack[PL_lex_casemods] = '\0';
4409 PL_lex_state = LEX_INTERPCONCAT;
4410 NEXTVAL_NEXTTOKE.ival = 0;
4411 force_next((2<<24)|'(');
4413 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4415 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4417 NEXTVAL_NEXTTOKE.ival = OP_LC;
4419 NEXTVAL_NEXTTOKE.ival = OP_UC;
4421 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4423 NEXTVAL_NEXTTOKE.ival = OP_FC;
4425 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4429 if (PL_lex_starts) {
4432 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4433 if (PL_lex_casemods == 1 && PL_lex_inpat)
4436 AopNOASSIGN(OP_CONCAT);
4442 case LEX_INTERPPUSH:
4443 return REPORT(sublex_push());
4445 case LEX_INTERPSTART:
4446 if (PL_bufptr == PL_bufend)
4447 return REPORT(sublex_done());
4448 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4449 "### Interpolated variable\n"); });
4451 /* for /@a/, we leave the joining for the regex engine to do
4452 * (unless we're within \Q etc) */
4453 PL_lex_dojoin = (*PL_bufptr == '@'
4454 && (!PL_lex_inpat || PL_lex_casemods));
4455 PL_lex_state = LEX_INTERPNORMAL;
4456 if (PL_lex_dojoin) {
4457 NEXTVAL_NEXTTOKE.ival = 0;
4459 force_ident("\"", '$');
4460 NEXTVAL_NEXTTOKE.ival = 0;
4462 NEXTVAL_NEXTTOKE.ival = 0;
4463 force_next((2<<24)|'(');
4464 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4467 /* Convert (?{...}) and friends to 'do {...}' */
4468 if (PL_lex_inpat && *PL_bufptr == '(') {
4469 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4471 if (*PL_bufptr != '{')
4473 PL_expect = XTERMBLOCK;
4477 if (PL_lex_starts++) {
4479 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4480 if (!PL_lex_casemods && PL_lex_inpat)
4483 AopNOASSIGN(OP_CONCAT);
4487 case LEX_INTERPENDMAYBE:
4488 if (intuit_more(PL_bufptr)) {
4489 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4495 if (PL_lex_dojoin) {
4496 const U8 dojoin_was = PL_lex_dojoin;
4497 PL_lex_dojoin = FALSE;
4498 PL_lex_state = LEX_INTERPCONCAT;
4499 PL_lex_allbrackets--;
4500 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4502 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4503 && SvEVALED(PL_lex_repl))
4505 if (PL_bufptr != PL_bufend)
4506 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4509 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4510 re_eval_str. If the here-doc body’s length equals the previous
4511 value of re_eval_start, re_eval_start will now be null. So
4512 check re_eval_str as well. */
4513 if (PL_parser->lex_shared->re_eval_start
4514 || PL_parser->lex_shared->re_eval_str) {
4516 if (*PL_bufptr != ')')
4517 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4519 /* having compiled a (?{..}) expression, return the original
4520 * text too, as a const */
4521 if (PL_parser->lex_shared->re_eval_str) {
4522 sv = PL_parser->lex_shared->re_eval_str;
4523 PL_parser->lex_shared->re_eval_str = NULL;
4525 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4526 SvPV_shrink_to_cur(sv);
4528 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4529 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4530 NEXTVAL_NEXTTOKE.opval =
4531 (OP*)newSVOP(OP_CONST, 0,
4534 PL_parser->lex_shared->re_eval_start = NULL;
4540 case LEX_INTERPCONCAT:
4542 if (PL_lex_brackets)
4543 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4544 (long) PL_lex_brackets);
4546 if (PL_bufptr == PL_bufend)
4547 return REPORT(sublex_done());
4549 /* m'foo' still needs to be parsed for possible (?{...}) */
4550 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4551 SV *sv = newSVsv(PL_linestr);
4553 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4557 s = scan_const(PL_bufptr);
4559 PL_lex_state = LEX_INTERPCASEMOD;
4561 PL_lex_state = LEX_INTERPSTART;
4564 if (s != PL_bufptr) {
4565 NEXTVAL_NEXTTOKE = pl_yylval;
4568 if (PL_lex_starts++) {
4569 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4570 if (!PL_lex_casemods && PL_lex_inpat)
4573 AopNOASSIGN(OP_CONCAT);
4583 s = scan_formline(PL_bufptr);
4584 if (!PL_lex_formbrack)
4593 /* We really do *not* want PL_linestr ever becoming a COW. */
4594 assert (!SvIsCOW(PL_linestr));
4596 PL_oldoldbufptr = PL_oldbufptr;
4598 PL_parser->saw_infix_sigil = 0;
4603 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4606 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4607 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4609 SVs_TEMP | SVf_UTF8),
4610 10, UNI_DISPLAY_ISPRINT)
4611 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4612 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4613 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4614 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4618 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4619 UTF8fARG(UTF, (s - d), d),
4624 goto fake_eof; /* emulate EOF on ^D or ^Z */
4626 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4629 if (PL_lex_brackets &&
4630 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4631 yyerror((const char *)
4633 ? "Format not terminated"
4634 : "Missing right curly or square bracket"));
4636 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4637 "### Tokener got EOF\n");
4641 if (s++ < PL_bufend)
4642 goto retry; /* ignore stray nulls */
4645 if (!PL_in_eval && !PL_preambled) {
4646 PL_preambled = TRUE;
4648 /* Generate a string of Perl code to load the debugger.
4649 * If PERL5DB is set, it will return the contents of that,
4650 * otherwise a compile-time require of perl5db.pl. */
4652 const char * const pdb = PerlEnv_getenv("PERL5DB");
4655 sv_setpv(PL_linestr, pdb);
4656 sv_catpvs(PL_linestr,";");
4658 SETERRNO(0,SS_NORMAL);
4659 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4661 PL_parser->preambling = CopLINE(PL_curcop);
4663 sv_setpvs(PL_linestr,"");
4664 if (PL_preambleav) {
4665 SV **svp = AvARRAY(PL_preambleav);
4666 SV **const end = svp + AvFILLp(PL_preambleav);
4668 sv_catsv(PL_linestr, *svp);
4670 sv_catpvs(PL_linestr, ";");
4672 sv_free(MUTABLE_SV(PL_preambleav));
4673 PL_preambleav = NULL;
4676 sv_catpvs(PL_linestr,
4677 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4678 if (PL_minus_n || PL_minus_p) {
4679 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4681 sv_catpvs(PL_linestr,"chomp;");
4684 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4685 || *PL_splitstr == '"')
4686 && strchr(PL_splitstr + 1, *PL_splitstr))
4687 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4689 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4690 bytes can be used as quoting characters. :-) */
4691 const char *splits = PL_splitstr;
4692 sv_catpvs(PL_linestr, "our @F=split(q\0");
4695 if (*splits == '\\')
4696 sv_catpvn(PL_linestr, splits, 1);
4697 sv_catpvn(PL_linestr, splits, 1);
4698 } while (*splits++);
4699 /* This loop will embed the trailing NUL of
4700 PL_linestr as the last thing it does before
4702 sv_catpvs(PL_linestr, ");");
4706 sv_catpvs(PL_linestr,"our @F=split(' ');");
4709 sv_catpvs(PL_linestr, "\n");
4710 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4711 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4712 PL_last_lop = PL_last_uni = NULL;
4713 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4714 update_debugger_info(PL_linestr, NULL, 0);
4719 bof = PL_rsfp ? TRUE : FALSE;
4722 fake_eof = LEX_FAKE_EOF;
4724 PL_bufptr = PL_bufend;
4725 COPLINE_INC_WITH_HERELINES;
4726 if (!lex_next_chunk(fake_eof)) {
4727 CopLINE_dec(PL_curcop);
4729 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4731 CopLINE_dec(PL_curcop);
4733 /* If it looks like the start of a BOM or raw UTF-16,
4734 * check if it in fact is. */
4735 if (bof && PL_rsfp &&
4737 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4740 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4741 bof = (offset == (Off_t)SvCUR(PL_linestr));
4742 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4743 /* offset may include swallowed CR */
4745 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4748 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4749 s = swallow_bom((U8*)s);
4752 if (PL_parser->in_pod) {
4753 /* Incest with pod. */
4754 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4755 sv_setpvs(PL_linestr, "");
4756 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4757 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4758 PL_last_lop = PL_last_uni = NULL;
4759 PL_parser->in_pod = 0;
4762 if (PL_rsfp || PL_parser->filtered)
4764 } while (PL_parser->in_pod);
4765 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4766 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4767 PL_last_lop = PL_last_uni = NULL;
4768 if (CopLINE(PL_curcop) == 1) {
4769 while (s < PL_bufend && isSPACE(*s))
4771 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4775 if (*s == '#' && *(s+1) == '!')
4777 #ifdef ALTERNATE_SHEBANG
4779 static char const as[] = ALTERNATE_SHEBANG;
4780 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4781 d = s + (sizeof(as) - 1);
4783 #endif /* ALTERNATE_SHEBANG */
4792 while (*d && !isSPACE(*d))
4796 #ifdef ARG_ZERO_IS_SCRIPT
4797 if (ipathend > ipath) {
4799 * HP-UX (at least) sets argv[0] to the script name,
4800 * which makes $^X incorrect. And Digital UNIX and Linux,
4801 * at least, set argv[0] to the basename of the Perl
4802 * interpreter. So, having found "#!", we'll set it right.
4804 SV* copfilesv = CopFILESV(PL_curcop);
4807 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4809 assert(SvPOK(x) || SvGMAGICAL(x));
4810 if (sv_eq(x, copfilesv)) {
4811 sv_setpvn(x, ipath, ipathend - ipath);
4817 const char *bstart = SvPV_const(copfilesv, blen);
4818 const char * const lstart = SvPV_const(x, llen);
4820 bstart += blen - llen;
4821 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4822 sv_setpvn(x, ipath, ipathend - ipath);
4829 /* Anything to do if no copfilesv? */
4831 TAINT_NOT; /* $^X is always tainted, but that's OK */
4833 #endif /* ARG_ZERO_IS_SCRIPT */
4838 d = instr(s,"perl -");
4840 d = instr(s,"perl");
4842 /* avoid getting into infinite loops when shebang
4843 * line contains "Perl" rather than "perl" */
4845 for (d = ipathend-4; d >= ipath; --d) {
4846 if (isALPHA_FOLD_EQ(*d, 'p')
4847 && !ibcmp(d, "perl", 4))
4857 #ifdef ALTERNATE_SHEBANG
4859 * If the ALTERNATE_SHEBANG on this system starts with a
4860 * character that can be part of a Perl expression, then if
4861 * we see it but not "perl", we're probably looking at the
4862 * start of Perl code, not a request to hand off to some
4863 * other interpreter. Similarly, if "perl" is there, but
4864 * not in the first 'word' of the line, we assume the line
4865 * contains the start of the Perl program.
4867 if (d && *s != '#') {
4868 const char *c = ipath;
4869 while (*c && !strchr("; \t\r\n\f\v#", *c))
4872 d = NULL; /* "perl" not in first word; ignore */
4874 *s = '#'; /* Don't try to parse shebang line */
4876 #endif /* ALTERNATE_SHEBANG */
4881 !instr(s,"indir") &&
4882 instr(PL_origargv[0],"perl"))
4889 while (s < PL_bufend && isSPACE(*s))
4891 if (s < PL_bufend) {
4892 Newx(newargv,PL_origargc+3,char*);
4894 while (s < PL_bufend && !isSPACE(*s))
4897 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4900 newargv = PL_origargv;
4903 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4905 Perl_croak(aTHX_ "Can't exec %s", ipath);
4908 while (*d && !isSPACE(*d))
4910 while (SPACE_OR_TAB(*d))
4914 const bool switches_done = PL_doswitches;
4915 const U32 oldpdb = PL_perldb;
4916 const bool oldn = PL_minus_n;
4917 const bool oldp = PL_minus_p;
4921 bool baduni = FALSE;
4923 const char *d2 = d1 + 1;
4924 if (parse_unicode_opts((const char **)&d2)
4928 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4929 const char * const m = d1;
4930 while (*d1 && !isSPACE(*d1))
4932 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4935 d1 = moreswitches(d1);
4937 if (PL_doswitches && !switches_done) {
4938 int argc = PL_origargc;
4939 char **argv = PL_origargv;
4942 } while (argc && argv[0][0] == '-' && argv[0][1]);
4943 init_argv_symbols(argc,argv);
4945 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4946 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4947 /* if we have already added "LINE: while (<>) {",
4948 we must not do it again */
4950 sv_setpvs(PL_linestr, "");
4951 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4952 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4953 PL_last_lop = PL_last_uni = NULL;
4954 PL_preambled = FALSE;
4955 if (PERLDB_LINE || PERLDB_SAVESRC)
4956 (void)gv_fetchfile(PL_origfilename);
4963 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4964 PL_lex_state = LEX_FORMLINE;
4965 NEXTVAL_NEXTTOKE.ival = 0;
4966 force_next(FORMRBRACK);
4971 #ifdef PERL_STRICT_CR
4972 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4974 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4976 case ' ': case '\t': case '\f': case '\v':
4981 if (PL_lex_state != LEX_NORMAL ||
4982 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
4983 const bool in_comment = *s == '#';
4984 if (*s == '#' && s == PL_linestart && PL_in_eval
4985 && !PL_rsfp && !PL_parser->filtered) {
4986 /* handle eval qq[#line 1 "foo"\n ...] */
4987 CopLINE_dec(PL_curcop);
4991 while (d < PL_bufend && *d != '\n')
4995 else if (d > PL_bufend)
4996 /* Found by Ilya: feed random input to Perl. */
4997 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5000 if (in_comment && d == PL_bufend
5001 && PL_lex_state == LEX_INTERPNORMAL
5002 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5003 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5006 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5007 PL_lex_state = LEX_FORMLINE;
5008 NEXTVAL_NEXTTOKE.ival = 0;
5009 force_next(FORMRBRACK);
5014 while (s < PL_bufend && *s != '\n')
5022 else if (s > PL_bufend)
5023 /* Found by Ilya: feed random input to Perl. */
5024 Perl_croak(aTHX_ "panic: input overflow");
5028 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5036 while (s < PL_bufend && SPACE_OR_TAB(*s))
5039 if (strnEQ(s,"=>",2)) {
5040 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5041 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5042 OPERATOR('-'); /* unary minus */
5045 case 'r': ftst = OP_FTEREAD; break;
5046 case 'w': ftst = OP_FTEWRITE; break;
5047 case 'x': ftst = OP_FTEEXEC; break;
5048 case 'o': ftst = OP_FTEOWNED; break;
5049 case 'R': ftst = OP_FTRREAD; break;
5050 case 'W': ftst = OP_FTRWRITE; break;
5051 case 'X': ftst = OP_FTREXEC; break;
5052 case 'O': ftst = OP_FTROWNED; break;
5053 case 'e': ftst = OP_FTIS; break;
5054 case 'z': ftst = OP_FTZERO; break;
5055 case 's': ftst = OP_FTSIZE; break;
5056 case 'f': ftst = OP_FTFILE; break;
5057 case 'd': ftst = OP_FTDIR; break;
5058 case 'l': ftst = OP_FTLINK; break;
5059 case 'p': ftst = OP_FTPIPE; break;
5060 case 'S': ftst = OP_FTSOCK; break;
5061 case 'u': ftst = OP_FTSUID; break;
5062 case 'g': ftst = OP_FTSGID; break;
5063 case 'k': ftst = OP_FTSVTX; break;
5064 case 'b': ftst = OP_FTBLK; break;
5065 case 'c': ftst = OP_FTCHR; break;
5066 case 't': ftst = OP_FTTTY; break;
5067 case 'T': ftst = OP_FTTEXT; break;
5068 case 'B': ftst = OP_FTBINARY; break;
5069 case 'M': case 'A': case 'C':
5070 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5072 case 'M': ftst = OP_FTMTIME; break;
5073 case 'A': ftst = OP_FTATIME; break;
5074 case 'C': ftst = OP_FTCTIME; break;
5082 PL_last_uni = PL_oldbufptr;
5083 PL_last_lop_op = (OPCODE)ftst;
5084 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5085 "### Saw file test %c\n", (int)tmp);
5090 /* Assume it was a minus followed by a one-letter named
5091 * subroutine call (or a -bareword), then. */
5092 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5093 "### '-%c' looked like a file test but was not\n",
5100 const char tmp = *s++;
5103 if (PL_expect == XOPERATOR)
5108 else if (*s == '>') {
5111 if (FEATURE_POSTDEREF_IS_ENABLED && (
5112 ((*s == '$' || *s == '&') && s[1] == '*')
5113 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5114 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5115 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5118 Perl_ck_warner_d(aTHX_
5119 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5120 "Postfix dereference is experimental"
5122 PL_expect = XPOSTDEREF;
5125 if (isIDFIRST_lazy_if(s,UTF)) {
5126 s = force_word(s,METHOD,FALSE,TRUE);
5134 if (PL_expect == XOPERATOR) {
5135 if (*s == '=' && !PL_lex_allbrackets &&
5136 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5143 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5145 OPERATOR('-'); /* unary minus */
5151 const char tmp = *s++;
5154 if (PL_expect == XOPERATOR)
5159 if (PL_expect == XOPERATOR) {
5160 if (*s == '=' && !PL_lex_allbrackets &&
5161 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5168 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5175 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5176 if (PL_expect != XOPERATOR) {
5177 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5178 PL_expect = XOPERATOR;
5179 force_ident(PL_tokenbuf, '*');
5187 if (*s == '=' && !PL_lex_allbrackets &&
5188 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5194 if (*s == '=' && !PL_lex_allbrackets &&
5195 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5199 PL_parser->saw_infix_sigil = 1;
5204 if (PL_expect == XOPERATOR) {
5205 if (s[1] == '=' && !PL_lex_allbrackets &&
5206 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5209 PL_parser->saw_infix_sigil = 1;
5212 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5213 PL_tokenbuf[0] = '%';
5214 s = scan_ident(s, PL_tokenbuf + 1,
5215 sizeof PL_tokenbuf - 1, FALSE);
5217 if (!PL_tokenbuf[1]) {
5220 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5222 PL_tokenbuf[0] = '@';
5224 PL_expect = XOPERATOR;
5225 force_ident_maybe_lex('%');
5230 bof = FEATURE_BITWISE_IS_ENABLED;
5231 if (bof && s[1] == '.')
5233 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5234 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5240 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5242 if (PL_lex_brackets > 100)
5243 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5244 PL_lex_brackstack[PL_lex_brackets++] = 0;
5245 PL_lex_allbrackets++;
5247 const char tmp = *s++;
5252 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5254 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5257 Perl_ck_warner_d(aTHX_
5258 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5259 "Smartmatch is experimental");
5263 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5265 BCop(OP_SCOMPLEMENT);
5267 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5269 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5276 goto just_a_word_zero_gv;
5282 switch (PL_expect) {
5284 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5286 PL_bufptr = s; /* update in case we back off */
5289 "Use of := for an empty attribute list is not allowed");
5296 PL_expect = XTERMBLOCK;
5300 while (isIDFIRST_lazy_if(s,UTF)) {
5303 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5304 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5305 if (tmp < 0) tmp = -tmp;
5320 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5322 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5323 COPLINE_SET_FROM_MULTI_END;
5325 /* MUST advance bufptr here to avoid bogus
5326 "at end of line" context messages from yyerror().
5328 PL_bufptr = s + len;
5329 yyerror("Unterminated attribute parameter in attribute list");
5333 return REPORT(0); /* EOF indicator */
5337 sv_catsv(sv, PL_lex_stuff);
5338 attrs = op_append_elem(OP_LIST, attrs,
5339 newSVOP(OP_CONST, 0, sv));
5340 SvREFCNT_dec_NN(PL_lex_stuff);
5341 PL_lex_stuff = NULL;
5344 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5346 if (PL_in_my == KEY_our) {
5347 deprecate(":unique");
5350 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5353 /* NOTE: any CV attrs applied here need to be part of
5354 the CVf_BUILTIN_ATTRS define in cv.h! */
5355 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5357 CvLVALUE_on(PL_compcv);
5359 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5361 deprecate(":locked");
5363 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5365 CvMETHOD_on(PL_compcv);
5367 else if (!PL_in_my && len == 5
5368 && strnEQ(SvPVX(sv), "const", len))
5371 Perl_ck_warner_d(aTHX_
5372 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5373 ":const is experimental"
5375 CvANONCONST_on(PL_compcv);
5376 if (!CvANON(PL_compcv))
5377 yyerror(":const is not permitted on named "
5380 /* After we've set the flags, it could be argued that
5381 we don't need to do the attributes.pm-based setting
5382 process, and shouldn't bother appending recognized
5383 flags. To experiment with that, uncomment the
5384 following "else". (Note that's already been
5385 uncommented. That keeps the above-applied built-in
5386 attributes from being intercepted (and possibly
5387 rejected) by a package's attribute routines, but is
5388 justified by the performance win for the common case
5389 of applying only built-in attributes.) */
5391 attrs = op_append_elem(OP_LIST, attrs,
5392 newSVOP(OP_CONST, 0,
5396 if (*s == ':' && s[1] != ':')
5399 break; /* require real whitespace or :'s */
5400 /* XXX losing whitespace on sequential attributes here */
5403 if (*s != ';' && *s != '}' &&
5404 !(PL_expect == XOPERATOR
5405 ? (*s == '=' || *s == ')')
5406 : (*s == '{' || *s == '('))) {
5407 const char q = ((*s == '\'') ? '"' : '\'');
5408 /* If here for an expression, and parsed no attrs, back
5410 if (PL_expect == XOPERATOR && !attrs) {
5414 /* MUST advance bufptr here to avoid bogus "at end of line"
5415 context messages from yyerror().
5418 yyerror( (const char *)
5420 ? Perl_form(aTHX_ "Invalid separator character "
5421 "%c%c%c in attribute list", q, *s, q)
5422 : "Unterminated attribute list" ) );
5430 NEXTVAL_NEXTTOKE.opval = attrs;
5436 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5440 PL_lex_allbrackets--;
5444 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5445 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5449 PL_lex_allbrackets++;
5452 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5459 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5462 PL_lex_allbrackets--;
5468 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5471 if (PL_lex_brackets <= 0)
5472 /* diag_listed_as: Unmatched right %s bracket */
5473 yyerror("Unmatched right square bracket");
5476 PL_lex_allbrackets--;
5477 if (PL_lex_state == LEX_INTERPNORMAL) {
5478 if (PL_lex_brackets == 0) {
5479 if (*s == '-' && s[1] == '>')
5480 PL_lex_state = LEX_INTERPENDMAYBE;
5481 else if (*s != '[' && *s != '{')
5482 PL_lex_state = LEX_INTERPEND;
5489 if (PL_lex_brackets > 100) {
5490 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5492 switch (PL_expect) {
5495 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5496 PL_lex_allbrackets++;
5497 OPERATOR(HASHBRACK);
5499 while (s < PL_bufend && SPACE_OR_TAB(*s))
5502 PL_tokenbuf[0] = '\0';
5503 if (d < PL_bufend && *d == '-') {
5504 PL_tokenbuf[0] = '-';
5506 while (d < PL_bufend && SPACE_OR_TAB(*d))
5509 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5510 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5512 while (d < PL_bufend && SPACE_OR_TAB(*d))
5515 const char minus = (PL_tokenbuf[0] == '-');
5516 s = force_word(s + minus, WORD, FALSE, TRUE);
5524 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5525 PL_lex_allbrackets++;
5530 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5531 PL_lex_allbrackets++;
5535 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5536 PL_lex_allbrackets++;
5541 if (PL_oldoldbufptr == PL_last_lop)
5542 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5544 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5545 PL_lex_allbrackets++;
5548 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5550 /* This hack is to get the ${} in the message. */
5552 yyerror("syntax error");
5555 OPERATOR(HASHBRACK);
5557 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5558 /* ${...} or @{...} etc., but not print {...}
5559 * Skip the disambiguation and treat this as a block.
5561 goto block_expectation;
5563 /* This hack serves to disambiguate a pair of curlies
5564 * as being a block or an anon hash. Normally, expectation
5565 * determines that, but in cases where we're not in a
5566 * position to expect anything in particular (like inside
5567 * eval"") we have to resolve the ambiguity. This code
5568 * covers the case where the first term in the curlies is a
5569 * quoted string. Most other cases need to be explicitly
5570 * disambiguated by prepending a "+" before the opening
5571 * curly in order to force resolution as an anon hash.
5573 * XXX should probably propagate the outer expectation
5574 * into eval"" to rely less on this hack, but that could
5575 * potentially break current behavior of eval"".
5579 if (*s == '\'' || *s == '"' || *s == '`') {
5580 /* common case: get past first string, handling escapes */
5581 for (t++; t < PL_bufend && *t != *s;)
5586 else if (*s == 'q') {
5589 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5590 && !isWORDCHAR(*t))))
5592 /* skip q//-like construct */
5594 char open, close, term;
5597 while (t < PL_bufend && isSPACE(*t))
5599 /* check for q => */
5600 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5601 OPERATOR(HASHBRACK);
5605 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5609 for (t++; t < PL_bufend; t++) {
5610 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5612 else if (*t == open)
5616 for (t++; t < PL_bufend; t++) {
5617 if (*t == '\\' && t+1 < PL_bufend)
5619 else if (*t == close && --brackets <= 0)
5621 else if (*t == open)
5628 /* skip plain q word */
5629 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5632 else if (isWORDCHAR_lazy_if(t,UTF)) {
5634 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5637 while (t < PL_bufend && isSPACE(*t))
5639 /* if comma follows first term, call it an anon hash */
5640 /* XXX it could be a comma expression with loop modifiers */
5641 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5642 || (*t == '=' && t[1] == '>')))
5643 OPERATOR(HASHBRACK);
5644 if (PL_expect == XREF)
5647 /* If there is an opening brace or 'sub:', treat it
5648 as a term to make ${{...}}{k} and &{sub:attr...}
5649 dwim. Otherwise, treat it as a statement, so
5650 map {no strict; ...} works.
5657 if (strnEQ(s, "sub", 3)) {
5668 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5674 pl_yylval.ival = CopLINE(PL_curcop);
5675 PL_copline = NOLINE; /* invalidate current command line number */
5676 TOKEN(formbrack ? '=' : '{');
5678 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5682 if (PL_lex_brackets <= 0)
5683 /* diag_listed_as: Unmatched right %s bracket */
5684 yyerror("Unmatched right curly bracket");
5686 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5687 PL_lex_allbrackets--;
5688 if (PL_lex_state == LEX_INTERPNORMAL) {
5689 if (PL_lex_brackets == 0) {
5690 if (PL_expect & XFAKEBRACK) {
5691 PL_expect &= XENUMMASK;
5692 PL_lex_state = LEX_INTERPEND;
5694 return yylex(); /* ignore fake brackets */
5696 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5697 && SvEVALED(PL_lex_repl))
5698 PL_lex_state = LEX_INTERPEND;
5699 else if (*s == '-' && s[1] == '>')
5700 PL_lex_state = LEX_INTERPENDMAYBE;
5701 else if (*s != '[' && *s != '{')
5702 PL_lex_state = LEX_INTERPEND;
5705 if (PL_expect & XFAKEBRACK) {
5706 PL_expect &= XENUMMASK;
5708 return yylex(); /* ignore fake brackets */
5710 force_next(formbrack ? '.' : '}');
5711 if (formbrack) LEAVE;
5712 if (formbrack == 2) { /* means . where arguments were expected */
5718 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5721 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5722 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5729 if (PL_expect == XOPERATOR) {
5730 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5731 && isIDFIRST_lazy_if(s,UTF))
5733 CopLINE_dec(PL_curcop);
5734 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5735 CopLINE_inc(PL_curcop);
5738 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5740 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5741 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5747 PL_parser->saw_infix_sigil = 1;
5748 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5754 PL_tokenbuf[0] = '&';
5755 s = scan_ident(s - 1, PL_tokenbuf + 1,
5756 sizeof PL_tokenbuf - 1, TRUE);
5757 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5758 if (PL_tokenbuf[1]) {
5759 force_ident_maybe_lex('&');
5768 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5769 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5777 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5779 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5780 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5784 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
5788 const char tmp = *s++;
5790 if (!PL_lex_allbrackets &&
5791 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5798 if (!PL_lex_allbrackets &&
5799 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5807 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5808 && strchr("+-*/%.^&|<",tmp))
5809 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5810 "Reversed %c= operator",(int)tmp);
5812 if (PL_expect == XSTATE && isALPHA(tmp) &&
5813 (s == PL_linestart+1 || s[-2] == '\n') )
5815 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5816 || PL_lex_state != LEX_NORMAL) {
5821 if (strnEQ(s,"=cut",4)) {
5835 PL_parser->in_pod = 1;
5839 if (PL_expect == XBLOCK) {
5841 #ifdef PERL_STRICT_CR
5842 while (SPACE_OR_TAB(*t))
5844 while (SPACE_OR_TAB(*t) || *t == '\r')
5847 if (*t == '\n' || *t == '#') {
5850 SAVEI8(PL_parser->form_lex_state);
5851 SAVEI32(PL_lex_formbrack);
5852 PL_parser->form_lex_state = PL_lex_state;
5853 PL_lex_formbrack = PL_lex_brackets + 1;
5857 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5866 const char tmp = *s++;
5868 /* was this !=~ where !~ was meant?
5869 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5871 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5872 const char *t = s+1;
5874 while (t < PL_bufend && isSPACE(*t))
5877 if (*t == '/' || *t == '?' ||
5878 ((*t == 'm' || *t == 's' || *t == 'y')
5879 && !isWORDCHAR(t[1])) ||
5880 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5881 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5882 "!=~ should be !~");
5884 if (!PL_lex_allbrackets &&
5885 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5897 if (PL_expect != XOPERATOR) {
5898 if (s[1] != '<' && !strchr(s,'>'))
5900 if (s[1] == '<' && s[2] != '>')
5901 s = scan_heredoc(s);
5903 s = scan_inputsymbol(s);
5904 PL_expect = XOPERATOR;
5905 TOKEN(sublex_start());
5911 if (*s == '=' && !PL_lex_allbrackets &&
5912 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5916 SHop(OP_LEFT_SHIFT);
5921 if (!PL_lex_allbrackets &&
5922 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5929 if (!PL_lex_allbrackets &&
5930 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5938 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5946 const char tmp = *s++;
5948 if (*s == '=' && !PL_lex_allbrackets &&
5949 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5953 SHop(OP_RIGHT_SHIFT);
5955 else if (tmp == '=') {
5956 if (!PL_lex_allbrackets &&
5957 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5965 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5974 if (PL_expect == XOPERATOR) {
5975 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5976 return deprecate_commaless_var_list();
5979 else if (PL_expect == XPOSTDEREF) {
5982 POSTDEREF(DOLSHARP);
5987 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
5988 PL_tokenbuf[0] = '@';
5989 s = scan_ident(s + 1, PL_tokenbuf + 1,
5990 sizeof PL_tokenbuf - 1, FALSE);
5991 if (PL_expect == XOPERATOR)
5992 no_op("Array length", s);
5993 if (!PL_tokenbuf[1])
5995 PL_expect = XOPERATOR;
5996 force_ident_maybe_lex('#');
6000 PL_tokenbuf[0] = '$';
6001 s = scan_ident(s, PL_tokenbuf + 1,
6002 sizeof PL_tokenbuf - 1, FALSE);
6003 if (PL_expect == XOPERATOR) {
6005 if (PL_bufptr > s) {
6007 PL_bufptr = PL_oldbufptr;
6011 if (!PL_tokenbuf[1]) {
6013 yyerror("Final $ should be \\$ or $name");
6019 const char tmp = *s;
6020 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6023 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6024 && intuit_more(s)) {
6026 PL_tokenbuf[0] = '@';
6027 if (ckWARN(WARN_SYNTAX)) {
6030 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6033 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6034 while (t < PL_bufend && *t != ']')
6036 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6037 "Multidimensional syntax %.*s not supported",
6038 (int)((t - PL_bufptr) + 1), PL_bufptr);
6042 else if (*s == '{') {
6044 PL_tokenbuf[0] = '%';
6045 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6046 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6048 char tmpbuf[sizeof PL_tokenbuf];
6051 } while (isSPACE(*t));
6052 if (isIDFIRST_lazy_if(t,UTF)) {
6054 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6059 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6060 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6061 "You need to quote \"%"UTF8f"\"",
6062 UTF8fARG(UTF, len, tmpbuf));
6068 PL_expect = XOPERATOR;
6069 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6070 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6071 if (!islop || PL_last_lop_op == OP_GREPSTART)
6072 PL_expect = XOPERATOR;
6073 else if (strchr("$@\"'`q", *s))
6074 PL_expect = XTERM; /* e.g. print $fh "foo" */
6075 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6076 PL_expect = XTERM; /* e.g. print $fh &sub */
6077 else if (isIDFIRST_lazy_if(s,UTF)) {
6078 char tmpbuf[sizeof PL_tokenbuf];
6080 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6081 if ((t2 = keyword(tmpbuf, len, 0))) {
6082 /* binary operators exclude handle interpretations */
6094 PL_expect = XTERM; /* e.g. print $fh length() */
6099 PL_expect = XTERM; /* e.g. print $fh subr() */
6102 else if (isDIGIT(*s))
6103 PL_expect = XTERM; /* e.g. print $fh 3 */
6104 else if (*s == '.' && isDIGIT(s[1]))
6105 PL_expect = XTERM; /* e.g. print $fh .3 */
6106 else if ((*s == '?' || *s == '-' || *s == '+')
6107 && !isSPACE(s[1]) && s[1] != '=')
6108 PL_expect = XTERM; /* e.g. print $fh -1 */
6109 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6111 PL_expect = XTERM; /* e.g. print $fh /.../
6112 XXX except DORDOR operator
6114 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6116 PL_expect = XTERM; /* print $fh <<"EOF" */
6119 force_ident_maybe_lex('$');
6123 if (PL_expect == XOPERATOR)
6125 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6126 PL_tokenbuf[0] = '@';
6127 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6129 if (!PL_tokenbuf[1]) {
6132 if (PL_lex_state == LEX_NORMAL)
6134 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6136 PL_tokenbuf[0] = '%';
6138 /* Warn about @ where they meant $. */
6139 if (*s == '[' || *s == '{') {
6140 if (ckWARN(WARN_SYNTAX)) {
6141 S_check_scalar_slice(aTHX_ s);
6145 PL_expect = XOPERATOR;
6146 force_ident_maybe_lex('@');
6149 case '/': /* may be division, defined-or, or pattern */
6150 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6151 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6152 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6157 else if (PL_expect == XOPERATOR) {
6159 if (*s == '=' && !PL_lex_allbrackets &&
6160 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6167 /* Disable warning on "study /blah/" */
6168 if (PL_oldoldbufptr == PL_last_uni
6169 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6170 || memNE(PL_last_uni, "study", 5)
6171 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6174 s = scan_pat(s,OP_MATCH);
6175 TERM(sublex_start());
6178 case '?': /* conditional */
6180 if (!PL_lex_allbrackets &&
6181 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6185 PL_lex_allbrackets++;
6189 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6190 #ifdef PERL_STRICT_CR
6193 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6195 && (s == PL_linestart || s[-1] == '\n') )
6198 formbrack = 2; /* dot seen where arguments expected */
6201 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6205 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6208 if (!PL_lex_allbrackets &&
6209 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6216 pl_yylval.ival = OPf_SPECIAL;
6222 if (*s == '=' && !PL_lex_allbrackets &&
6223 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6230 case '0': case '1': case '2': case '3': case '4':
6231 case '5': case '6': case '7': case '8': case '9':
6232 s = scan_num(s, &pl_yylval);
6233 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6234 if (PL_expect == XOPERATOR)
6239 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6242 COPLINE_SET_FROM_MULTI_END;
6243 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6244 if (PL_expect == XOPERATOR) {
6245 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6246 return deprecate_commaless_var_list();
6251 pl_yylval.ival = OP_CONST;
6252 TERM(sublex_start());
6255 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6258 printbuf("### Saw string before %s\n", s);
6260 PerlIO_printf(Perl_debug_log,
6261 "### Saw unterminated string\n");
6263 if (PL_expect == XOPERATOR) {
6264 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6265 return deprecate_commaless_var_list();
6272 pl_yylval.ival = OP_CONST;
6273 /* FIXME. I think that this can be const if char *d is replaced by
6274 more localised variables. */
6275 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6276 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6277 pl_yylval.ival = OP_STRINGIFY;
6281 if (pl_yylval.ival == OP_CONST)
6282 COPLINE_SET_FROM_MULTI_END;
6283 TERM(sublex_start());
6286 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6287 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6288 if (PL_expect == XOPERATOR)
6289 no_op("Backticks",s);
6292 pl_yylval.ival = OP_BACKTICK;
6293 TERM(sublex_start());
6297 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6299 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6301 if (PL_expect == XOPERATOR)
6302 no_op("Backslash",s);
6306 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6307 char *start = s + 2;
6308 while (isDIGIT(*start) || *start == '_')
6310 if (*start == '.' && isDIGIT(start[1])) {
6311 s = scan_num(s, &pl_yylval);
6314 else if ((*start == ':' && start[1] == ':')
6315 || (PL_expect == XSTATE && *start == ':'))
6317 else if (PL_expect == XSTATE) {
6319 while (d < PL_bufend && isSPACE(*d)) d++;
6320 if (*d == ':') goto keylookup;
6322 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6323 if (!isALPHA(*start) && (PL_expect == XTERM
6324 || PL_expect == XREF || PL_expect == XSTATE
6325 || PL_expect == XTERMORDORDOR)) {
6326 GV *const gv = gv_fetchpvn_flags(s, start - s,
6327 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6329 s = scan_num(s, &pl_yylval);
6336 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6389 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6391 /* Some keywords can be followed by any delimiter, including ':' */
6392 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6394 /* x::* is just a word, unless x is "CORE" */
6395 if (!anydelim && *s == ':' && s[1] == ':') {
6396 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6401 while (d < PL_bufend && isSPACE(*d))
6402 d++; /* no comments skipped here, or s### is misparsed */
6404 /* Is this a word before a => operator? */
6405 if (*d == '=' && d[1] == '>') {
6409 = (OP*)newSVOP(OP_CONST, 0,
6410 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6411 pl_yylval.opval->op_private = OPpCONST_BARE;
6415 /* Check for plugged-in keyword */
6419 char *saved_bufptr = PL_bufptr;
6421 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6423 if (result == KEYWORD_PLUGIN_DECLINE) {
6424 /* not a plugged-in keyword */
6425 PL_bufptr = saved_bufptr;
6426 } else if (result == KEYWORD_PLUGIN_STMT) {
6427 pl_yylval.opval = o;
6429 if (!PL_nexttoke) PL_expect = XSTATE;
6430 return REPORT(PLUGSTMT);
6431 } else if (result == KEYWORD_PLUGIN_EXPR) {
6432 pl_yylval.opval = o;
6434 if (!PL_nexttoke) PL_expect = XOPERATOR;
6435 return REPORT(PLUGEXPR);
6437 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6442 /* Check for built-in keyword */
6443 tmp = keyword(PL_tokenbuf, len, 0);
6445 /* Is this a label? */
6446 if (!anydelim && PL_expect == XSTATE
6447 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6449 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6450 pl_yylval.pval[len] = '\0';
6451 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6456 /* Check for lexical sub */
6457 if (PL_expect != XOPERATOR) {
6458 char tmpbuf[sizeof PL_tokenbuf + 1];
6460 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6461 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6462 if (off != NOT_IN_PAD) {
6463 assert(off); /* we assume this is boolean-true below */
6464 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6465 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6466 HEK * const stashname = HvNAME_HEK(stash);
6467 sv = newSVhek(stashname);
6468 sv_catpvs(sv, "::");
6469 sv_catpvn_flags(sv, PL_tokenbuf, len,
6470 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6471 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6481 rv2cv_op = newOP(OP_PADANY, 0);
6482 rv2cv_op->op_targ = off;
6483 cv = find_lexical_cv(off);
6491 if (tmp < 0) { /* second-class keyword? */
6492 GV *ogv = NULL; /* override (winner) */
6493 GV *hgv = NULL; /* hidden (loser) */
6494 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6496 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6497 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6501 if (GvIMPORTED_CV(gv))
6503 else if (! CvMETHOD(cv))
6507 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6511 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6512 : SvPCS_IMPORTED(gv)
6513 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6522 tmp = 0; /* overridden by import or by GLOBAL */
6525 && -tmp==KEY_lock /* XXX generalizable kludge */
6528 tmp = 0; /* any sub overrides "weak" keyword */
6530 else { /* no override */
6532 if (tmp == KEY_dump) {
6533 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6534 "dump() better written as CORE::dump()");
6538 if (hgv && tmp != KEY_x) /* never ambiguous */
6539 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6540 "Ambiguous call resolved as CORE::%s(), "
6541 "qualify as such or use &",
6546 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6547 && (!anydelim || *s != '#')) {
6548 /* no override, and not s### either; skipspace is safe here
6549 * check for => on following line */
6551 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6552 STRLEN soff = s - SvPVX(PL_linestr);
6553 s = skipspace_flags(s, LEX_NO_INCLINE);
6554 arrow = *s == '=' && s[1] == '>';
6555 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6556 s = SvPVX(PL_linestr) + soff;
6564 default: /* not a keyword */
6565 /* Trade off - by using this evil construction we can pull the
6566 variable gv into the block labelled keylookup. If not, then
6567 we have to give it function scope so that the goto from the
6568 earlier ':' case doesn't bypass the initialisation. */
6570 just_a_word_zero_gv:
6582 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6586 /* Get the rest if it looks like a package qualifier */
6588 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6590 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6593 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6594 UTF8fARG(UTF, len, PL_tokenbuf),
6595 *s == '\'' ? "'" : "::");
6600 if (PL_expect == XOPERATOR) {
6601 if (PL_bufptr == PL_linestart) {
6602 CopLINE_dec(PL_curcop);
6603 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6604 CopLINE_inc(PL_curcop);
6607 no_op("Bareword",s);
6610 /* See if the name is "Foo::",
6611 in which case Foo is a bareword
6612 (and a package name). */
6615 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6617 if (ckWARN(WARN_BAREWORD)
6618 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6619 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6620 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6621 UTF8fARG(UTF, len, PL_tokenbuf));
6623 PL_tokenbuf[len] = '\0';
6632 /* if we saw a global override before, get the right name */
6635 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6638 SV * const tmp_sv = sv;
6639 sv = newSVpvs("CORE::GLOBAL::");
6640 sv_catsv(sv, tmp_sv);
6641 SvREFCNT_dec(tmp_sv);
6645 /* Presume this is going to be a bareword of some sort. */
6647 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6648 pl_yylval.opval->op_private = OPpCONST_BARE;
6650 /* And if "Foo::", then that's what it certainly is. */
6656 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6657 const_op->op_private = OPpCONST_BARE;
6659 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6663 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6666 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6669 /* Use this var to track whether intuit_method has been
6670 called. intuit_method returns 0 or > 255. */
6673 /* See if it's the indirect object for a list operator. */
6675 if (PL_oldoldbufptr &&
6676 PL_oldoldbufptr < PL_bufptr &&
6677 (PL_oldoldbufptr == PL_last_lop
6678 || PL_oldoldbufptr == PL_last_uni) &&
6679 /* NO SKIPSPACE BEFORE HERE! */
6680 (PL_expect == XREF ||
6681 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6683 bool immediate_paren = *s == '(';
6685 /* (Now we can afford to cross potential line boundary.) */
6688 /* Two barewords in a row may indicate method call. */
6690 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6691 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6695 /* If not a declared subroutine, it's an indirect object. */
6696 /* (But it's an indir obj regardless for sort.) */
6697 /* Also, if "_" follows a filetest operator, it's a bareword */
6700 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6702 (PL_last_lop_op != OP_MAPSTART &&
6703 PL_last_lop_op != OP_GREPSTART))))
6704 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6705 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6708 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6713 PL_expect = XOPERATOR;
6716 /* Is this a word before a => operator? */
6717 if (*s == '=' && s[1] == '>' && !pkgname) {
6720 if (gvp || (lex && !off)) {
6721 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6722 /* This is our own scalar, created a few lines
6723 above, so this is safe. */
6725 sv_setpv(sv, PL_tokenbuf);
6726 if (UTF && !IN_BYTES
6727 && is_utf8_string((U8*)PL_tokenbuf, len))
6734 /* If followed by a paren, it's certainly a subroutine. */
6739 while (SPACE_OR_TAB(*d))
6741 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6746 NEXTVAL_NEXTTOKE.opval =
6747 off ? rv2cv_op : pl_yylval.opval;
6749 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6750 else op_free(rv2cv_op), force_next(WORD);
6755 /* If followed by var or block, call it a method (unless sub) */
6757 if ((*s == '$' || *s == '{') && !cv) {
6759 PL_last_lop = PL_oldbufptr;
6760 PL_last_lop_op = OP_METHOD;
6761 if (!PL_lex_allbrackets &&
6762 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6763 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6764 PL_expect = XBLOCKTERM;
6766 return REPORT(METHOD);
6769 /* If followed by a bareword, see if it looks like indir obj. */
6771 if (tmp == 1 && !orig_keyword
6772 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6773 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6776 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6778 sv_setpvn(sv, PL_tokenbuf, len);
6779 if (UTF && !IN_BYTES
6780 && is_utf8_string((U8*)PL_tokenbuf, len))
6782 else SvUTF8_off(sv);
6785 if (tmp == METHOD && !PL_lex_allbrackets &&
6786 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6787 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6791 /* Not a method, so call it a subroutine (if defined) */
6794 /* Check for a constant sub */
6795 if ((sv = cv_const_sv_or_av(cv))) {
6798 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6799 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6800 if (SvTYPE(sv) == SVt_PVAV)
6801 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6804 pl_yylval.opval->op_private = 0;
6805 pl_yylval.opval->op_folded = 1;
6806 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6811 op_free(pl_yylval.opval);
6813 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6814 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6815 PL_last_lop = PL_oldbufptr;
6816 PL_last_lop_op = OP_ENTERSUB;
6817 /* Is there a prototype? */
6821 STRLEN protolen = CvPROTOLEN(cv);
6822 const char *proto = CvPROTO(cv);
6824 proto = S_strip_spaces(aTHX_ proto, &protolen);
6827 if ((optional = *proto == ';'))
6830 while (*proto == ';');
6834 *proto == '$' || *proto == '_'
6835 || *proto == '*' || *proto == '+'
6840 *proto == '\\' && proto[1] && proto[2] == '\0'
6843 UNIPROTO(UNIOPSUB,optional);
6844 if (*proto == '\\' && proto[1] == '[') {
6845 const char *p = proto + 2;
6846 while(*p && *p != ']')
6848 if(*p == ']' && !p[1])
6849 UNIPROTO(UNIOPSUB,optional);
6851 if (*proto == '&' && *s == '{') {
6853 sv_setpvs(PL_subname, "__ANON__");
6855 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6856 if (!PL_lex_allbrackets &&
6857 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6858 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6862 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6864 force_next(off ? PRIVATEREF : WORD);
6865 if (!PL_lex_allbrackets &&
6866 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6867 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6871 /* Call it a bare word */
6873 if (PL_hints & HINT_STRICT_SUBS)
6874 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6877 /* after "print" and similar functions (corresponding to
6878 * "F? L" in opcode.pl), whatever wasn't already parsed as
6879 * a filehandle should be subject to "strict subs".
6880 * Likewise for the optional indirect-object argument to system
6881 * or exec, which can't be a bareword */
6882 if ((PL_last_lop_op == OP_PRINT
6883 || PL_last_lop_op == OP_PRTF
6884 || PL_last_lop_op == OP_SAY
6885 || PL_last_lop_op == OP_SYSTEM
6886 || PL_last_lop_op == OP_EXEC)
6887 && (PL_hints & HINT_STRICT_SUBS))
6888 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6889 if (lastchar != '-') {
6890 if (ckWARN(WARN_RESERVED)) {
6894 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6896 /* PL_warn_reserved is constant */
6897 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6898 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6908 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6909 && saw_infix_sigil) {
6910 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6911 "Operator or semicolon missing before %c%"UTF8f,
6913 UTF8fARG(UTF, strlen(PL_tokenbuf),
6915 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6916 "Ambiguous use of %c resolved as operator %c",
6917 lastchar, lastchar);
6924 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6929 (OP*)newSVOP(OP_CONST, 0,
6930 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6933 case KEY___PACKAGE__:
6935 (OP*)newSVOP(OP_CONST, 0,
6937 ? newSVhek(HvNAME_HEK(PL_curstash))
6944 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6945 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6948 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6950 gv_init(gv,stash,"DATA",4,0);
6953 GvIOp(gv) = newIO();
6954 IoIFP(GvIOp(gv)) = PL_rsfp;
6955 #if defined(HAS_FCNTL) && defined(F_SETFD)
6957 const int fd = PerlIO_fileno(PL_rsfp);
6958 fcntl(fd,F_SETFD,fd >= 3);
6961 /* Mark this internal pseudo-handle as clean */
6962 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6963 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6964 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6966 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6967 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6968 /* if the script was opened in binmode, we need to revert
6969 * it to text mode for compatibility; but only iff it has CRs
6970 * XXX this is a questionable hack at best. */
6971 if (PL_bufend-PL_bufptr > 2
6972 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6975 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6976 loc = PerlIO_tell(PL_rsfp);
6977 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6980 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6982 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6983 #endif /* NETWARE */
6985 PerlIO_seek(PL_rsfp, loc, 0);
6989 #ifdef PERLIO_LAYERS
6992 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6993 else if (IN_ENCODING) {
6999 XPUSHs(_get_encoding());
7001 call_method("name", G_SCALAR);
7005 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7006 Perl_form(aTHX_ ":encoding(%"SVf")",
7019 FUN0OP(CvCLONE(PL_compcv)
7020 ? newOP(OP_RUNCV, 0)
7021 : newPVOP(OP_RUNCV,0,NULL));
7030 if (PL_expect == XSTATE) {
7041 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7042 if ((*s == ':' && s[1] == ':')
7043 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7047 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7051 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7052 UTF8fARG(UTF, len, PL_tokenbuf));
7055 else if (tmp == KEY_require || tmp == KEY_do
7057 /* that's a way to remember we saw "CORE::" */
7069 LOP(OP_ACCEPT,XTERM);
7072 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7077 LOP(OP_ATAN2,XTERM);
7083 LOP(OP_BINMODE,XTERM);
7086 LOP(OP_BLESS,XTERM);
7095 /* We have to disambiguate the two senses of
7096 "continue". If the next token is a '{' then
7097 treat it as the start of a continue block;
7098 otherwise treat it as a control operator.
7108 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7118 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7127 if (!PL_cryptseen) {
7128 PL_cryptseen = TRUE;
7132 LOP(OP_CRYPT,XTERM);
7135 LOP(OP_CHMOD,XTERM);
7138 LOP(OP_CHOWN,XTERM);
7141 LOP(OP_CONNECT,XTERM);
7161 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7163 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7164 && !keyword(PL_tokenbuf + 1, len, 0)) {
7167 force_ident_maybe_lex('&');
7172 if (orig_keyword == KEY_do) {
7181 PL_hints |= HINT_BLOCK_SCOPE;
7191 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7192 STR_WITH_LEN("NDBM_File::"),
7193 STR_WITH_LEN("DB_File::"),
7194 STR_WITH_LEN("GDBM_File::"),
7195 STR_WITH_LEN("SDBM_File::"),
7196 STR_WITH_LEN("ODBM_File::"),
7198 LOP(OP_DBMOPEN,XTERM);
7210 pl_yylval.ival = CopLINE(PL_curcop);
7214 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7226 if (*s == '{') { /* block eval */
7227 PL_expect = XTERMBLOCK;
7228 UNIBRACK(OP_ENTERTRY);
7230 else { /* string eval */
7232 UNIBRACK(OP_ENTEREVAL);
7237 UNIBRACK(-OP_ENTEREVAL);
7251 case KEY_endhostent:
7257 case KEY_endservent:
7260 case KEY_endprotoent:
7271 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7273 pl_yylval.ival = CopLINE(PL_curcop);
7275 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7278 if ((PL_bufend - p) >= 3 &&
7279 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7281 else if ((PL_bufend - p) >= 4 &&
7282 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7285 /* skip optional package name, as in "for my abc $x (..)" */
7286 if (isIDFIRST_lazy_if(p,UTF)) {
7287 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7291 Perl_croak(aTHX_ "Missing $ on loop variable");
7296 LOP(OP_FORMLINE,XTERM);
7305 LOP(OP_FCNTL,XTERM);
7311 LOP(OP_FLOCK,XTERM);
7314 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7319 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7324 LOP(OP_GREPSTART, XREF);
7341 case KEY_getpriority:
7342 LOP(OP_GETPRIORITY,XTERM);
7344 case KEY_getprotobyname:
7347 case KEY_getprotobynumber:
7348 LOP(OP_GPBYNUMBER,XTERM);
7350 case KEY_getprotoent:
7362 case KEY_getpeername:
7363 UNI(OP_GETPEERNAME);
7365 case KEY_gethostbyname:
7368 case KEY_gethostbyaddr:
7369 LOP(OP_GHBYADDR,XTERM);
7371 case KEY_gethostent:
7374 case KEY_getnetbyname:
7377 case KEY_getnetbyaddr:
7378 LOP(OP_GNBYADDR,XTERM);
7383 case KEY_getservbyname:
7384 LOP(OP_GSBYNAME,XTERM);
7386 case KEY_getservbyport:
7387 LOP(OP_GSBYPORT,XTERM);
7389 case KEY_getservent:
7392 case KEY_getsockname:
7393 UNI(OP_GETSOCKNAME);
7395 case KEY_getsockopt:
7396 LOP(OP_GSOCKOPT,XTERM);
7411 pl_yylval.ival = CopLINE(PL_curcop);
7412 Perl_ck_warner_d(aTHX_
7413 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7414 "given is experimental");
7419 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7427 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7429 pl_yylval.ival = CopLINE(PL_curcop);
7433 LOP(OP_INDEX,XTERM);
7439 LOP(OP_IOCTL,XTERM);
7467 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7472 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7486 LOP(OP_LISTEN,XTERM);
7495 s = scan_pat(s,OP_MATCH);
7496 TERM(sublex_start());
7499 LOP(OP_MAPSTART, XREF);
7502 LOP(OP_MKDIR,XTERM);
7505 LOP(OP_MSGCTL,XTERM);
7508 LOP(OP_MSGGET,XTERM);
7511 LOP(OP_MSGRCV,XTERM);
7514 LOP(OP_MSGSND,XTERM);
7519 PL_in_my = (U16)tmp;
7521 if (isIDFIRST_lazy_if(s,UTF)) {
7522 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7523 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7525 if (!FEATURE_LEXSUBS_IS_ENABLED)
7527 "Experimental \"%s\" subs not enabled",
7528 tmp == KEY_my ? "my" :
7529 tmp == KEY_state ? "state" : "our");
7530 Perl_ck_warner_d(aTHX_
7531 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7532 "The lexical_subs feature is experimental");
7535 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7536 if (!PL_in_my_stash) {
7540 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7541 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7542 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7552 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7557 s = tokenize_use(0, s);
7561 if (*s == '(' || (s = skipspace(s), *s == '('))
7564 if (!PL_lex_allbrackets &&
7565 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7566 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7572 if (isIDFIRST_lazy_if(s,UTF)) {
7574 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7576 for (t=d; isSPACE(*t);)
7578 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7580 && !(t[0] == '=' && t[1] == '>')
7581 && !(t[0] == ':' && t[1] == ':')
7582 && !keyword(s, d-s, 0)
7584 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7585 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7586 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7592 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7594 pl_yylval.ival = OP_OR;
7604 LOP(OP_OPEN_DIR,XTERM);
7607 checkcomma(s,PL_tokenbuf,"filehandle");
7611 checkcomma(s,PL_tokenbuf,"filehandle");
7630 s = force_word(s,WORD,FALSE,TRUE);
7632 s = force_strict_version(s);
7636 LOP(OP_PIPE_OP,XTERM);
7639 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7642 COPLINE_SET_FROM_MULTI_END;
7643 pl_yylval.ival = OP_CONST;
7644 TERM(sublex_start());
7651 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7654 COPLINE_SET_FROM_MULTI_END;
7655 PL_expect = XOPERATOR;
7656 if (SvCUR(PL_lex_stuff)) {
7657 int warned_comma = !ckWARN(WARN_QW);
7658 int warned_comment = warned_comma;
7659 d = SvPV_force(PL_lex_stuff, len);
7661 for (; isSPACE(*d) && len; --len, ++d)
7666 if (!warned_comma || !warned_comment) {
7667 for (; !isSPACE(*d) && len; --len, ++d) {
7668 if (!warned_comma && *d == ',') {
7669 Perl_warner(aTHX_ packWARN(WARN_QW),
7670 "Possible attempt to separate words with commas");
7673 else if (!warned_comment && *d == '#') {
7674 Perl_warner(aTHX_ packWARN(WARN_QW),
7675 "Possible attempt to put comments in qw() list");
7681 for (; !isSPACE(*d) && len; --len, ++d)
7684 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7685 words = op_append_elem(OP_LIST, words,
7686 newSVOP(OP_CONST, 0, tokeq(sv)));
7691 words = newNULLLIST();
7692 SvREFCNT_dec_NN(PL_lex_stuff);
7693 PL_lex_stuff = NULL;
7694 PL_expect = XOPERATOR;
7695 pl_yylval.opval = sawparens(words);
7700 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7703 pl_yylval.ival = OP_STRINGIFY;
7704 if (SvIVX(PL_lex_stuff) == '\'')
7705 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7706 TERM(sublex_start());
7709 s = scan_pat(s,OP_QR);
7710 TERM(sublex_start());
7713 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7716 pl_yylval.ival = OP_BACKTICK;
7717 TERM(sublex_start());
7725 s = force_version(s, FALSE);
7727 else if (*s != 'v' || !isDIGIT(s[1])
7728 || (s = force_version(s, TRUE), *s == 'v'))
7730 *PL_tokenbuf = '\0';
7731 s = force_word(s,WORD,TRUE,TRUE);
7732 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7733 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7734 GV_ADD | (UTF ? SVf_UTF8 : 0));
7736 yyerror("<> at require-statement should be quotes");
7738 if (orig_keyword == KEY_require) {
7744 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7746 PL_last_uni = PL_oldbufptr;
7747 PL_last_lop_op = OP_REQUIRE;
7749 return REPORT( (int)REQUIRE );
7758 LOP(OP_RENAME,XTERM);
7767 LOP(OP_RINDEX,XTERM);
7776 UNIDOR(OP_READLINE);
7779 UNIDOR(OP_BACKTICK);
7788 LOP(OP_REVERSE,XTERM);
7791 UNIDOR(OP_READLINK);
7798 if (pl_yylval.opval)
7799 TERM(sublex_start());
7801 TOKEN(1); /* force error */
7804 checkcomma(s,PL_tokenbuf,"filehandle");
7814 LOP(OP_SELECT,XTERM);
7820 LOP(OP_SEMCTL,XTERM);
7823 LOP(OP_SEMGET,XTERM);
7826 LOP(OP_SEMOP,XTERM);
7832 LOP(OP_SETPGRP,XTERM);
7834 case KEY_setpriority:
7835 LOP(OP_SETPRIORITY,XTERM);
7837 case KEY_sethostent:
7843 case KEY_setservent:
7846 case KEY_setprotoent:
7856 LOP(OP_SEEKDIR,XTERM);
7858 case KEY_setsockopt:
7859 LOP(OP_SSOCKOPT,XTERM);
7865 LOP(OP_SHMCTL,XTERM);
7868 LOP(OP_SHMGET,XTERM);
7871 LOP(OP_SHMREAD,XTERM);
7874 LOP(OP_SHMWRITE,XTERM);
7877 LOP(OP_SHUTDOWN,XTERM);
7886 LOP(OP_SOCKET,XTERM);
7888 case KEY_socketpair:
7889 LOP(OP_SOCKPAIR,XTERM);
7892 checkcomma(s,PL_tokenbuf,"subroutine name");
7895 s = force_word(s,WORD,TRUE,TRUE);
7899 LOP(OP_SPLIT,XTERM);
7902 LOP(OP_SPRINTF,XTERM);
7905 LOP(OP_SPLICE,XTERM);
7920 LOP(OP_SUBSTR,XTERM);
7926 char * const tmpbuf = PL_tokenbuf + 1;
7927 expectation attrful;
7928 bool have_name, have_proto;
7929 const int key = tmp;
7930 SV *format_name = NULL;
7935 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7936 (*s == ':' && s[1] == ':'))
7940 attrful = XATTRBLOCK;
7941 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7943 if (key == KEY_format)
7944 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7946 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7948 PL_tokenbuf, len + 1, 0
7950 sv_setpvn(PL_subname, tmpbuf, len);
7952 sv_setsv(PL_subname,PL_curstname);
7953 sv_catpvs(PL_subname,"::");
7954 sv_catpvn(PL_subname,tmpbuf,len);
7956 if (SvUTF8(PL_linestr))
7957 SvUTF8_on(PL_subname);
7964 if (key == KEY_my || key == KEY_our || key==KEY_state)
7967 /* diag_listed_as: Missing name in "%s sub" */
7969 "Missing name in \"%s\"", PL_bufptr);
7971 PL_expect = XTERMBLOCK;
7972 attrful = XATTRTERM;
7973 sv_setpvs(PL_subname,"?");
7977 if (key == KEY_format) {
7979 NEXTVAL_NEXTTOKE.opval
7980 = (OP*)newSVOP(OP_CONST,0, format_name);
7981 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
7987 /* Look for a prototype */
7988 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
7989 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7990 COPLINE_SET_FROM_MULTI_END;
7992 Perl_croak(aTHX_ "Prototype not terminated");
7993 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8001 if (*s == ':' && s[1] != ':')
8002 PL_expect = attrful;
8003 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
8005 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8006 else if (*s != ';' && *s != '}')
8007 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8011 NEXTVAL_NEXTTOKE.opval =
8012 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8013 PL_lex_stuff = NULL;
8018 sv_setpvs(PL_subname, "__ANON__");
8020 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8023 force_ident_maybe_lex('&');
8028 LOP(OP_SYSTEM,XREF);
8031 LOP(OP_SYMLINK,XTERM);
8034 LOP(OP_SYSCALL,XTERM);
8037 LOP(OP_SYSOPEN,XTERM);
8040 LOP(OP_SYSSEEK,XTERM);
8043 LOP(OP_SYSREAD,XTERM);
8046 LOP(OP_SYSWRITE,XTERM);
8051 TERM(sublex_start());
8072 LOP(OP_TRUNCATE,XTERM);
8084 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8086 pl_yylval.ival = CopLINE(PL_curcop);
8090 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8092 pl_yylval.ival = CopLINE(PL_curcop);
8096 LOP(OP_UNLINK,XTERM);
8102 LOP(OP_UNPACK,XTERM);
8105 LOP(OP_UTIME,XTERM);
8111 LOP(OP_UNSHIFT,XTERM);
8114 s = tokenize_use(1, s);
8124 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8126 pl_yylval.ival = CopLINE(PL_curcop);
8127 Perl_ck_warner_d(aTHX_
8128 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8129 "when is experimental");
8133 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8135 pl_yylval.ival = CopLINE(PL_curcop);
8139 PL_hints |= HINT_BLOCK_SCOPE;
8146 LOP(OP_WAITPID,XTERM);
8152 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8153 * we use the same number on EBCDIC */
8154 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8158 if (PL_expect == XOPERATOR) {
8159 if (*s == '=' && !PL_lex_allbrackets &&
8160 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8168 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8170 pl_yylval.ival = OP_XOR;
8179 Looks up an identifier in the pad or in a package
8182 PRIVATEREF if this is a lexical name.
8183 WORD if this belongs to a package.
8186 if we're in a my declaration
8187 croak if they tried to say my($foo::bar)
8188 build the ops for a my() declaration
8189 if it's an access to a my() variable
8190 build ops for access to a my() variable
8191 if in a dq string, and they've said @foo and we can't find @foo
8193 build ops for a bareword
8197 S_pending_ident(pTHX)
8200 const char pit = (char)pl_yylval.ival;
8201 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8202 /* All routes through this function want to know if there is a colon. */
8203 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8205 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8206 "### Pending identifier '%s'\n", PL_tokenbuf); });
8208 /* if we're in a my(), we can't allow dynamics here.
8209 $foo'bar has already been turned into $foo::bar, so
8210 just check for colons.
8212 if it's a legal name, the OP is a PADANY.
8215 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8217 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8218 "variable %s in \"our\"",
8219 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8220 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8224 /* "my" variable %s can't be in a package */
8225 /* PL_no_myglob is constant */
8226 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8227 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8228 PL_in_my == KEY_my ? "my" : "state",
8229 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8231 UTF ? SVf_UTF8 : 0);
8235 pl_yylval.opval = newOP(OP_PADANY, 0);
8236 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8237 UTF ? SVf_UTF8 : 0);
8243 build the ops for accesses to a my() variable.
8248 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8250 if (tmp != NOT_IN_PAD) {
8251 /* might be an "our" variable" */
8252 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8253 /* build ops for a bareword */
8254 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8255 HEK * const stashname = HvNAME_HEK(stash);
8256 SV * const sym = newSVhek(stashname);
8257 sv_catpvs(sym, "::");
8258 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8259 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8260 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8264 ((PL_tokenbuf[0] == '$') ? SVt_PV
8265 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8270 pl_yylval.opval = newOP(OP_PADANY, 0);
8271 pl_yylval.opval->op_targ = tmp;
8277 Whine if they've said @foo in a doublequoted string,
8278 and @foo isn't a variable we can find in the symbol
8281 if (ckWARN(WARN_AMBIGUOUS) &&
8282 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8283 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8284 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8285 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8286 /* DO NOT warn for @- and @+ */
8287 && !( PL_tokenbuf[2] == '\0' &&
8288 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8291 /* Downgraded from fatal to warning 20000522 mjd */
8292 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8293 "Possible unintended interpolation of %"UTF8f
8295 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8299 /* build ops for a bareword */
8300 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8301 newSVpvn_flags(PL_tokenbuf + 1,
8303 UTF ? SVf_UTF8 : 0 ));
8304 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8306 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8307 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8308 | ( UTF ? SVf_UTF8 : 0 ),
8309 ((PL_tokenbuf[0] == '$') ? SVt_PV
8310 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8316 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8318 PERL_ARGS_ASSERT_CHECKCOMMA;
8320 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8321 if (ckWARN(WARN_SYNTAX)) {
8324 for (w = s+2; *w && level; w++) {
8332 /* the list of chars below is for end of statements or
8333 * block / parens, boolean operators (&&, ||, //) and branch
8334 * constructs (or, and, if, until, unless, while, err, for).
8335 * Not a very solid hack... */
8336 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8337 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8338 "%s (...) interpreted as function",name);
8341 while (s < PL_bufend && isSPACE(*s))
8345 while (s < PL_bufend && isSPACE(*s))
8347 if (isIDFIRST_lazy_if(s,UTF)) {
8348 const char * const w = s;
8349 s += UTF ? UTF8SKIP(s) : 1;
8350 while (isWORDCHAR_lazy_if(s,UTF))
8351 s += UTF ? UTF8SKIP(s) : 1;
8352 while (s < PL_bufend && isSPACE(*s))
8357 if (keyword(w, s - w, 0))
8360 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8361 if (gv && GvCVu(gv))
8365 Copy(w, tmpbuf+1, s - w, char);
8367 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8368 if (off != NOT_IN_PAD) return;
8370 Perl_croak(aTHX_ "No comma allowed after %s", what);
8375 /* S_new_constant(): do any overload::constant lookup.
8377 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8378 Best used as sv=new_constant(..., sv, ...).
8379 If s, pv are NULL, calls subroutine with one argument,
8380 and <type> is used with error messages only.
8381 <type> is assumed to be well formed UTF-8 */
8384 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8385 SV *sv, SV *pv, const char *type, STRLEN typelen)
8388 HV * table = GvHV(PL_hintgv); /* ^H */
8393 const char *why1 = "", *why2 = "", *why3 = "";
8395 PERL_ARGS_ASSERT_NEW_CONSTANT;
8396 /* We assume that this is true: */
8397 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8400 /* charnames doesn't work well if there have been errors found */
8401 if (PL_error_count > 0 && *key == 'c')
8403 SvREFCNT_dec_NN(sv);
8404 return &PL_sv_undef;
8407 sv_2mortal(sv); /* Parent created it permanently */
8409 || ! (PL_hints & HINT_LOCALIZE_HH)
8410 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8415 /* Here haven't found what we're looking for. If it is charnames,
8416 * perhaps it needs to be loaded. Try doing that before giving up */
8418 Perl_load_module(aTHX_
8420 newSVpvs("_charnames"),
8421 /* version parameter; no need to specify it, as if
8422 * we get too early a version, will fail anyway,
8423 * not being able to find '_charnames' */
8428 assert(sp == PL_stack_sp);
8429 table = GvHV(PL_hintgv);
8431 && (PL_hints & HINT_LOCALIZE_HH)
8432 && (cvp = hv_fetch(table, key, keylen, FALSE))
8438 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8439 msg = Perl_form(aTHX_
8440 "Constant(%.*s) unknown",
8441 (int)(type ? typelen : len),
8447 why3 = "} is not defined";
8450 msg = Perl_form(aTHX_
8451 /* The +3 is for '\N{'; -4 for that, plus '}' */
8452 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8456 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8457 (int)(type ? typelen : len),
8458 (type ? type: s), why1, why2, why3);
8461 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8462 return SvREFCNT_inc_simple_NN(sv);
8467 pv = newSVpvn_flags(s, len, SVs_TEMP);
8469 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8471 typesv = &PL_sv_undef;
8473 PUSHSTACKi(PERLSI_OVERLOAD);
8485 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8489 /* Check the eval first */
8490 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8492 const char * errstr;
8493 sv_catpvs(errsv, "Propagated");
8494 errstr = SvPV_const(errsv, errlen);
8495 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8497 res = SvREFCNT_inc_simple_NN(sv);
8501 SvREFCNT_inc_simple_void_NN(res);
8510 why1 = "Call to &{$^H{";
8512 why3 = "}} did not return a defined value";
8514 (void)sv_2mortal(sv);
8521 PERL_STATIC_INLINE void
8522 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8523 PERL_ARGS_ASSERT_PARSE_IDENT;
8527 Perl_croak(aTHX_ "%s", ident_too_long);
8528 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8529 /* The UTF-8 case must come first, otherwise things
8530 * like c\N{COMBINING TILDE} would start failing, as the
8531 * isWORDCHAR_A case below would gobble the 'c' up.
8534 char *t = *s + UTF8SKIP(*s);
8535 while (isIDCONT_utf8((U8*)t))
8537 if (*d + (t - *s) > e)
8538 Perl_croak(aTHX_ "%s", ident_too_long);
8539 Copy(*s, *d, t - *s, char);
8543 else if ( isWORDCHAR_A(**s) ) {
8546 } while (isWORDCHAR_A(**s) && *d < e);
8548 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8553 else if (allow_package && **s == ':' && (*s)[1] == ':'
8554 /* Disallow things like Foo::$bar. For the curious, this is
8555 * the code path that triggers the "Bad name after" warning
8556 * when looking for barewords.
8558 && (*s)[2] != '$') {
8568 /* Returns a NUL terminated string, with the length of the string written to
8572 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8575 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8576 bool is_utf8 = cBOOL(UTF);
8578 PERL_ARGS_ASSERT_SCAN_WORD;
8580 parse_ident(&s, &d, e, allow_package, is_utf8);
8587 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8589 I32 herelines = PL_parser->herelines;
8590 SSize_t bracket = -1;
8593 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8594 bool is_utf8 = cBOOL(UTF);
8595 I32 orig_copline = 0, tmp_copline = 0;
8597 PERL_ARGS_ASSERT_SCAN_IDENT;
8599 if (isSPACE(*s) || !*s)
8602 while (isDIGIT(*s)) {
8604 Perl_croak(aTHX_ "%s", ident_too_long);
8609 parse_ident(&s, &d, e, 1, is_utf8);
8614 /* Either a digit variable, or parse_ident() found an identifier
8615 (anything valid as a bareword), so job done and return. */
8616 if (PL_lex_state != LEX_NORMAL)
8617 PL_lex_state = LEX_INTERPENDMAYBE;
8620 if (*s == '$' && s[1] &&
8621 (isIDFIRST_lazy_if(s+1,is_utf8)
8622 || isDIGIT_A((U8)s[1])
8625 || strnEQ(s+1,"::",2)) )
8627 /* Dereferencing a value in a scalar variable.
8628 The alternatives are different syntaxes for a scalar variable.
8629 Using ' as a leading package separator isn't allowed. :: is. */
8632 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8634 bracket = s - SvPVX(PL_linestr);
8636 orig_copline = CopLINE(PL_curcop);
8637 if (s < PL_bufend && isSPACE(*s)) {
8642 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8643 * iff Unicode semantics are to be used. The legal ones are any of:
8644 * a) all ASCII characters except:
8645 * 1) space-type ones, like \t and SPACE;
8648 * The final case currently doesn't get this far in the program, so we
8649 * don't test for it. If that were to change, it would be ok to allow it.
8650 * c) When not under Unicode rules, any upper Latin1 character
8651 * d) Otherwise, when unicode rules are used, all XIDS characters.
8653 * Because all ASCII characters have the same representation whether
8654 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8655 * '{' without knowing if is UTF-8 or not.
8656 * EBCDIC already uses the rules that ASCII platforms will use after the
8657 * deprecation cycle; see comment below about the deprecation. */
8659 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8660 (isGRAPH_A(*(s)) || ((is_utf8) \
8661 ? isIDFIRST_utf8((U8*) (s)) \
8663 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8665 # define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s)) \
8666 && LIKELY(*(s) != '\0') \
8668 || isASCII_utf8((U8*) (s)) \
8669 || isIDFIRST_utf8((U8*) (s))))
8671 if ((s <= PL_bufend - (is_utf8)
8674 && VALID_LEN_ONE_IDENT(s, is_utf8))
8676 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8677 * because often it has no graphic representation. (We can't get to
8678 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8681 ? ! isGRAPH_utf8( (U8*) s)
8682 : (! isGRAPH_L1( (U8) *s)
8683 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8685 /* Split messages for back compat */
8686 if (isCNTRL_A( (U8) *s)) {
8687 deprecate("literal control characters in variable names");
8690 deprecate("literal non-graphic characters in variable names");
8695 const STRLEN skip = UTF8SKIP(s);
8698 for ( i = 0; i < skip; i++ )
8706 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8707 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8711 /* Warn about ambiguous code after unary operators if {...} notation isn't
8712 used. There's no difference in ambiguity; it's merely a heuristic
8713 about when not to warn. */
8714 else if (ck_uni && bracket == -1)
8716 if (bracket != -1) {
8717 /* If we were processing {...} notation then... */
8718 if (isIDFIRST_lazy_if(d,is_utf8)) {
8719 /* if it starts as a valid identifier, assume that it is one.
8720 (the later check for } being at the expected point will trap
8721 cases where this doesn't pan out.) */
8722 d += is_utf8 ? UTF8SKIP(d) : 1;
8723 parse_ident(&s, &d, e, 1, is_utf8);
8725 tmp_copline = CopLINE(PL_curcop);
8726 if (s < PL_bufend && isSPACE(*s)) {
8729 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8730 /* ${foo[0]} and ${foo{bar}} notation. */
8731 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8732 const char * const brack =
8734 ((*s == '[') ? "[...]" : "{...}");
8735 orig_copline = CopLINE(PL_curcop);
8736 CopLINE_set(PL_curcop, tmp_copline);
8737 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8738 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8739 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8740 funny, dest, brack, funny, dest, brack);
8741 CopLINE_set(PL_curcop, orig_copline);
8744 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8745 PL_lex_allbrackets++;
8749 /* Handle extended ${^Foo} variables
8750 * 1999-02-27 mjd-perl-patch@plover.com */
8751 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8755 while (isWORDCHAR(*s) && d < e) {
8759 Perl_croak(aTHX_ "%s", ident_too_long);
8764 tmp_copline = CopLINE(PL_curcop);
8765 if (s < PL_bufend && isSPACE(*s)) {
8769 /* Expect to find a closing } after consuming any trailing whitespace.
8773 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8774 PL_lex_state = LEX_INTERPEND;
8777 if (PL_lex_state == LEX_NORMAL) {
8778 if (ckWARN(WARN_AMBIGUOUS) &&
8779 (keyword(dest, d - dest, 0)
8780 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8782 SV *tmp = newSVpvn_flags( dest, d - dest,
8783 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8786 orig_copline = CopLINE(PL_curcop);
8787 CopLINE_set(PL_curcop, tmp_copline);
8788 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8789 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8790 funny, SVfARG(tmp), funny, SVfARG(tmp));
8791 CopLINE_set(PL_curcop, orig_copline);
8796 /* Didn't find the closing } at the point we expected, so restore
8797 state such that the next thing to process is the opening { and */
8798 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8799 CopLINE_set(PL_curcop, orig_copline);
8800 PL_parser->herelines = herelines;
8804 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8805 PL_lex_state = LEX_INTERPEND;
8810 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8812 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8813 * found in the parse starting at 's', based on the subset that are valid
8814 * in this context input to this routine in 'valid_flags'. Advances s.
8815 * Returns TRUE if the input should be treated as a valid flag, so the next
8816 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8817 * upon first call on the current regex. This routine will set it to any
8818 * charset modifier found. The caller shouldn't change it. This way,
8819 * another charset modifier encountered in the parse can be detected as an
8820 * error, as we have decided to allow only one */
8823 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8825 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8826 if (isWORDCHAR_lazy_if(*s, UTF)) {
8827 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8828 UTF ? SVf_UTF8 : 0);
8830 /* Pretend that it worked, so will continue processing before
8839 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8840 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8841 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8842 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8843 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8844 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8845 case LOCALE_PAT_MOD:
8847 goto multiple_charsets;
8849 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8852 case UNICODE_PAT_MOD:
8854 goto multiple_charsets;
8856 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8859 case ASCII_RESTRICT_PAT_MOD:
8861 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8865 /* Error if previous modifier wasn't an 'a', but if it was, see
8866 * if, and accept, a second occurrence (only) */
8868 || get_regex_charset(*pmfl)
8869 != REGEX_ASCII_RESTRICTED_CHARSET)
8871 goto multiple_charsets;
8873 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8877 case DEPENDS_PAT_MOD:
8879 goto multiple_charsets;
8881 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8890 if (*charset != c) {
8891 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8893 else if (c == 'a') {
8894 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8895 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8898 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8901 /* Pretend that it worked, so will continue processing before dieing */
8907 S_scan_pat(pTHX_ char *start, I32 type)
8911 const char * const valid_flags =
8912 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8913 char charset = '\0'; /* character set modifier */
8914 unsigned int x_mod_count = 0;
8916 PERL_ARGS_ASSERT_SCAN_PAT;
8918 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8920 Perl_croak(aTHX_ "Search pattern not terminated");
8922 pm = (PMOP*)newPMOP(type, 0);
8923 if (PL_multi_open == '?') {
8924 /* This is the only point in the code that sets PMf_ONCE: */
8925 pm->op_pmflags |= PMf_ONCE;
8927 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8928 allows us to restrict the list needed by reset to just the ??
8930 assert(type != OP_TRANS);
8932 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8935 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8938 elements = mg->mg_len / sizeof(PMOP**);
8939 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8940 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8941 mg->mg_len = elements * sizeof(PMOP**);
8942 PmopSTASH_set(pm,PL_curstash);
8946 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8947 * anon CV. False positives like qr/[(?{]/ are harmless */
8949 if (type == OP_QR) {
8951 char *e, *p = SvPV(PL_lex_stuff, len);
8953 for (; p < e; p++) {
8954 if (p[0] == '(' && p[1] == '?'
8955 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8957 pm->op_pmflags |= PMf_HAS_CV;
8961 pm->op_pmflags |= PMf_IS_QR;
8964 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
8965 &s, &charset, &x_mod_count))
8967 /* issue a warning if /c is specified,but /g is not */
8968 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8970 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8971 "Use of /c modifier is meaningless without /g" );
8974 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
8976 PL_lex_op = (OP*)pm;
8977 pl_yylval.ival = OP_MATCH;
8982 S_scan_subst(pTHX_ char *start)
8989 char charset = '\0'; /* character set modifier */
8990 unsigned int x_mod_count = 0;
8993 PERL_ARGS_ASSERT_SCAN_SUBST;
8995 pl_yylval.ival = OP_NULL;
8997 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9000 Perl_croak(aTHX_ "Substitution pattern not terminated");
9004 first_start = PL_multi_start;
9005 first_line = CopLINE(PL_curcop);
9006 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9008 SvREFCNT_dec_NN(PL_lex_stuff);
9009 PL_lex_stuff = NULL;
9010 Perl_croak(aTHX_ "Substitution replacement not terminated");
9012 PL_multi_start = first_start; /* so whole substitution is taken together */
9014 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9018 if (*s == EXEC_PAT_MOD) {
9022 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9023 &s, &charset, &x_mod_count))
9029 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9031 if ((pm->op_pmflags & PMf_CONTINUE)) {
9032 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9036 SV * const repl = newSVpvs("");
9039 pm->op_pmflags |= PMf_EVAL;
9042 sv_catpvs(repl, "eval ");
9044 sv_catpvs(repl, "do ");
9046 sv_catpvs(repl, "{");
9047 sv_catsv(repl, PL_sublex_info.repl);
9048 sv_catpvs(repl, "}");
9050 SvREFCNT_dec(PL_sublex_info.repl);
9051 PL_sublex_info.repl = repl;
9053 if (CopLINE(PL_curcop) != first_line) {
9054 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9055 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9056 CopLINE(PL_curcop) - first_line;
9057 CopLINE_set(PL_curcop, first_line);
9060 PL_lex_op = (OP*)pm;
9061 pl_yylval.ival = OP_SUBST;
9066 S_scan_trans(pTHX_ char *start)
9073 bool nondestruct = 0;
9076 PERL_ARGS_ASSERT_SCAN_TRANS;
9078 pl_yylval.ival = OP_NULL;
9080 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9082 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9086 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9088 SvREFCNT_dec_NN(PL_lex_stuff);
9089 PL_lex_stuff = NULL;
9090 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9093 complement = del = squash = 0;
9097 complement = OPpTRANS_COMPLEMENT;
9100 del = OPpTRANS_DELETE;
9103 squash = OPpTRANS_SQUASH;
9115 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9116 o->op_private &= ~OPpTRANS_ALL;
9117 o->op_private |= del|squash|complement|
9118 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9119 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9122 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9129 Takes a pointer to the first < in <<FOO.
9130 Returns a pointer to the byte following <<FOO.
9132 This function scans a heredoc, which involves different methods
9133 depending on whether we are in a string eval, quoted construct, etc.
9134 This is because PL_linestr could containing a single line of input, or
9135 a whole string being evalled, or the contents of the current quote-
9138 The two basic methods are:
9139 - Steal lines from the input stream
9140 - Scan the heredoc in PL_linestr and remove it therefrom
9142 In a file scope or filtered eval, the first method is used; in a
9143 string eval, the second.
9145 In a quote-like operator, we have to choose between the two,
9146 depending on where we can find a newline. We peek into outer lex-
9147 ing scopes until we find one with a newline in it. If we reach the
9148 outermost lexing scope and it is a file, we use the stream method.
9149 Otherwise it is treated as an eval.
9153 S_scan_heredoc(pTHX_ char *s)
9155 I32 op_type = OP_SCALAR;
9162 const bool infile = PL_rsfp || PL_parser->filtered;
9163 const line_t origline = CopLINE(PL_curcop);
9164 LEXSHARED *shared = PL_parser->lex_shared;
9166 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9169 d = PL_tokenbuf + 1;
9170 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9171 *PL_tokenbuf = '\n';
9173 while (SPACE_OR_TAB(*peek))
9175 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9178 s = delimcpy(d, e, s, PL_bufend, term, &len);
9180 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9186 /* <<\FOO is equivalent to <<'FOO' */
9190 if (!isWORDCHAR_lazy_if(s,UTF))
9191 deprecate("bare << to mean <<\"\"");
9192 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9197 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9198 Perl_croak(aTHX_ "Delimiter for here document is too long");
9201 len = d - PL_tokenbuf;
9203 #ifndef PERL_STRICT_CR
9204 d = strchr(s, '\r');
9206 char * const olds = s;
9208 while (s < PL_bufend) {
9214 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9223 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9228 tmpstr = newSV_type(SVt_PVIV);
9232 SvIV_set(tmpstr, -1);
9234 else if (term == '`') {
9235 op_type = OP_BACKTICK;
9236 SvIV_set(tmpstr, '\\');
9239 PL_multi_start = origline + 1 + PL_parser->herelines;
9240 PL_multi_open = PL_multi_close = '<';
9241 /* inside a string eval or quote-like operator */
9242 if (!infile || PL_lex_inwhat) {
9245 char * const olds = s;
9246 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9247 /* These two fields are not set until an inner lexing scope is
9248 entered. But we need them set here. */
9249 shared->ls_bufptr = s;
9250 shared->ls_linestr = PL_linestr;
9252 /* Look for a newline. If the current buffer does not have one,
9253 peek into the line buffer of the parent lexing scope, going
9254 up as many levels as necessary to find one with a newline
9257 while (!(s = (char *)memchr(
9258 (void *)shared->ls_bufptr, '\n',
9259 SvEND(shared->ls_linestr)-shared->ls_bufptr
9261 shared = shared->ls_prev;
9262 /* shared is only null if we have gone beyond the outermost
9263 lexing scope. In a file, we will have broken out of the
9264 loop in the previous iteration. In an eval, the string buf-
9265 fer ends with "\n;", so the while condition above will have
9266 evaluated to false. So shared can never be null. */
9268 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9269 most lexing scope. In a file, shared->ls_linestr at that
9270 level is just one line, so there is no body to steal. */
9271 if (infile && !shared->ls_prev) {
9277 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9280 linestr = shared->ls_linestr;
9281 bufend = SvEND(linestr);
9283 while (s < bufend - len + 1 &&
9284 memNE(s,PL_tokenbuf,len) ) {
9286 ++PL_parser->herelines;
9288 if (s >= bufend - len + 1) {
9291 sv_setpvn(tmpstr,d+1,s-d);
9293 /* the preceding stmt passes a newline */
9294 PL_parser->herelines++;
9296 /* s now points to the newline after the heredoc terminator.
9297 d points to the newline before the body of the heredoc.
9300 /* We are going to modify linestr in place here, so set
9301 aside copies of the string if necessary for re-evals or
9303 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9304 check shared->re_eval_str. */
9305 if (shared->re_eval_start || shared->re_eval_str) {
9306 /* Set aside the rest of the regexp */
9307 if (!shared->re_eval_str)
9308 shared->re_eval_str =
9309 newSVpvn(shared->re_eval_start,
9310 bufend - shared->re_eval_start);
9311 shared->re_eval_start -= s-d;
9313 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9314 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9315 cx->blk_eval.cur_text == linestr)
9317 cx->blk_eval.cur_text = newSVsv(linestr);
9318 SvSCREAM_on(cx->blk_eval.cur_text);
9320 /* Copy everything from s onwards back to d. */
9321 Move(s,d,bufend-s + 1,char);
9322 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9323 /* Setting PL_bufend only applies when we have not dug deeper
9324 into other scopes, because sublex_done sets PL_bufend to
9325 SvEND(PL_linestr). */
9326 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9333 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9334 term = PL_tokenbuf[1];
9336 linestr_save = PL_linestr; /* must restore this afterwards */
9337 d = s; /* and this */
9338 PL_linestr = newSVpvs("");
9339 PL_bufend = SvPVX(PL_linestr);
9341 PL_bufptr = PL_bufend;
9342 CopLINE_set(PL_curcop,
9343 origline + 1 + PL_parser->herelines);
9344 if (!lex_next_chunk(LEX_NO_TERM)
9345 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9346 /* Simply freeing linestr_save might seem simpler here, as it
9347 does not matter what PL_linestr points to, since we are
9348 about to croak; but in a quote-like op, linestr_save
9349 will have been prospectively freed already, via
9350 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9351 restore PL_linestr. */
9352 SvREFCNT_dec_NN(PL_linestr);
9353 PL_linestr = linestr_save;
9356 CopLINE_set(PL_curcop, origline);
9357 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9358 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9359 /* ^That should be enough to avoid this needing to grow: */
9360 sv_catpvs(PL_linestr, "\n\0");
9361 assert(s == SvPVX(PL_linestr));
9362 PL_bufend = SvEND(PL_linestr);
9365 PL_parser->herelines++;
9366 PL_last_lop = PL_last_uni = NULL;
9367 #ifndef PERL_STRICT_CR
9368 if (PL_bufend - PL_linestart >= 2) {
9369 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9370 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9372 PL_bufend[-2] = '\n';
9374 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9376 else if (PL_bufend[-1] == '\r')
9377 PL_bufend[-1] = '\n';
9379 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9380 PL_bufend[-1] = '\n';
9382 if (*s == term && PL_bufend-s >= len
9383 && memEQ(s,PL_tokenbuf + 1,len)) {
9384 SvREFCNT_dec(PL_linestr);
9385 PL_linestr = linestr_save;
9386 PL_linestart = SvPVX(linestr_save);
9387 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9392 sv_catsv(tmpstr,PL_linestr);
9396 PL_multi_end = origline + PL_parser->herelines;
9397 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9398 SvPV_shrink_to_cur(tmpstr);
9401 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9403 else if (IN_ENCODING)
9404 sv_recode_to_utf8(tmpstr, _get_encoding());
9406 PL_lex_stuff = tmpstr;
9407 pl_yylval.ival = op_type;
9411 SvREFCNT_dec(tmpstr);
9412 CopLINE_set(PL_curcop, origline);
9413 missingterm(PL_tokenbuf + 1);
9417 takes: current position in input buffer
9418 returns: new position in input buffer
9419 side-effects: pl_yylval and lex_op are set.
9424 <<>> read from ARGV without magic open
9425 <FH> read from filehandle
9426 <pkg::FH> read from package qualified filehandle
9427 <pkg'FH> read from package qualified filehandle
9428 <$fh> read from filehandle in $fh
9434 S_scan_inputsymbol(pTHX_ char *start)
9436 char *s = start; /* current position in buffer */
9439 bool nomagicopen = FALSE;
9440 char *d = PL_tokenbuf; /* start of temp holding space */
9441 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9443 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9445 end = strchr(s, '\n');
9448 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9455 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9457 /* die if we didn't have space for the contents of the <>,
9458 or if it didn't end, or if we see a newline
9461 if (len >= (I32)sizeof PL_tokenbuf)
9462 Perl_croak(aTHX_ "Excessively long <> operator");
9464 Perl_croak(aTHX_ "Unterminated <> operator");
9469 Remember, only scalar variables are interpreted as filehandles by
9470 this code. Anything more complex (e.g., <$fh{$num}>) will be
9471 treated as a glob() call.
9472 This code makes use of the fact that except for the $ at the front,
9473 a scalar variable and a filehandle look the same.
9475 if (*d == '$' && d[1]) d++;
9477 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9478 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9479 d += UTF ? UTF8SKIP(d) : 1;
9481 /* If we've tried to read what we allow filehandles to look like, and
9482 there's still text left, then it must be a glob() and not a getline.
9483 Use scan_str to pull out the stuff between the <> and treat it
9484 as nothing more than a string.
9487 if (d - PL_tokenbuf != len) {
9488 pl_yylval.ival = OP_GLOB;
9489 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9491 Perl_croak(aTHX_ "Glob not terminated");
9495 bool readline_overriden = FALSE;
9497 /* we're in a filehandle read situation */
9500 /* turn <> into <ARGV> */
9502 Copy("ARGV",d,5,char);
9504 /* Check whether readline() is overriden */
9505 if ((gv_readline = gv_override("readline",8)))
9506 readline_overriden = TRUE;
9508 /* if <$fh>, create the ops to turn the variable into a
9512 /* try to find it in the pad for this block, otherwise find
9513 add symbol table ops
9515 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9516 if (tmp != NOT_IN_PAD) {
9517 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9518 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9519 HEK * const stashname = HvNAME_HEK(stash);
9520 SV * const sym = sv_2mortal(newSVhek(stashname));
9521 sv_catpvs(sym, "::");
9527 OP * const o = newOP(OP_PADSV, 0);
9529 PL_lex_op = readline_overriden
9530 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9531 op_append_elem(OP_LIST, o,
9532 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9533 : (OP*)newUNOP(OP_READLINE, 0, o);
9541 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9543 PL_lex_op = readline_overriden
9544 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9545 op_append_elem(OP_LIST,
9546 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9547 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9548 : (OP*)newUNOP(OP_READLINE, 0,
9549 newUNOP(OP_RV2SV, 0,
9550 newGVOP(OP_GV, 0, gv)));
9552 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9553 pl_yylval.ival = OP_NULL;
9556 /* If it's none of the above, it must be a literal filehandle
9557 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9559 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9560 PL_lex_op = readline_overriden
9561 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9562 op_append_elem(OP_LIST,
9563 newGVOP(OP_GV, 0, gv),
9564 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9565 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9566 pl_yylval.ival = OP_NULL;
9576 start position in buffer
9577 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9578 only if they are of the open/close form
9579 keep_delims preserve the delimiters around the string
9580 re_reparse compiling a run-time /(?{})/:
9581 collapse // to /, and skip encoding src
9582 delimp if non-null, this is set to the position of
9583 the closing delimiter, or just after it if
9584 the closing and opening delimiters differ
9585 (i.e., the opening delimiter of a substitu-
9587 returns: position to continue reading from buffer
9588 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9589 updates the read buffer.
9591 This subroutine pulls a string out of the input. It is called for:
9592 q single quotes q(literal text)
9593 ' single quotes 'literal text'
9594 qq double quotes qq(interpolate $here please)
9595 " double quotes "interpolate $here please"
9596 qx backticks qx(/bin/ls -l)
9597 ` backticks `/bin/ls -l`
9598 qw quote words @EXPORT_OK = qw( func() $spam )
9599 m// regexp match m/this/
9600 s/// regexp substitute s/this/that/
9601 tr/// string transliterate tr/this/that/
9602 y/// string transliterate y/this/that/
9603 ($*@) sub prototypes sub foo ($)
9604 (stuff) sub attr parameters sub foo : attr(stuff)
9605 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9607 In most of these cases (all but <>, patterns and transliterate)
9608 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9609 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9610 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9613 It skips whitespace before the string starts, and treats the first
9614 character as the delimiter. If the delimiter is one of ([{< then
9615 the corresponding "close" character )]}> is used as the closing
9616 delimiter. It allows quoting of delimiters, and if the string has
9617 balanced delimiters ([{<>}]) it allows nesting.
9619 On success, the SV with the resulting string is put into lex_stuff or,
9620 if that is already non-NULL, into lex_repl. The second case occurs only
9621 when parsing the RHS of the special constructs s/// and tr/// (y///).
9622 For convenience, the terminating delimiter character is stuffed into
9627 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9631 SV *sv; /* scalar value: string */
9632 const char *tmps; /* temp string, used for delimiter matching */
9633 char *s = start; /* current position in the buffer */
9634 char term; /* terminating character */
9635 char *to; /* current position in the sv's data */
9636 I32 brackets = 1; /* bracket nesting level */
9637 bool has_utf8 = FALSE; /* is there any utf8 content? */
9638 I32 termcode; /* terminating char. code */
9639 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9640 STRLEN termlen; /* length of terminating string */
9641 int last_off = 0; /* last position for nesting bracket */
9644 PERL_ARGS_ASSERT_SCAN_STR;
9646 /* skip space before the delimiter */
9651 /* mark where we are, in case we need to report errors */
9654 /* after skipping whitespace, the next character is the terminator */
9657 termcode = termstr[0] = term;
9661 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9662 Copy(s, termstr, termlen, U8);
9663 if (!UTF8_IS_INVARIANT(term))
9667 /* mark where we are */
9668 PL_multi_start = CopLINE(PL_curcop);
9669 PL_multi_open = term;
9670 herelines = PL_parser->herelines;
9672 /* find corresponding closing delimiter */
9673 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9674 termcode = termstr[0] = term = tmps[5];
9676 PL_multi_close = term;
9678 if (PL_multi_open == PL_multi_close) {
9679 keep_bracketed_quoted = FALSE;
9682 /* create a new SV to hold the contents. 79 is the SV's initial length.
9683 What a random number. */
9684 sv = newSV_type(SVt_PVIV);
9686 SvIV_set(sv, termcode);
9687 (void)SvPOK_only(sv); /* validate pointer */
9689 /* move past delimiter and try to read a complete string */
9691 sv_catpvn(sv, s, termlen);
9694 if (IN_ENCODING && !UTF && !re_reparse) {
9698 int offset = s - SvPVX_const(PL_linestr);
9699 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9700 &offset, (char*)termstr, termlen);
9704 if (SvIsCOW(PL_linestr)) {
9705 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9706 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9707 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9708 char *buf = SvPVX(PL_linestr);
9709 bufend_pos = PL_parser->bufend - buf;
9710 bufptr_pos = PL_parser->bufptr - buf;
9711 oldbufptr_pos = PL_parser->oldbufptr - buf;
9712 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9713 linestart_pos = PL_parser->linestart - buf;
9714 last_uni_pos = PL_parser->last_uni
9715 ? PL_parser->last_uni - buf
9717 last_lop_pos = PL_parser->last_lop
9718 ? PL_parser->last_lop - buf
9721 PL_parser->lex_shared->re_eval_start ?
9722 PL_parser->lex_shared->re_eval_start - buf : 0;
9725 sv_force_normal(PL_linestr);
9727 buf = SvPVX(PL_linestr);
9728 PL_parser->bufend = buf + bufend_pos;
9729 PL_parser->bufptr = buf + bufptr_pos;
9730 PL_parser->oldbufptr = buf + oldbufptr_pos;
9731 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9732 PL_parser->linestart = buf + linestart_pos;
9733 if (PL_parser->last_uni)
9734 PL_parser->last_uni = buf + last_uni_pos;
9735 if (PL_parser->last_lop)
9736 PL_parser->last_lop = buf + last_lop_pos;
9737 if (PL_parser->lex_shared->re_eval_start)
9738 PL_parser->lex_shared->re_eval_start =
9739 buf + re_eval_start_pos;
9742 ns = SvPVX_const(PL_linestr) + offset;
9743 svlast = SvEND(sv) - 1;
9745 for (; s < ns; s++) {
9746 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9747 COPLINE_INC_WITH_HERELINES;
9750 goto read_more_line;
9752 /* handle quoted delimiters */
9753 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9755 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9757 if ((svlast-1 - t) % 2) {
9758 if (!keep_bracketed_quoted) {
9761 SvCUR_set(sv, SvCUR(sv) - 1);
9766 if (PL_multi_open == PL_multi_close) {
9772 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9773 /* At here, all closes are "was quoted" one,
9774 so we don't check PL_multi_close. */
9776 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9781 else if (*t == PL_multi_open)
9789 SvCUR_set(sv, w - SvPVX_const(sv));
9791 last_off = w - SvPVX(sv);
9792 if (--brackets <= 0)
9798 SvCUR_set(sv, SvCUR(sv) - 1);
9804 /* extend sv if need be */
9805 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9806 /* set 'to' to the next character in the sv's string */
9807 to = SvPVX(sv)+SvCUR(sv);
9809 /* if open delimiter is the close delimiter read unbridle */
9810 if (PL_multi_open == PL_multi_close) {
9811 for (; s < PL_bufend; s++,to++) {
9812 /* embedded newlines increment the current line number */
9813 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9814 COPLINE_INC_WITH_HERELINES;
9815 /* handle quoted delimiters */
9816 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9817 if (!keep_bracketed_quoted
9819 || (re_reparse && s[1] == '\\'))
9822 else /* any other quotes are simply copied straight through */
9825 /* terminate when run out of buffer (the for() condition), or
9826 have found the terminator */
9827 else if (*s == term) {
9830 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9833 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9839 /* if the terminator isn't the same as the start character (e.g.,
9840 matched brackets), we have to allow more in the quoting, and
9841 be prepared for nested brackets.
9844 /* read until we run out of string, or we find the terminator */
9845 for (; s < PL_bufend; s++,to++) {
9846 /* embedded newlines increment the line count */
9847 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9848 COPLINE_INC_WITH_HERELINES;
9849 /* backslashes can escape the open or closing characters */
9850 if (*s == '\\' && s+1 < PL_bufend) {
9851 if (!keep_bracketed_quoted &&
9852 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9859 /* allow nested opens and closes */
9860 else if (*s == PL_multi_close && --brackets <= 0)
9862 else if (*s == PL_multi_open)
9864 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9869 /* terminate the copied string and update the sv's end-of-string */
9871 SvCUR_set(sv, to - SvPVX_const(sv));
9874 * this next chunk reads more into the buffer if we're not done yet
9878 break; /* handle case where we are done yet :-) */
9880 #ifndef PERL_STRICT_CR
9881 if (to - SvPVX_const(sv) >= 2) {
9882 if ((to[-2] == '\r' && to[-1] == '\n') ||
9883 (to[-2] == '\n' && to[-1] == '\r'))
9887 SvCUR_set(sv, to - SvPVX_const(sv));
9889 else if (to[-1] == '\r')
9892 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9897 /* if we're out of file, or a read fails, bail and reset the current
9898 line marker so we can report where the unterminated string began
9900 COPLINE_INC_WITH_HERELINES;
9901 PL_bufptr = PL_bufend;
9902 if (!lex_next_chunk(0)) {
9904 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9910 /* at this point, we have successfully read the delimited string */
9912 if (!IN_ENCODING || UTF || re_reparse) {
9915 sv_catpvn(sv, s, termlen);
9918 if (has_utf8 || (IN_ENCODING && !re_reparse))
9921 PL_multi_end = CopLINE(PL_curcop);
9922 CopLINE_set(PL_curcop, PL_multi_start);
9923 PL_parser->herelines = herelines;
9925 /* if we allocated too much space, give some back */
9926 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9927 SvLEN_set(sv, SvCUR(sv) + 1);
9928 SvPV_renew(sv, SvLEN(sv));
9931 /* decide whether this is the first or second quoted string we've read
9936 PL_sublex_info.repl = sv;
9939 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9945 takes: pointer to position in buffer
9946 returns: pointer to new position in buffer
9947 side-effects: builds ops for the constant in pl_yylval.op
9949 Read a number in any of the formats that Perl accepts:
9951 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9952 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9953 0b[01](_?[01])* binary integers
9954 0[0-7](_?[0-7])* octal integers
9955 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9956 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9958 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9961 If it reads a number without a decimal point or an exponent, it will
9962 try converting the number to an integer and see if it can do so
9963 without loss of precision.
9967 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9969 const char *s = start; /* current position in buffer */
9970 char *d; /* destination in temp buffer */
9971 char *e; /* end of temp buffer */
9972 NV nv; /* number read, as a double */
9973 SV *sv = NULL; /* place to put the converted number */
9974 bool floatit; /* boolean: int or float? */
9975 const char *lastub = NULL; /* position of last underbar */
9976 static const char* const number_too_long = "Number too long";
9977 /* Hexadecimal floating point.
9979 * In many places (where we have quads and NV is IEEE 754 double)
9980 * we can fit the mantissa bits of a NV into an unsigned quad.
9981 * (Note that UVs might not be quads even when we have quads.)
9982 * This will not work everywhere, though (either no quads, or
9983 * using long doubles), in which case we have to resort to NV,
9984 * which will probably mean horrible loss of precision due to
9985 * multiple fp operations. */
9988 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
9989 # define HEXFP_UQUAD
9990 Uquad_t hexfp_uquad = 0;
9991 int hexfp_frac_bits = 0;
9996 NV hexfp_mult = 1.0;
9997 UV high_non_zero = 0; /* highest digit */
9999 PERL_ARGS_ASSERT_SCAN_NUM;
10001 /* We use the first character to decide what type of number this is */
10005 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10007 /* if it starts with a 0, it could be an octal number, a decimal in
10008 0.13 disguise, or a hexadecimal number, or a binary number. */
10012 u holds the "number so far"
10013 shift the power of 2 of the base
10014 (hex == 4, octal == 3, binary == 1)
10015 overflowed was the number more than we can hold?
10017 Shift is used when we add a digit. It also serves as an "are
10018 we in octal/hex/binary?" indicator to disallow hex characters
10019 when in octal mode.
10024 bool overflowed = FALSE;
10025 bool just_zero = TRUE; /* just plain 0 or binary number? */
10026 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10027 static const char* const bases[5] =
10028 { "", "binary", "", "octal", "hexadecimal" };
10029 static const char* const Bases[5] =
10030 { "", "Binary", "", "Octal", "Hexadecimal" };
10031 static const char* const maxima[5] =
10033 "0b11111111111111111111111111111111",
10037 const char *base, *Base, *max;
10039 /* check for hex */
10040 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10044 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10049 /* check for a decimal in disguise */
10050 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10052 /* so it must be octal */
10059 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10060 "Misplaced _ in number");
10064 base = bases[shift];
10065 Base = Bases[shift];
10066 max = maxima[shift];
10068 /* read the rest of the number */
10070 /* x is used in the overflow test,
10071 b is the digit we're adding on. */
10076 /* if we don't mention it, we're done */
10080 /* _ are ignored -- but warned about if consecutive */
10082 if (lastub && s == lastub + 1)
10083 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10084 "Misplaced _ in number");
10088 /* 8 and 9 are not octal */
10089 case '8': case '9':
10091 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10095 case '2': case '3': case '4':
10096 case '5': case '6': case '7':
10098 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10101 case '0': case '1':
10102 b = *s++ & 15; /* ASCII digit -> value of digit */
10106 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10107 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10108 /* make sure they said 0x */
10111 b = (*s++ & 7) + 9;
10113 /* Prepare to put the digit we have onto the end
10114 of the number so far. We check for overflows.
10120 x = u << shift; /* make room for the digit */
10122 total_bits += shift;
10124 if ((x >> shift) != u
10125 && !(PL_hints & HINT_NEW_BINARY)) {
10128 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10129 "Integer overflow in %s number",
10132 u = x | b; /* add the digit to the end */
10135 n *= nvshift[shift];
10136 /* If an NV has not enough bits in its
10137 * mantissa to represent an UV this summing of
10138 * small low-order numbers is a waste of time
10139 * (because the NV cannot preserve the
10140 * low-order bits anyway): we could just
10141 * remember when did we overflow and in the
10142 * end just multiply n by the right
10147 if (high_non_zero == 0 && b > 0)
10150 /* this could be hexfp, but peek ahead
10151 * to avoid matching ".." */
10152 if (UNLIKELY(HEXFP_PEEK(s))) {
10160 /* if we get here, we had success: make a scalar value from
10165 /* final misplaced underbar check */
10166 if (s[-1] == '_') {
10167 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10170 if (UNLIKELY(HEXFP_PEEK(s))) {
10171 /* Do sloppy (on the underbars) but quick detection
10172 * (and value construction) for hexfp, the decimal
10173 * detection will shortly be more thorough with the
10174 * underbar checks. */
10178 #else /* HEXFP_NV */
10183 NV mult = 1 / 16.0;
10186 while (isXDIGIT(*h) || *h == '_') {
10187 if (isXDIGIT(*h)) {
10188 U8 b = XDIGIT_VALUE(*h);
10189 total_bits += shift;
10191 hexfp_uquad <<= shift;
10193 hexfp_frac_bits += shift;
10194 #else /* HEXFP_NV */
10195 hexfp_nv += b * mult;
10203 if (total_bits >= 4) {
10204 if (high_non_zero < 0x8)
10206 if (high_non_zero < 0x4)
10208 if (high_non_zero < 0x2)
10212 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10213 bool negexp = FALSE;
10217 else if (*h == '-') {
10223 while (isDIGIT(*h) || *h == '_') {
10226 hexfp_exp += *h - '0';
10229 -hexfp_exp < NV_MIN_EXP - 1) {
10230 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10231 "Hexadecimal float: exponent underflow");
10238 hexfp_exp > NV_MAX_EXP - 1) {
10239 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10240 "Hexadecimal float: exponent overflow");
10249 hexfp_exp = -hexfp_exp;
10251 hexfp_exp -= hexfp_frac_bits;
10253 hexfp_mult = pow(2.0, hexfp_exp);
10261 if (n > 4294967295.0)
10262 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10263 "%s number > %s non-portable",
10269 if (u > 0xffffffff)
10270 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10271 "%s number > %s non-portable",
10276 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10277 sv = new_constant(start, s - start, "integer",
10278 sv, NULL, NULL, 0);
10279 else if (PL_hints & HINT_NEW_BINARY)
10280 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10285 handle decimal numbers.
10286 we're also sent here when we read a 0 as the first digit
10288 case '1': case '2': case '3': case '4': case '5':
10289 case '6': case '7': case '8': case '9': case '.':
10292 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10301 /* read next group of digits and _ and copy into d */
10302 while (isDIGIT(*s) || *s == '_' ||
10303 UNLIKELY(hexfp && isXDIGIT(*s))) {
10304 /* skip underscores, checking for misplaced ones
10308 if (lastub && s == lastub + 1)
10309 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10310 "Misplaced _ in number");
10314 /* check for end of fixed-length buffer */
10316 Perl_croak(aTHX_ "%s", number_too_long);
10317 /* if we're ok, copy the character */
10322 /* final misplaced underbar check */
10323 if (lastub && s == lastub + 1) {
10324 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10327 /* read a decimal portion if there is one. avoid
10328 3..5 being interpreted as the number 3. followed
10331 if (*s == '.' && s[1] != '.') {
10336 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10337 "Misplaced _ in number");
10341 /* copy, ignoring underbars, until we run out of digits.
10343 for (; isDIGIT(*s) || *s == '_' ||
10344 UNLIKELY(hexfp && isXDIGIT(*s));
10346 /* fixed length buffer check */
10348 Perl_croak(aTHX_ "%s", number_too_long);
10350 if (lastub && s == lastub + 1)
10351 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10352 "Misplaced _ in number");
10358 /* fractional part ending in underbar? */
10359 if (s[-1] == '_') {
10360 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10361 "Misplaced _ in number");
10363 if (*s == '.' && isDIGIT(s[1])) {
10364 /* oops, it's really a v-string, but without the "v" */
10370 /* read exponent part, if present */
10371 if ((isALPHA_FOLD_EQ(*s, 'e')
10372 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10373 && strchr("+-0123456789_", s[1]))
10377 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10378 ditto for p (hexfloats) */
10379 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10380 /* At least some Mach atof()s don't grok 'E' */
10383 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10390 /* stray preinitial _ */
10392 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10393 "Misplaced _ in number");
10397 /* allow positive or negative exponent */
10398 if (*s == '+' || *s == '-')
10401 /* stray initial _ */
10403 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10404 "Misplaced _ in number");
10408 /* read digits of exponent */
10409 while (isDIGIT(*s) || *s == '_') {
10412 Perl_croak(aTHX_ "%s", number_too_long);
10416 if (((lastub && s == lastub + 1) ||
10417 (!isDIGIT(s[1]) && s[1] != '_')))
10418 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10419 "Misplaced _ in number");
10427 We try to do an integer conversion first if no characters
10428 indicating "float" have been found.
10433 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10435 if (flags == IS_NUMBER_IN_UV) {
10437 sv = newSViv(uv); /* Prefer IVs over UVs. */
10440 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10441 if (uv <= (UV) IV_MIN)
10442 sv = newSViv(-(IV)uv);
10449 STORE_NUMERIC_LOCAL_SET_STANDARD();
10450 /* terminate the string */
10452 if (UNLIKELY(hexfp)) {
10453 # ifdef NV_MANT_DIG
10454 if (total_bits > NV_MANT_DIG)
10455 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10456 "Hexadecimal float: mantissa overflow");
10459 nv = hexfp_uquad * hexfp_mult;
10460 #else /* HEXFP_NV */
10461 nv = hexfp_nv * hexfp_mult;
10464 nv = Atof(PL_tokenbuf);
10466 RESTORE_NUMERIC_LOCAL();
10471 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10472 const char *const key = floatit ? "float" : "integer";
10473 const STRLEN keylen = floatit ? 5 : 7;
10474 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10475 key, keylen, sv, NULL, NULL, 0);
10479 /* if it starts with a v, it could be a v-string */
10482 sv = newSV(5); /* preallocate storage space */
10483 ENTER_with_name("scan_vstring");
10485 s = scan_vstring(s, PL_bufend, sv);
10486 SvREFCNT_inc_simple_void_NN(sv);
10487 LEAVE_with_name("scan_vstring");
10491 /* make the op for the constant and return */
10494 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10496 lvalp->opval = NULL;
10502 S_scan_formline(pTHX_ char *s)
10506 SV * const stuff = newSVpvs("");
10507 bool needargs = FALSE;
10508 bool eofmt = FALSE;
10510 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10512 while (!needargs) {
10515 #ifdef PERL_STRICT_CR
10516 while (SPACE_OR_TAB(*t))
10519 while (SPACE_OR_TAB(*t) || *t == '\r')
10522 if (*t == '\n' || t == PL_bufend) {
10527 eol = (char *) memchr(s,'\n',PL_bufend-s);
10531 for (t = s; t < eol; t++) {
10532 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10534 goto enough; /* ~~ must be first line in formline */
10536 if (*t == '@' || *t == '^')
10540 sv_catpvn(stuff, s, eol-s);
10541 #ifndef PERL_STRICT_CR
10542 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10543 char *end = SvPVX(stuff) + SvCUR(stuff);
10546 SvCUR_set(stuff, SvCUR(stuff) - 1);
10554 if ((PL_rsfp || PL_parser->filtered)
10555 && PL_parser->form_lex_state == LEX_NORMAL) {
10557 PL_bufptr = PL_bufend;
10558 COPLINE_INC_WITH_HERELINES;
10559 got_some = lex_next_chunk(0);
10560 CopLINE_dec(PL_curcop);
10568 if (!SvCUR(stuff) || needargs)
10569 PL_lex_state = PL_parser->form_lex_state;
10570 if (SvCUR(stuff)) {
10571 PL_expect = XSTATE;
10573 const char *s2 = s;
10574 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10578 PL_expect = XTERMBLOCK;
10579 NEXTVAL_NEXTTOKE.ival = 0;
10582 NEXTVAL_NEXTTOKE.ival = 0;
10583 force_next(FORMLBRACK);
10586 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10588 else if (IN_ENCODING)
10589 sv_recode_to_utf8(stuff, _get_encoding());
10591 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10595 SvREFCNT_dec(stuff);
10597 PL_lex_formbrack = 0;
10603 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10605 const I32 oldsavestack_ix = PL_savestack_ix;
10606 CV* const outsidecv = PL_compcv;
10608 SAVEI32(PL_subline);
10609 save_item(PL_subname);
10610 SAVESPTR(PL_compcv);
10612 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10613 CvFLAGS(PL_compcv) |= flags;
10615 PL_subline = CopLINE(PL_curcop);
10616 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10617 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10618 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10619 if (outsidecv && CvPADLIST(outsidecv))
10620 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10622 return oldsavestack_ix;
10626 S_yywarn(pTHX_ const char *const s, U32 flags)
10628 PERL_ARGS_ASSERT_YYWARN;
10630 PL_in_eval |= EVAL_WARNONLY;
10631 yyerror_pv(s, flags);
10636 Perl_yyerror(pTHX_ const char *const s)
10638 PERL_ARGS_ASSERT_YYERROR;
10639 return yyerror_pvn(s, strlen(s), 0);
10643 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10645 PERL_ARGS_ASSERT_YYERROR_PV;
10646 return yyerror_pvn(s, strlen(s), flags);
10650 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10652 const char *context = NULL;
10655 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10656 int yychar = PL_parser->yychar;
10658 PERL_ARGS_ASSERT_YYERROR_PVN;
10660 if (!yychar || (yychar == ';' && !PL_rsfp))
10661 sv_catpvs(where_sv, "at EOF");
10662 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10663 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10664 PL_oldbufptr != PL_bufptr) {
10667 The code below is removed for NetWare because it abends/crashes on NetWare
10668 when the script has error such as not having the closing quotes like:
10669 if ($var eq "value)
10670 Checking of white spaces is anyway done in NetWare code.
10673 while (isSPACE(*PL_oldoldbufptr))
10676 context = PL_oldoldbufptr;
10677 contlen = PL_bufptr - PL_oldoldbufptr;
10679 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10680 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10683 The code below is removed for NetWare because it abends/crashes on NetWare
10684 when the script has error such as not having the closing quotes like:
10685 if ($var eq "value)
10686 Checking of white spaces is anyway done in NetWare code.
10689 while (isSPACE(*PL_oldbufptr))
10692 context = PL_oldbufptr;
10693 contlen = PL_bufptr - PL_oldbufptr;
10695 else if (yychar > 255)
10696 sv_catpvs(where_sv, "next token ???");
10697 else if (yychar == YYEMPTY) {
10698 if (PL_lex_state == LEX_NORMAL ||
10699 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10700 sv_catpvs(where_sv, "at end of line");
10701 else if (PL_lex_inpat)
10702 sv_catpvs(where_sv, "within pattern");
10704 sv_catpvs(where_sv, "within string");
10707 sv_catpvs(where_sv, "next char ");
10709 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10710 else if (isPRINT_LC(yychar)) {
10711 const char string = yychar;
10712 sv_catpvn(where_sv, &string, 1);
10715 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10717 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10718 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10719 OutCopFILE(PL_curcop),
10720 (IV)(PL_parser->preambling == NOLINE
10721 ? CopLINE(PL_curcop)
10722 : PL_parser->preambling));
10724 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10725 UTF8fARG(UTF, contlen, context));
10727 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10728 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10729 Perl_sv_catpvf(aTHX_ msg,
10730 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10731 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10734 if (PL_in_eval & EVAL_WARNONLY) {
10735 PL_in_eval &= ~EVAL_WARNONLY;
10736 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10740 if (PL_error_count >= 10) {
10742 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10743 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10744 SVfARG(errsv), OutCopFILE(PL_curcop));
10746 Perl_croak(aTHX_ "%s has too many errors.\n",
10747 OutCopFILE(PL_curcop));
10750 PL_in_my_stash = NULL;
10755 S_swallow_bom(pTHX_ U8 *s)
10757 const STRLEN slen = SvCUR(PL_linestr);
10759 PERL_ARGS_ASSERT_SWALLOW_BOM;
10763 if (s[1] == 0xFE) {
10764 /* UTF-16 little-endian? (or UTF-32LE?) */
10765 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10766 /* diag_listed_as: Unsupported script encoding %s */
10767 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10768 #ifndef PERL_NO_UTF16_FILTER
10769 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10771 if (PL_bufend > (char*)s) {
10772 s = add_utf16_textfilter(s, TRUE);
10775 /* diag_listed_as: Unsupported script encoding %s */
10776 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10781 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10782 #ifndef PERL_NO_UTF16_FILTER
10783 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10785 if (PL_bufend > (char *)s) {
10786 s = add_utf16_textfilter(s, FALSE);
10789 /* diag_listed_as: Unsupported script encoding %s */
10790 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10794 case BOM_UTF8_FIRST_BYTE: {
10795 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10796 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10797 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10798 s += len + 1; /* UTF-8 */
10805 if (s[2] == 0xFE && s[3] == 0xFF) {
10806 /* UTF-32 big-endian */
10807 /* diag_listed_as: Unsupported script encoding %s */
10808 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10811 else if (s[2] == 0 && s[3] != 0) {
10814 * are a good indicator of UTF-16BE. */
10815 #ifndef PERL_NO_UTF16_FILTER
10816 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10817 s = add_utf16_textfilter(s, FALSE);
10819 /* diag_listed_as: Unsupported script encoding %s */
10820 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10827 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10830 * are a good indicator of UTF-16LE. */
10831 #ifndef PERL_NO_UTF16_FILTER
10832 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10833 s = add_utf16_textfilter(s, TRUE);
10835 /* diag_listed_as: Unsupported script encoding %s */
10836 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10844 #ifndef PERL_NO_UTF16_FILTER
10846 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10848 SV *const filter = FILTER_DATA(idx);
10849 /* We re-use this each time round, throwing the contents away before we
10851 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10852 SV *const utf8_buffer = filter;
10853 IV status = IoPAGE(filter);
10854 const bool reverse = cBOOL(IoLINES(filter));
10857 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10859 /* As we're automatically added, at the lowest level, and hence only called
10860 from this file, we can be sure that we're not called in block mode. Hence
10861 don't bother writing code to deal with block mode. */
10863 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10866 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10868 DEBUG_P(PerlIO_printf(Perl_debug_log,
10869 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10870 FPTR2DPTR(void *, S_utf16_textfilter),
10871 reverse ? 'l' : 'b', idx, maxlen, status,
10872 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10879 /* First, look in our buffer of existing UTF-8 data: */
10880 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10884 } else if (status == 0) {
10886 IoPAGE(filter) = 0;
10887 nl = SvEND(utf8_buffer);
10890 STRLEN got = nl - SvPVX(utf8_buffer);
10891 /* Did we have anything to append? */
10893 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10894 /* Everything else in this code works just fine if SVp_POK isn't
10895 set. This, however, needs it, and we need it to work, else
10896 we loop infinitely because the buffer is never consumed. */
10897 sv_chop(utf8_buffer, nl);
10901 /* OK, not a complete line there, so need to read some more UTF-16.
10902 Read an extra octect if the buffer currently has an odd number. */
10906 if (SvCUR(utf16_buffer) >= 2) {
10907 /* Location of the high octet of the last complete code point.
10908 Gosh, UTF-16 is a pain. All the benefits of variable length,
10909 *coupled* with all the benefits of partial reads and
10911 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10912 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10914 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10918 /* We have the first half of a surrogate. Read more. */
10919 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10922 status = FILTER_READ(idx + 1, utf16_buffer,
10923 160 + (SvCUR(utf16_buffer) & 1));
10924 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10925 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10928 IoPAGE(filter) = status;
10933 chars = SvCUR(utf16_buffer) >> 1;
10934 have = SvCUR(utf8_buffer);
10935 SvGROW(utf8_buffer, have + chars * 3 + 1);
10938 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10939 (U8*)SvPVX_const(utf8_buffer) + have,
10940 chars * 2, &newlen);
10942 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10943 (U8*)SvPVX_const(utf8_buffer) + have,
10944 chars * 2, &newlen);
10946 SvCUR_set(utf8_buffer, have + newlen);
10949 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10950 it's private to us, and utf16_to_utf8{,reversed} take a
10951 (pointer,length) pair, rather than a NUL-terminated string. */
10952 if(SvCUR(utf16_buffer) & 1) {
10953 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10954 SvCUR_set(utf16_buffer, 1);
10956 SvCUR_set(utf16_buffer, 0);
10959 DEBUG_P(PerlIO_printf(Perl_debug_log,
10960 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10962 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10963 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10968 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10970 SV *filter = filter_add(S_utf16_textfilter, NULL);
10972 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10974 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10975 sv_setpvs(filter, "");
10976 IoLINES(filter) = reversed;
10977 IoPAGE(filter) = 1; /* Not EOF */
10979 /* Sadly, we have to return a valid pointer, come what may, so we have to
10980 ignore any error return from this. */
10981 SvCUR_set(PL_linestr, 0);
10982 if (FILTER_READ(0, PL_linestr, 0)) {
10983 SvUTF8_on(PL_linestr);
10985 SvUTF8_on(PL_linestr);
10987 PL_bufend = SvEND(PL_linestr);
10988 return (U8*)SvPVX(PL_linestr);
10993 Returns a pointer to the next character after the parsed
10994 vstring, as well as updating the passed in sv.
10996 Function must be called like
10998 sv = sv_2mortal(newSV(5));
10999 s = scan_vstring(s,e,sv);
11001 where s and e are the start and end of the string.
11002 The sv should already be large enough to store the vstring
11003 passed in, for performance reasons.
11005 This function may croak if fatal warnings are enabled in the
11006 calling scope, hence the sv_2mortal in the example (to prevent
11007 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11013 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11015 const char *pos = s;
11016 const char *start = s;
11018 PERL_ARGS_ASSERT_SCAN_VSTRING;
11020 if (*pos == 'v') pos++; /* get past 'v' */
11021 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11023 if ( *pos != '.') {
11024 /* this may not be a v-string if followed by => */
11025 const char *next = pos;
11026 while (next < e && isSPACE(*next))
11028 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11029 /* return string not v-string */
11030 sv_setpvn(sv,(char *)s,pos-s);
11031 return (char *)pos;
11035 if (!isALPHA(*pos)) {
11036 U8 tmpbuf[UTF8_MAXBYTES+1];
11039 s++; /* get past 'v' */
11044 /* this is atoi() that tolerates underscores */
11047 const char *end = pos;
11049 while (--end >= s) {
11051 const UV orev = rev;
11052 rev += (*end - '0') * mult;
11055 /* diag_listed_as: Integer overflow in %s number */
11056 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11057 "Integer overflow in decimal number");
11061 if (rev > 0x7FFFFFFF)
11062 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11064 /* Append native character for the rev point */
11065 tmpend = uvchr_to_utf8(tmpbuf, rev);
11066 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11067 if (!UVCHR_IS_INVARIANT(rev))
11069 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11075 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11079 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11086 Perl_keyword_plugin_standard(pTHX_
11087 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11089 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11090 PERL_UNUSED_CONTEXT;
11091 PERL_UNUSED_ARG(keyword_ptr);
11092 PERL_UNUSED_ARG(keyword_len);
11093 PERL_UNUSED_ARG(op_ptr);
11094 return KEYWORD_PLUGIN_DECLINE;
11097 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11099 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11101 SAVEI32(PL_lex_brackets);
11102 if (PL_lex_brackets > 100)
11103 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11104 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11105 SAVEI32(PL_lex_allbrackets);
11106 PL_lex_allbrackets = 0;
11107 SAVEI8(PL_lex_fakeeof);
11108 PL_lex_fakeeof = (U8)fakeeof;
11109 if(yyparse(gramtype) && !PL_parser->error_count)
11110 qerror(Perl_mess(aTHX_ "Parse error"));
11113 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11115 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11119 SAVEVPTR(PL_eval_root);
11120 PL_eval_root = NULL;
11121 parse_recdescent(gramtype, fakeeof);
11127 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11129 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11132 if (flags & ~PARSE_OPTIONAL)
11133 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11134 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11135 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11136 if (!PL_parser->error_count)
11137 qerror(Perl_mess(aTHX_ "Parse error"));
11138 exprop = newOP(OP_NULL, 0);
11144 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11146 Parse a Perl arithmetic expression. This may contain operators of precedence
11147 down to the bit shift operators. The expression must be followed (and thus
11148 terminated) either by a comparison or lower-precedence operator or by
11149 something that would normally terminate an expression such as semicolon.
11150 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11151 otherwise it is mandatory. It is up to the caller to ensure that the
11152 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11153 the source of the code to be parsed and the lexical context for the
11156 The op tree representing the expression is returned. If an optional
11157 expression is absent, a null pointer is returned, otherwise the pointer
11160 If an error occurs in parsing or compilation, in most cases a valid op
11161 tree is returned anyway. The error is reflected in the parser state,
11162 normally resulting in a single exception at the top level of parsing
11163 which covers all the compilation errors that occurred. Some compilation
11164 errors, however, will throw an exception immediately.
11170 Perl_parse_arithexpr(pTHX_ U32 flags)
11172 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11176 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11178 Parse a Perl term expression. This may contain operators of precedence
11179 down to the assignment operators. The expression must be followed (and thus
11180 terminated) either by a comma or lower-precedence operator or by
11181 something that would normally terminate an expression such as semicolon.
11182 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11183 otherwise it is mandatory. It is up to the caller to ensure that the
11184 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11185 the source of the code to be parsed and the lexical context for the
11188 The op tree representing the expression is returned. If an optional
11189 expression is absent, a null pointer is returned, otherwise the pointer
11192 If an error occurs in parsing or compilation, in most cases a valid op
11193 tree is returned anyway. The error is reflected in the parser state,
11194 normally resulting in a single exception at the top level of parsing
11195 which covers all the compilation errors that occurred. Some compilation
11196 errors, however, will throw an exception immediately.
11202 Perl_parse_termexpr(pTHX_ U32 flags)
11204 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11208 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11210 Parse a Perl list expression. This may contain operators of precedence
11211 down to the comma operator. The expression must be followed (and thus
11212 terminated) either by a low-precedence logic operator such as C<or> or by
11213 something that would normally terminate an expression such as semicolon.
11214 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11215 otherwise it is mandatory. It is up to the caller to ensure that the
11216 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11217 the source of the code to be parsed and the lexical context for the
11220 The op tree representing the expression is returned. If an optional
11221 expression is absent, a null pointer is returned, otherwise the pointer
11224 If an error occurs in parsing or compilation, in most cases a valid op
11225 tree is returned anyway. The error is reflected in the parser state,
11226 normally resulting in a single exception at the top level of parsing
11227 which covers all the compilation errors that occurred. Some compilation
11228 errors, however, will throw an exception immediately.
11234 Perl_parse_listexpr(pTHX_ U32 flags)
11236 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11240 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11242 Parse a single complete Perl expression. This allows the full
11243 expression grammar, including the lowest-precedence operators such
11244 as C<or>. The expression must be followed (and thus terminated) by a
11245 token that an expression would normally be terminated by: end-of-file,
11246 closing bracketing punctuation, semicolon, or one of the keywords that
11247 signals a postfix expression-statement modifier. If I<flags> includes
11248 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11249 mandatory. It is up to the caller to ensure that the dynamic parser
11250 state (L</PL_parser> et al) is correctly set to reflect the source of
11251 the code to be parsed and the lexical context for the expression.
11253 The op tree representing the expression is returned. If an optional
11254 expression is absent, a null pointer is returned, otherwise the pointer
11257 If an error occurs in parsing or compilation, in most cases a valid op
11258 tree is returned anyway. The error is reflected in the parser state,
11259 normally resulting in a single exception at the top level of parsing
11260 which covers all the compilation errors that occurred. Some compilation
11261 errors, however, will throw an exception immediately.
11267 Perl_parse_fullexpr(pTHX_ U32 flags)
11269 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11273 =for apidoc Amx|OP *|parse_block|U32 flags
11275 Parse a single complete Perl code block. This consists of an opening
11276 brace, a sequence of statements, and a closing brace. The block
11277 constitutes a lexical scope, so C<my> variables and various compile-time
11278 effects can be contained within it. It is up to the caller to ensure
11279 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11280 reflect the source of the code to be parsed and the lexical context for
11283 The op tree representing the code block is returned. This is always a
11284 real op, never a null pointer. It will normally be a C<lineseq> list,
11285 including C<nextstate> or equivalent ops. No ops to construct any kind
11286 of runtime scope are included by virtue of it being a block.
11288 If an error occurs in parsing or compilation, in most cases a valid op
11289 tree (most likely null) is returned anyway. The error is reflected in
11290 the parser state, normally resulting in a single exception at the top
11291 level of parsing which covers all the compilation errors that occurred.
11292 Some compilation errors, however, will throw an exception immediately.
11294 The I<flags> parameter is reserved for future use, and must always
11301 Perl_parse_block(pTHX_ U32 flags)
11304 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11305 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11309 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11311 Parse a single unadorned Perl statement. This may be a normal imperative
11312 statement or a declaration that has compile-time effect. It does not
11313 include any label or other affixture. It is up to the caller to ensure
11314 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11315 reflect the source of the code to be parsed and the lexical context for
11318 The op tree representing the statement is returned. This may be a
11319 null pointer if the statement is null, for example if it was actually
11320 a subroutine definition (which has compile-time side effects). If not
11321 null, it will be ops directly implementing the statement, suitable to
11322 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11323 equivalent op (except for those embedded in a scope contained entirely
11324 within the statement).
11326 If an error occurs in parsing or compilation, in most cases a valid op
11327 tree (most likely null) is returned anyway. The error is reflected in
11328 the parser state, normally resulting in a single exception at the top
11329 level of parsing which covers all the compilation errors that occurred.
11330 Some compilation errors, however, will throw an exception immediately.
11332 The I<flags> parameter is reserved for future use, and must always
11339 Perl_parse_barestmt(pTHX_ U32 flags)
11342 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11343 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11347 =for apidoc Amx|SV *|parse_label|U32 flags
11349 Parse a single label, possibly optional, of the type that may prefix a
11350 Perl statement. It is up to the caller to ensure that the dynamic parser
11351 state (L</PL_parser> et al) is correctly set to reflect the source of
11352 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11353 label is optional, otherwise it is mandatory.
11355 The name of the label is returned in the form of a fresh scalar. If an
11356 optional label is absent, a null pointer is returned.
11358 If an error occurs in parsing, which can only occur if the label is
11359 mandatory, a valid label is returned anyway. The error is reflected in
11360 the parser state, normally resulting in a single exception at the top
11361 level of parsing which covers all the compilation errors that occurred.
11367 Perl_parse_label(pTHX_ U32 flags)
11369 if (flags & ~PARSE_OPTIONAL)
11370 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11371 if (PL_lex_state == LEX_KNOWNEXT) {
11372 PL_parser->yychar = yylex();
11373 if (PL_parser->yychar == LABEL) {
11374 char * const lpv = pl_yylval.pval;
11375 STRLEN llen = strlen(lpv);
11376 PL_parser->yychar = YYEMPTY;
11377 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11384 STRLEN wlen, bufptr_pos;
11387 if (!isIDFIRST_lazy_if(s, UTF))
11389 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11390 if (word_takes_any_delimeter(s, wlen))
11392 bufptr_pos = s - SvPVX(PL_linestr);
11394 lex_read_space(LEX_KEEP_PREVIOUS);
11396 s = SvPVX(PL_linestr) + bufptr_pos;
11397 if (t[0] == ':' && t[1] != ':') {
11398 PL_oldoldbufptr = PL_oldbufptr;
11401 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11405 if (flags & PARSE_OPTIONAL) {
11408 qerror(Perl_mess(aTHX_ "Parse error"));
11409 return newSVpvs("x");
11416 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11418 Parse a single complete Perl statement. This may be a normal imperative
11419 statement or a declaration that has compile-time effect, and may include
11420 optional labels. It is up to the caller to ensure that the dynamic
11421 parser state (L</PL_parser> et al) is correctly set to reflect the source
11422 of the code to be parsed and the lexical context for the statement.
11424 The op tree representing the statement is returned. This may be a
11425 null pointer if the statement is null, for example if it was actually
11426 a subroutine definition (which has compile-time side effects). If not
11427 null, it will be the result of a L</newSTATEOP> call, normally including
11428 a C<nextstate> or equivalent op.
11430 If an error occurs in parsing or compilation, in most cases a valid op
11431 tree (most likely null) is returned anyway. The error is reflected in
11432 the parser state, normally resulting in a single exception at the top
11433 level of parsing which covers all the compilation errors that occurred.
11434 Some compilation errors, however, will throw an exception immediately.
11436 The I<flags> parameter is reserved for future use, and must always
11443 Perl_parse_fullstmt(pTHX_ U32 flags)
11446 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11447 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11451 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11453 Parse a sequence of zero or more Perl statements. These may be normal
11454 imperative statements, including optional labels, or declarations
11455 that have compile-time effect, or any mixture thereof. The statement
11456 sequence ends when a closing brace or end-of-file is encountered in a
11457 place where a new statement could have validly started. It is up to
11458 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11459 is correctly set to reflect the source of the code to be parsed and the
11460 lexical context for the statements.
11462 The op tree representing the statement sequence is returned. This may
11463 be a null pointer if the statements were all null, for example if there
11464 were no statements or if there were only subroutine definitions (which
11465 have compile-time side effects). If not null, it will be a C<lineseq>
11466 list, normally including C<nextstate> or equivalent ops.
11468 If an error occurs in parsing or compilation, in most cases a valid op
11469 tree is returned anyway. The error is reflected in the parser state,
11470 normally resulting in a single exception at the top level of parsing
11471 which covers all the compilation errors that occurred. Some compilation
11472 errors, however, will throw an exception immediately.
11474 The I<flags> parameter is reserved for future use, and must always
11481 Perl_parse_stmtseq(pTHX_ U32 flags)
11486 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11487 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11488 c = lex_peek_unichar(0);
11489 if (c != -1 && c != /*{*/'}')
11490 qerror(Perl_mess(aTHX_ "Parse error"));
11494 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11496 S_lex_token_boundary(pTHX)
11498 PL_oldoldbufptr = PL_oldbufptr;
11499 PL_oldbufptr = PL_bufptr;
11502 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11504 S_parse_opt_lexvar(pTHX)
11509 lex_token_boundary();
11510 sigil = lex_read_unichar(0);
11511 if (lex_peek_unichar(0) == '#') {
11512 qerror(Perl_mess(aTHX_ "Parse error"));
11516 c = lex_peek_unichar(0);
11517 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11520 d = PL_tokenbuf + 1;
11521 PL_tokenbuf[0] = (char)sigil;
11522 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11524 if (d == PL_tokenbuf+1)
11526 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11527 OPf_MOD | (OPpLVAL_INTRO<<8));
11528 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11533 Perl_parse_subsignature(pTHX)
11536 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11537 OP *initops = NULL;
11539 c = lex_peek_unichar(0);
11540 while (c != /*(*/')') {
11544 if (prev_type == 2)
11545 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11546 var = parse_opt_lexvar();
11548 newBINOP(OP_AELEM, 0,
11549 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11551 newSVOP(OP_CONST, 0, newSViv(pos))) :
11554 c = lex_peek_unichar(0);
11556 lex_token_boundary();
11557 lex_read_unichar(0);
11559 c = lex_peek_unichar(0);
11560 if (c == ',' || c == /*(*/')') {
11562 qerror(Perl_mess(aTHX_ "Optional parameter "
11563 "lacks default expression"));
11565 OP *defexpr = parse_termexpr(0);
11566 if (defexpr->op_type == OP_UNDEF &&
11567 !(defexpr->op_flags & OPf_KIDS)) {
11572 scalar(newUNOP(OP_RV2AV, 0,
11573 newGVOP(OP_GV, 0, PL_defgv))),
11574 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11576 newCONDOP(0, ifop, expr, defexpr) :
11577 newLOGOP(OP_OR, 0, ifop, defexpr);
11582 if (prev_type == 1)
11583 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11584 "follows optional parameter"));
11586 min_arity = pos + 1;
11588 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11590 initops = op_append_list(OP_LINESEQ, initops,
11591 newSTATEOP(0, NULL, expr));
11597 if (prev_type == 2)
11598 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11599 var = parse_opt_lexvar();
11601 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11602 newBINOP(OP_BIT_AND, 0,
11603 scalar(newUNOP(OP_RV2AV, 0,
11604 newGVOP(OP_GV, 0, PL_defgv))),
11605 newSVOP(OP_CONST, 0, newSViv(1))),
11606 op_convert_list(OP_DIE, 0,
11607 op_convert_list(OP_SPRINTF, 0,
11608 op_append_list(OP_LIST,
11609 newSVOP(OP_CONST, 0,
11610 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11612 op_append_list(OP_LIST,
11613 newSVOP(OP_CONST, 0, newSViv(1)),
11614 newSVOP(OP_CONST, 0, newSViv(2))),
11615 newOP(OP_CALLER, 0))))));
11616 if (pos != min_arity)
11617 chkop = newLOGOP(OP_AND, 0,
11619 scalar(newUNOP(OP_RV2AV, 0,
11620 newGVOP(OP_GV, 0, PL_defgv))),
11621 newSVOP(OP_CONST, 0, newSViv(pos))),
11623 initops = op_append_list(OP_LINESEQ,
11624 newSTATEOP(0, NULL, chkop),
11629 op_prepend_elem(OP_ASLICE,
11630 newOP(OP_PUSHMARK, 0),
11631 newLISTOP(OP_ASLICE, 0,
11633 newSVOP(OP_CONST, 0, newSViv(pos)),
11634 newUNOP(OP_AV2ARYLEN, 0,
11635 ref(newUNOP(OP_RV2AV, 0,
11636 newGVOP(OP_GV, 0, PL_defgv)),
11638 ref(newUNOP(OP_RV2AV, 0,
11639 newGVOP(OP_GV, 0, PL_defgv)),
11641 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11642 initops = op_append_list(OP_LINESEQ, initops,
11643 newSTATEOP(0, NULL,
11644 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11651 qerror(Perl_mess(aTHX_ "Parse error"));
11655 c = lex_peek_unichar(0);
11657 case /*(*/')': break;
11660 lex_token_boundary();
11661 lex_read_unichar(0);
11663 c = lex_peek_unichar(0);
11664 } while (c == ',');
11670 if (min_arity != 0) {
11671 initops = op_append_list(OP_LINESEQ,
11672 newSTATEOP(0, NULL,
11675 scalar(newUNOP(OP_RV2AV, 0,
11676 newGVOP(OP_GV, 0, PL_defgv))),
11677 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11678 op_convert_list(OP_DIE, 0,
11679 op_convert_list(OP_SPRINTF, 0,
11680 op_append_list(OP_LIST,
11681 newSVOP(OP_CONST, 0,
11682 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11684 op_append_list(OP_LIST,
11685 newSVOP(OP_CONST, 0, newSViv(1)),
11686 newSVOP(OP_CONST, 0, newSViv(2))),
11687 newOP(OP_CALLER, 0))))))),
11690 if (max_arity != -1) {
11691 initops = op_append_list(OP_LINESEQ,
11692 newSTATEOP(0, NULL,
11695 scalar(newUNOP(OP_RV2AV, 0,
11696 newGVOP(OP_GV, 0, PL_defgv))),
11697 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11698 op_convert_list(OP_DIE, 0,
11699 op_convert_list(OP_SPRINTF, 0,
11700 op_append_list(OP_LIST,
11701 newSVOP(OP_CONST, 0,
11702 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11704 op_append_list(OP_LIST,
11705 newSVOP(OP_CONST, 0, newSViv(1)),
11706 newSVOP(OP_CONST, 0, newSViv(2))),
11707 newOP(OP_CALLER, 0))))))),
11715 * c-indentation-style: bsd
11716 * c-basic-offset: 4
11717 * indent-tabs-mode: nil
11720 * ex: set ts=8 sts=4 sw=4 et: