3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_sublex_info (PL_parser->sublex_info)
69 #define PL_linestr (PL_parser->linestr)
70 #define PL_expect (PL_parser->expect)
71 #define PL_copline (PL_parser->copline)
72 #define PL_bufptr (PL_parser->bufptr)
73 #define PL_oldbufptr (PL_parser->oldbufptr)
74 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
75 #define PL_linestart (PL_parser->linestart)
76 #define PL_bufend (PL_parser->bufend)
77 #define PL_last_uni (PL_parser->last_uni)
78 #define PL_last_lop (PL_parser->last_lop)
79 #define PL_last_lop_op (PL_parser->last_lop_op)
80 #define PL_lex_state (PL_parser->lex_state)
81 #define PL_rsfp (PL_parser->rsfp)
82 #define PL_rsfp_filters (PL_parser->rsfp_filters)
83 #define PL_in_my (PL_parser->in_my)
84 #define PL_in_my_stash (PL_parser->in_my_stash)
85 #define PL_tokenbuf (PL_parser->tokenbuf)
86 #define PL_multi_end (PL_parser->multi_end)
87 #define PL_error_count (PL_parser->error_count)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_nexttype (PL_parser->nexttype)
91 # define PL_nextval (PL_parser->nextval)
93 static const char* const ident_too_long = "Identifier too long";
95 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
97 #define XENUMMASK 0x3f
99 #define XFAKEBRACK 0x80
101 #ifdef USE_UTF8_SCRIPTS
102 # define UTF cBOOL(!IN_BYTES)
104 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
107 /* The maximum number of characters preceding the unrecognized one to display */
108 #define UNRECOGNIZED_PRECEDE_COUNT 10
110 /* In variables named $^X, these are the legal values for X.
111 * 1999-02-27 mjd-perl-patch@plover.com */
112 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
114 #define SPACE_OR_TAB(c) isBLANK_A(c)
116 #define HEXFP_PEEK(s) \
118 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
119 isALPHA_FOLD_EQ(s[0], 'p'))
121 /* LEX_* are values for PL_lex_state, the state of the lexer.
122 * They are arranged oddly so that the guard on the switch statement
123 * can get by with a single comparison (if the compiler is smart enough).
125 * These values refer to the various states within a sublex parse,
126 * i.e. within a double quotish string
129 /* #define LEX_NOTPARSING 11 is done in perl.h. */
131 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
132 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
133 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
134 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
135 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
137 /* at end of code, eg "$x" followed by: */
138 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
139 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
141 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
142 string or after \E, $foo, etc */
143 #define LEX_INTERPCONST 2 /* NOT USED */
144 #define LEX_FORMLINE 1 /* expecting a format line */
145 #define LEX_KNOWNEXT 0 /* next token known; just return it */
149 static const char* const lex_state_names[] = {
164 #include "keywords.h"
166 /* CLINE is a macro that ensures PL_copline has a sane value */
168 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 * Convenience functions to return different tokens and prime the
172 * lexer for the next token. They all take an argument.
174 * TOKEN : generic token (used for '(', DOLSHARP, etc)
175 * OPERATOR : generic operator
176 * AOPERATOR : assignment operator
177 * PREBLOCK : beginning the block after an if, while, foreach, ...
178 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
179 * PREREF : *EXPR where EXPR is not a simple identifier
180 * TERM : expression term
181 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
182 * LOOPX : loop exiting command (goto, last, dump, etc)
183 * FTST : file test operator
184 * FUN0 : zero-argument function
185 * FUN0OP : zero-argument function, with its op created in this file
186 * FUN1 : not used, except for not, which isn't a UNIOP
187 * BOop : bitwise or or xor
189 * BCop : bitwise complement
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
194 * AopNOASSIGN : addition-level operator that is never part of .=
195 * Mop : multiplication-level operator
196 * Eop : equality-testing operator
197 * Rop : relational operator <= != gt
199 * Also see LOP and lop() below.
202 #ifdef DEBUGGING /* Serve -DT. */
203 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
205 # define REPORT(retval) (retval)
208 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
209 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
210 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
211 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
213 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
214 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
215 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
216 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
218 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
220 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
221 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
222 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
223 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
224 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
225 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
226 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
228 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
229 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
230 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
231 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
232 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
233 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
234 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
235 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
237 /* This bit of chicanery makes a unary function followed by
238 * a parenthesis into a function with one argument, highest precedence.
239 * The UNIDOR macro is for unary functions that can be followed by the //
240 * operator (such as C<shift // 0>).
242 #define UNI3(f,x,have_x) { \
243 pl_yylval.ival = f; \
244 if (have_x) PL_expect = x; \
246 PL_last_uni = PL_oldbufptr; \
247 PL_last_lop_op = f; \
249 return REPORT( (int)FUNC1 ); \
251 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
253 #define UNI(f) UNI3(f,XTERM,1)
254 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
255 #define UNIPROTO(f,optional) { \
256 if (optional) PL_last_uni = PL_oldbufptr; \
260 #define UNIBRACK(f) UNI3(f,0,0)
262 /* grandfather return to old style */
265 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
266 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
267 pl_yylval.ival = (f); \
273 #define COPLINE_INC_WITH_HERELINES \
275 CopLINE_inc(PL_curcop); \
276 if (PL_parser->herelines) \
277 CopLINE(PL_curcop) += PL_parser->herelines, \
278 PL_parser->herelines = 0; \
280 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
281 * is no sublex_push to follow. */
282 #define COPLINE_SET_FROM_MULTI_END \
284 CopLINE_set(PL_curcop, PL_multi_end); \
285 if (PL_multi_end != PL_multi_start) \
286 PL_parser->herelines = 0; \
292 /* how to interpret the pl_yylval associated with the token */
296 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
301 static struct debug_tokens {
303 enum token_type type;
305 } const debug_tokens[] =
307 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
308 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
309 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
310 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
311 { ARROW, TOKENTYPE_NONE, "ARROW" },
312 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
313 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
314 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
315 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
316 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
317 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
318 { DO, TOKENTYPE_NONE, "DO" },
319 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
320 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
321 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
322 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
323 { ELSE, TOKENTYPE_NONE, "ELSE" },
324 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
325 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
326 { FOR, TOKENTYPE_IVAL, "FOR" },
327 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
328 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
329 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
330 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
331 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
332 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
333 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
334 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
335 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
336 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
337 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
338 { IF, TOKENTYPE_IVAL, "IF" },
339 { LABEL, TOKENTYPE_PVAL, "LABEL" },
340 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
341 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
342 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
343 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
344 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
345 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
346 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
347 { MY, TOKENTYPE_IVAL, "MY" },
348 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
349 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
350 { OROP, TOKENTYPE_IVAL, "OROP" },
351 { OROR, TOKENTYPE_NONE, "OROR" },
352 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
353 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
354 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
355 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
356 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
357 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
358 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
359 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
360 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
361 { PREINC, TOKENTYPE_NONE, "PREINC" },
362 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
363 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
364 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
365 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
366 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
367 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
368 { SUB, TOKENTYPE_NONE, "SUB" },
369 { THING, TOKENTYPE_OPVAL, "THING" },
370 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
371 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
372 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
373 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
374 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
375 { USE, TOKENTYPE_IVAL, "USE" },
376 { WHEN, TOKENTYPE_IVAL, "WHEN" },
377 { WHILE, TOKENTYPE_IVAL, "WHILE" },
378 { WORD, TOKENTYPE_OPVAL, "WORD" },
379 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
380 { 0, TOKENTYPE_NONE, NULL }
383 /* dump the returned token in rv, plus any optional arg in pl_yylval */
386 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
388 PERL_ARGS_ASSERT_TOKEREPORT;
391 const char *name = NULL;
392 enum token_type type = TOKENTYPE_NONE;
393 const struct debug_tokens *p;
394 SV* const report = newSVpvs("<== ");
396 for (p = debug_tokens; p->token; p++) {
397 if (p->token == (int)rv) {
404 Perl_sv_catpv(aTHX_ report, name);
405 else if (isGRAPH(rv))
407 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
409 sv_catpvs(report, " (pending identifier)");
412 sv_catpvs(report, "EOF");
414 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
419 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
421 case TOKENTYPE_OPNUM:
422 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
423 PL_op_name[lvalp->ival]);
426 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
428 case TOKENTYPE_OPVAL:
430 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
431 PL_op_name[lvalp->opval->op_type]);
432 if (lvalp->opval->op_type == OP_CONST) {
433 Perl_sv_catpvf(aTHX_ report, " %s",
434 SvPEEK(cSVOPx_sv(lvalp->opval)));
439 sv_catpvs(report, "(opval=null)");
442 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
448 /* print the buffer with suitable escapes */
451 S_printbuf(pTHX_ const char *const fmt, const char *const s)
453 SV* const tmp = newSVpvs("");
455 PERL_ARGS_ASSERT_PRINTBUF;
457 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
458 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
466 S_deprecate_commaless_var_list(pTHX) {
468 deprecate("comma-less variable list");
469 return REPORT(','); /* grandfather non-comma-format format */
475 * This subroutine looks for an '=' next to the operator that has just been
476 * parsed and turns it into an ASSIGNOP if it finds one.
480 S_ao(pTHX_ int toketype)
482 if (*PL_bufptr == '=') {
484 if (toketype == ANDAND)
485 pl_yylval.ival = OP_ANDASSIGN;
486 else if (toketype == OROR)
487 pl_yylval.ival = OP_ORASSIGN;
488 else if (toketype == DORDOR)
489 pl_yylval.ival = OP_DORASSIGN;
492 return REPORT(toketype);
497 * When Perl expects an operator and finds something else, no_op
498 * prints the warning. It always prints "<something> found where
499 * operator expected. It prints "Missing semicolon on previous line?"
500 * if the surprise occurs at the start of the line. "do you need to
501 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
502 * where the compiler doesn't know if foo is a method call or a function.
503 * It prints "Missing operator before end of line" if there's nothing
504 * after the missing operator, or "... before <...>" if there is something
505 * after the missing operator.
507 * PL_bufptr is expected to point to the start of the thing that was found,
508 * and s after the next token or partial token.
512 S_no_op(pTHX_ const char *const what, char *s)
514 char * const oldbp = PL_bufptr;
515 const bool is_first = (PL_oldbufptr == PL_linestart);
517 PERL_ARGS_ASSERT_NO_OP;
523 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
524 if (ckWARN_d(WARN_SYNTAX)) {
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
527 "\t(Missing semicolon on previous line?)\n");
528 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
530 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
531 t += UTF ? UTF8SKIP(t) : 1)
533 if (t < PL_bufptr && isSPACE(*t))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Do you need to predeclare %"UTF8f"?)\n",
536 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing operator before %"UTF8f"?)\n",
542 UTF8fARG(UTF, s - oldbp, oldbp));
550 * Complain about missing quote/regexp/heredoc terminator.
551 * If it's called with NULL then it cauterizes the line buffer.
552 * If we're in a delimited string and the delimiter is a control
553 * character, it's reformatted into a two-char sequence like ^C.
558 S_missingterm(pTHX_ char *s)
563 char * const nl = strrchr(s,'\n');
567 else if ((U8) PL_multi_close < 32) {
569 tmpbuf[1] = (char)toCTRL(PL_multi_close);
574 *tmpbuf = (char)PL_multi_close;
578 q = strchr(s,'"') ? '\'' : '"';
579 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
585 * Check whether the named feature is enabled.
588 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
590 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
592 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
594 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
596 if (namelen > MAX_FEATURE_LEN)
598 memcpy(&he_name[8], name, namelen);
600 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
601 REFCOUNTED_HE_EXISTS));
605 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
606 * utf16-to-utf8-reversed.
609 #ifdef PERL_CR_FILTER
613 const char *s = SvPVX_const(sv);
614 const char * const e = s + SvCUR(sv);
616 PERL_ARGS_ASSERT_STRIP_RETURN;
618 /* outer loop optimized to do nothing if there are no CR-LFs */
620 if (*s++ == '\r' && *s == '\n') {
621 /* hit a CR-LF, need to copy the rest */
625 if (*s == '\r' && s[1] == '\n')
636 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
639 if (count > 0 && !maxlen)
646 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
648 Creates and initialises a new lexer/parser state object, supplying
649 a context in which to lex and parse from a new source of Perl code.
650 A pointer to the new state object is placed in L</PL_parser>. An entry
651 is made on the save stack so that upon unwinding the new state object
652 will be destroyed and the former value of L</PL_parser> will be restored.
653 Nothing else need be done to clean up the parsing context.
655 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
656 non-null, provides a string (in SV form) containing code to be parsed.
657 A copy of the string is made, so subsequent modification of C<line>
658 does not affect parsing. C<rsfp>, if non-null, provides an input stream
659 from which code will be read to be parsed. If both are non-null, the
660 code in C<line> comes first and must consist of complete lines of input,
661 and C<rsfp> supplies the remainder of the source.
663 The C<flags> parameter is reserved for future use. Currently it is only
664 used by perl internally, so extensions should always pass zero.
669 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
670 can share filters with the current parser.
671 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
672 caller, hence isn't owned by the parser, so shouldn't be closed on parser
673 destruction. This is used to handle the case of defaulting to reading the
674 script from the standard input because no filename was given on the command
675 line (without getting confused by situation where STDIN has been closed, so
676 the script handle is opened on fd 0) */
679 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
681 const char *s = NULL;
682 yy_parser *parser, *oparser;
683 if (flags && flags & ~LEX_START_FLAGS)
684 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
686 /* create and initialise a parser */
688 Newxz(parser, 1, yy_parser);
689 parser->old_parser = oparser = PL_parser;
692 parser->stack = NULL;
694 parser->stack_size = 0;
696 /* on scope exit, free this parser and restore any outer one */
698 parser->saved_curcop = PL_curcop;
700 /* initialise lexer state */
702 parser->nexttoke = 0;
703 parser->error_count = oparser ? oparser->error_count : 0;
704 parser->copline = parser->preambling = NOLINE;
705 parser->lex_state = LEX_NORMAL;
706 parser->expect = XSTATE;
708 parser->rsfp_filters =
709 !(flags & LEX_START_SAME_FILTER) || !oparser
711 : MUTABLE_AV(SvREFCNT_inc(
712 oparser->rsfp_filters
713 ? oparser->rsfp_filters
714 : (oparser->rsfp_filters = newAV())
717 Newx(parser->lex_brackstack, 120, char);
718 Newx(parser->lex_casestack, 12, char);
719 *parser->lex_casestack = '\0';
720 Newxz(parser->lex_shared, 1, LEXSHARED);
724 s = SvPV_const(line, len);
725 parser->linestr = flags & LEX_START_COPIED
726 ? SvREFCNT_inc_simple_NN(line)
727 : newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
730 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
732 parser->oldoldbufptr =
735 parser->linestart = SvPVX(parser->linestr);
736 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
737 parser->last_lop = parser->last_uni = NULL;
739 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
740 |LEX_DONT_CLOSE_RSFP));
741 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
742 |LEX_DONT_CLOSE_RSFP));
744 parser->in_pod = parser->filtered = 0;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser
761 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
764 SvREFCNT_dec(parser->lex_stuff);
765 SvREFCNT_dec(parser->sublex_info.repl);
767 Safefree(parser->lex_brackstack);
768 Safefree(parser->lex_casestack);
769 Safefree(parser->lex_shared);
770 PL_parser = parser->old_parser;
775 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
777 I32 nexttoke = parser->nexttoke;
778 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
780 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
781 && parser->nextval[nexttoke].opval
782 && parser->nextval[nexttoke].opval->op_slabbed
783 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
784 op_free(parser->nextval[nexttoke].opval);
785 parser->nextval[nexttoke].opval = NULL;
792 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
794 Buffer scalar containing the chunk currently under consideration of the
795 text currently being lexed. This is always a plain string scalar (for
796 which C<SvPOK> is true). It is not intended to be used as a scalar by
797 normal scalar means; instead refer to the buffer directly by the pointer
798 variables described below.
800 The lexer maintains various C<char*> pointers to things in the
801 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
802 reallocated, all of these pointers must be updated. Don't attempt to
803 do this manually, but rather use L</lex_grow_linestr> if you need to
804 reallocate the buffer.
806 The content of the text chunk in the buffer is commonly exactly one
807 complete line of input, up to and including a newline terminator,
808 but there are situations where it is otherwise. The octets of the
809 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
810 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
811 flag on this scalar, which may disagree with it.
813 For direct examination of the buffer, the variable
814 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
815 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
816 of these pointers is usually preferable to examination of the scalar
817 through normal scalar means.
819 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
821 Direct pointer to the end of the chunk of text currently being lexed, the
822 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
823 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
824 always located at the end of the buffer, and does not count as part of
825 the buffer's contents.
827 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
829 Points to the current position of lexing inside the lexer buffer.
830 Characters around this point may be freely examined, within
831 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
832 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
833 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
835 Lexing code (whether in the Perl core or not) moves this pointer past
836 the characters that it consumes. It is also expected to perform some
837 bookkeeping whenever a newline character is consumed. This movement
838 can be more conveniently performed by the function L</lex_read_to>,
839 which handles newlines appropriately.
841 Interpretation of the buffer's octets can be abstracted out by
842 using the slightly higher-level functions L</lex_peek_unichar> and
843 L</lex_read_unichar>.
845 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
847 Points to the start of the current line inside the lexer buffer.
848 This is useful for indicating at which column an error occurred, and
849 not much else. This must be updated by any lexing code that consumes
850 a newline; the function L</lex_read_to> handles this detail.
856 =for apidoc Amx|bool|lex_bufutf8
858 Indicates whether the octets in the lexer buffer
859 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
860 of Unicode characters. If not, they should be interpreted as Latin-1
861 characters. This is analogous to the C<SvUTF8> flag for scalars.
863 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
864 contains valid UTF-8. Lexing code must be robust in the face of invalid
867 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
868 is significant, but not the whole story regarding the input character
869 encoding. Normally, when a file is being read, the scalar contains octets
870 and its C<SvUTF8> flag is off, but the octets should be interpreted as
871 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
872 however, the scalar may have the C<SvUTF8> flag on, and in this case its
873 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
874 is in effect. This logic may change in the future; use this function
875 instead of implementing the logic yourself.
881 Perl_lex_bufutf8(pTHX)
887 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
889 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
890 at least C<len> octets (including terminating C<NUL>). Returns a
891 pointer to the reallocated buffer. This is necessary before making
892 any direct modification of the buffer that would increase its length.
893 L</lex_stuff_pvn> provides a more convenient way to insert text into
896 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
897 this function updates all of the lexer's variables that point directly
904 Perl_lex_grow_linestr(pTHX_ STRLEN len)
908 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
909 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
910 linestr = PL_parser->linestr;
911 buf = SvPVX(linestr);
912 if (len <= SvLEN(linestr))
914 bufend_pos = PL_parser->bufend - buf;
915 bufptr_pos = PL_parser->bufptr - buf;
916 oldbufptr_pos = PL_parser->oldbufptr - buf;
917 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
918 linestart_pos = PL_parser->linestart - buf;
919 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
920 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
921 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
922 PL_parser->lex_shared->re_eval_start - buf : 0;
924 buf = sv_grow(linestr, len);
926 PL_parser->bufend = buf + bufend_pos;
927 PL_parser->bufptr = buf + bufptr_pos;
928 PL_parser->oldbufptr = buf + oldbufptr_pos;
929 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
930 PL_parser->linestart = buf + linestart_pos;
931 if (PL_parser->last_uni)
932 PL_parser->last_uni = buf + last_uni_pos;
933 if (PL_parser->last_lop)
934 PL_parser->last_lop = buf + last_lop_pos;
935 if (PL_parser->lex_shared->re_eval_start)
936 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
941 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
943 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
944 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
945 reallocating the buffer if necessary. This means that lexing code that
946 runs later will see the characters as if they had appeared in the input.
947 It is not recommended to do this as part of normal parsing, and most
948 uses of this facility run the risk of the inserted characters being
949 interpreted in an unintended manner.
951 The string to be inserted is represented by C<len> octets starting
952 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
953 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
954 The characters are recoded for the lexer buffer, according to how the
955 buffer is currently being interpreted (L</lex_bufutf8>). If a string
956 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
957 function is more convenient.
963 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
967 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
968 if (flags & ~(LEX_STUFF_UTF8))
969 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
971 if (flags & LEX_STUFF_UTF8) {
974 STRLEN highhalf = 0; /* Count of variants */
975 const char *p, *e = pv+len;
976 for (p = pv; p != e; p++) {
977 if (! UTF8_IS_INVARIANT(*p)) {
983 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
984 bufptr = PL_parser->bufptr;
985 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
986 SvCUR_set(PL_parser->linestr,
987 SvCUR(PL_parser->linestr) + len+highhalf);
988 PL_parser->bufend += len+highhalf;
989 for (p = pv; p != e; p++) {
991 if (! UTF8_IS_INVARIANT(c)) {
992 *bufptr++ = UTF8_TWO_BYTE_HI(c);
993 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1000 if (flags & LEX_STUFF_UTF8) {
1001 STRLEN highhalf = 0;
1002 const char *p, *e = pv+len;
1003 for (p = pv; p != e; p++) {
1005 if (UTF8_IS_ABOVE_LATIN1(c)) {
1006 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1007 "non-Latin-1 character into Latin-1 input");
1008 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1011 } else if (! UTF8_IS_INVARIANT(c)) {
1012 /* malformed UTF-8 */
1014 SAVESPTR(PL_warnhook);
1015 PL_warnhook = PERL_WARNHOOK_FATAL;
1016 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1022 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1023 bufptr = PL_parser->bufptr;
1024 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1025 SvCUR_set(PL_parser->linestr,
1026 SvCUR(PL_parser->linestr) + len-highhalf);
1027 PL_parser->bufend += len-highhalf;
1030 if (UTF8_IS_INVARIANT(*p)) {
1036 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1042 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1043 bufptr = PL_parser->bufptr;
1044 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1045 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1046 PL_parser->bufend += len;
1047 Copy(pv, bufptr, len, char);
1053 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1055 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1056 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1057 reallocating the buffer if necessary. This means that lexing code that
1058 runs later will see the characters as if they had appeared in the input.
1059 It is not recommended to do this as part of normal parsing, and most
1060 uses of this facility run the risk of the inserted characters being
1061 interpreted in an unintended manner.
1063 The string to be inserted is represented by octets starting at C<pv>
1064 and continuing to the first nul. These octets are interpreted as either
1065 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1066 in C<flags>. The characters are recoded for the lexer buffer, according
1067 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1068 If it is not convenient to nul-terminate a string to be inserted, the
1069 L</lex_stuff_pvn> function is more appropriate.
1075 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1077 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1078 lex_stuff_pvn(pv, strlen(pv), flags);
1082 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1084 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1085 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1086 reallocating the buffer if necessary. This means that lexing code that
1087 runs later will see the characters as if they had appeared in the input.
1088 It is not recommended to do this as part of normal parsing, and most
1089 uses of this facility run the risk of the inserted characters being
1090 interpreted in an unintended manner.
1092 The string to be inserted is the string value of C<sv>. The characters
1093 are recoded for the lexer buffer, according to how the buffer is currently
1094 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1095 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1096 need to construct a scalar.
1102 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1106 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1110 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1114 =for apidoc Amx|void|lex_unstuff|char *ptr
1116 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1117 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1118 This hides the discarded text from any lexing code that runs later,
1119 as if the text had never appeared.
1121 This is not the normal way to consume lexed text. For that, use
1128 Perl_lex_unstuff(pTHX_ char *ptr)
1132 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1133 buf = PL_parser->bufptr;
1135 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 bufend = PL_parser->bufend;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1141 unstuff_len = ptr - buf;
1142 Move(ptr, buf, bufend+1-ptr, char);
1143 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1144 PL_parser->bufend = bufend - unstuff_len;
1148 =for apidoc Amx|void|lex_read_to|char *ptr
1150 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1151 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1152 performing the correct bookkeeping whenever a newline character is passed.
1153 This is the normal way to consume lexed text.
1155 Interpretation of the buffer's octets can be abstracted out by
1156 using the slightly higher-level functions L</lex_peek_unichar> and
1157 L</lex_read_unichar>.
1163 Perl_lex_read_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_READ_TO;
1167 s = PL_parser->bufptr;
1168 if (ptr < s || ptr > PL_parser->bufend)
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1170 for (; s != ptr; s++)
1172 COPLINE_INC_WITH_HERELINES;
1173 PL_parser->linestart = s+1;
1175 PL_parser->bufptr = ptr;
1179 =for apidoc Amx|void|lex_discard_to|char *ptr
1181 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1182 up to C<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. C<ptr> must not
1184 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1185 it is not permitted to discard text that has yet to be lexed.
1187 Normally it is not necessarily to do this directly, because it suffices to
1188 use the implicit discarding behaviour of L</lex_next_chunk> and things
1189 based on it. However, if a token stretches across multiple lines,
1190 and the lexing code has kept multiple lines of text in the buffer for
1191 that purpose, then after completion of the token it would be wise to
1192 explicitly discard the now-unneeded earlier lines, to avoid future
1193 multi-line tokens growing the buffer without bound.
1199 Perl_lex_discard_to(pTHX_ char *ptr)
1203 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1204 buf = SvPVX(PL_parser->linestr);
1206 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1209 if (ptr > PL_parser->bufptr)
1210 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1211 discard_len = ptr - buf;
1212 if (PL_parser->oldbufptr < ptr)
1213 PL_parser->oldbufptr = ptr;
1214 if (PL_parser->oldoldbufptr < ptr)
1215 PL_parser->oldoldbufptr = ptr;
1216 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1217 PL_parser->last_uni = NULL;
1218 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1219 PL_parser->last_lop = NULL;
1220 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1221 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1222 PL_parser->bufend -= discard_len;
1223 PL_parser->bufptr -= discard_len;
1224 PL_parser->oldbufptr -= discard_len;
1225 PL_parser->oldoldbufptr -= discard_len;
1226 if (PL_parser->last_uni)
1227 PL_parser->last_uni -= discard_len;
1228 if (PL_parser->last_lop)
1229 PL_parser->last_lop -= discard_len;
1233 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1235 Reads in the next chunk of text to be lexed, appending it to
1236 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1237 looked to the end of the current chunk and wants to know more. It is
1238 usual, but not necessary, for lexing to have consumed the entirety of
1239 the current chunk at this time.
1241 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1242 chunk (i.e., the current chunk has been entirely consumed), normally the
1243 current chunk will be discarded at the same time that the new chunk is
1244 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1245 will not be discarded. If the current chunk has not been entirely
1246 consumed, then it will not be discarded regardless of the flag.
1248 Returns true if some new text was added to the buffer, or false if the
1249 buffer has reached the end of the input text.
1254 #define LEX_FAKE_EOF 0x80000000
1255 #define LEX_NO_TERM 0x40000000 /* here-doc */
1258 Perl_lex_next_chunk(pTHX_ U32 flags)
1262 STRLEN old_bufend_pos, new_bufend_pos;
1263 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1264 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1265 bool got_some_for_debugger = 0;
1267 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1268 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1269 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1271 linestr = PL_parser->linestr;
1272 buf = SvPVX(linestr);
1273 if (!(flags & LEX_KEEP_PREVIOUS)
1274 && PL_parser->bufptr == PL_parser->bufend)
1276 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1278 if (PL_parser->last_uni != PL_parser->bufend)
1279 PL_parser->last_uni = NULL;
1280 if (PL_parser->last_lop != PL_parser->bufend)
1281 PL_parser->last_lop = NULL;
1282 last_uni_pos = last_lop_pos = 0;
1286 old_bufend_pos = PL_parser->bufend - buf;
1287 bufptr_pos = PL_parser->bufptr - buf;
1288 oldbufptr_pos = PL_parser->oldbufptr - buf;
1289 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1290 linestart_pos = PL_parser->linestart - buf;
1291 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1292 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1294 if (flags & LEX_FAKE_EOF) {
1296 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1298 } else if (filter_gets(linestr, old_bufend_pos)) {
1300 got_some_for_debugger = 1;
1301 } else if (flags & LEX_NO_TERM) {
1304 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1305 sv_setpvs(linestr, "");
1307 /* End of real input. Close filehandle (unless it was STDIN),
1308 * then add implicit termination.
1310 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1311 PerlIO_clearerr(PL_parser->rsfp);
1312 else if (PL_parser->rsfp)
1313 (void)PerlIO_close(PL_parser->rsfp);
1314 PL_parser->rsfp = NULL;
1315 PL_parser->in_pod = PL_parser->filtered = 0;
1316 if (!PL_in_eval && PL_minus_p) {
1318 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1319 PL_minus_n = PL_minus_p = 0;
1320 } else if (!PL_in_eval && PL_minus_n) {
1321 sv_catpvs(linestr, /*{*/";}");
1324 sv_catpvs(linestr, ";");
1327 buf = SvPVX(linestr);
1328 new_bufend_pos = SvCUR(linestr);
1329 PL_parser->bufend = buf + new_bufend_pos;
1330 PL_parser->bufptr = buf + bufptr_pos;
1331 PL_parser->oldbufptr = buf + oldbufptr_pos;
1332 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1333 PL_parser->linestart = buf + linestart_pos;
1334 if (PL_parser->last_uni)
1335 PL_parser->last_uni = buf + last_uni_pos;
1336 if (PL_parser->last_lop)
1337 PL_parser->last_lop = buf + last_lop_pos;
1338 if (PL_parser->preambling != NOLINE) {
1339 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1340 PL_parser->preambling = NOLINE;
1342 if ( got_some_for_debugger
1343 && PERLDB_LINE_OR_SAVESRC
1344 && PL_curstash != PL_debstash)
1346 /* debugger active and we're not compiling the debugger code,
1347 * so store the line into the debugger's array of lines
1349 update_debugger_info(NULL, buf+old_bufend_pos,
1350 new_bufend_pos-old_bufend_pos);
1356 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1358 Looks ahead one (Unicode) character in the text currently being lexed.
1359 Returns the codepoint (unsigned integer value) of the next character,
1360 or -1 if lexing has reached the end of the input text. To consume the
1361 peeked character, use L</lex_read_unichar>.
1363 If the next character is in (or extends into) the next chunk of input
1364 text, the next chunk will be read in. Normally the current chunk will be
1365 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1366 bit set, then the current chunk will not be discarded.
1368 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1369 is encountered, an exception is generated.
1375 Perl_lex_peek_unichar(pTHX_ U32 flags)
1379 if (flags & ~(LEX_KEEP_PREVIOUS))
1380 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1381 s = PL_parser->bufptr;
1382 bufend = PL_parser->bufend;
1388 if (!lex_next_chunk(flags))
1390 s = PL_parser->bufptr;
1391 bufend = PL_parser->bufend;
1394 if (UTF8_IS_INVARIANT(head))
1396 if (UTF8_IS_START(head)) {
1397 len = UTF8SKIP(&head);
1398 while ((STRLEN)(bufend-s) < len) {
1399 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1401 s = PL_parser->bufptr;
1402 bufend = PL_parser->bufend;
1405 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1406 if (retlen == (STRLEN)-1) {
1407 /* malformed UTF-8 */
1409 SAVESPTR(PL_warnhook);
1410 PL_warnhook = PERL_WARNHOOK_FATAL;
1411 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1417 if (!lex_next_chunk(flags))
1419 s = PL_parser->bufptr;
1426 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1428 Reads the next (Unicode) character in the text currently being lexed.
1429 Returns the codepoint (unsigned integer value) of the character read,
1430 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1431 if lexing has reached the end of the input text. To non-destructively
1432 examine the next character, use L</lex_peek_unichar> instead.
1434 If the next character is in (or extends into) the next chunk of input
1435 text, the next chunk will be read in. Normally the current chunk will be
1436 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1437 bit set, then the current chunk will not be discarded.
1439 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1440 is encountered, an exception is generated.
1446 Perl_lex_read_unichar(pTHX_ U32 flags)
1449 if (flags & ~(LEX_KEEP_PREVIOUS))
1450 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1451 c = lex_peek_unichar(flags);
1454 COPLINE_INC_WITH_HERELINES;
1456 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1458 ++(PL_parser->bufptr);
1464 =for apidoc Amx|void|lex_read_space|U32 flags
1466 Reads optional spaces, in Perl style, in the text currently being
1467 lexed. The spaces may include ordinary whitespace characters and
1468 Perl-style comments. C<#line> directives are processed if encountered.
1469 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1470 at a non-space character (or the end of the input text).
1472 If spaces extend into the next chunk of input text, the next chunk will
1473 be read in. Normally the current chunk will be discarded at the same
1474 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1475 chunk will not be discarded.
1480 #define LEX_NO_INCLINE 0x40000000
1481 #define LEX_NO_NEXT_CHUNK 0x80000000
1484 Perl_lex_read_space(pTHX_ U32 flags)
1487 const bool can_incline = !(flags & LEX_NO_INCLINE);
1488 bool need_incline = 0;
1489 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1490 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1491 s = PL_parser->bufptr;
1492 bufend = PL_parser->bufend;
1498 } while (!(c == '\n' || (c == 0 && s == bufend)));
1499 } else if (c == '\n') {
1502 PL_parser->linestart = s;
1508 } else if (isSPACE(c)) {
1510 } else if (c == 0 && s == bufend) {
1513 if (flags & LEX_NO_NEXT_CHUNK)
1515 PL_parser->bufptr = s;
1516 l = CopLINE(PL_curcop);
1517 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1518 got_more = lex_next_chunk(flags);
1519 CopLINE_set(PL_curcop, l);
1520 s = PL_parser->bufptr;
1521 bufend = PL_parser->bufend;
1524 if (can_incline && need_incline && PL_parser->rsfp) {
1534 PL_parser->bufptr = s;
1539 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1541 This function performs syntax checking on a prototype, C<proto>.
1542 If C<warn> is true, any illegal characters or mismatched brackets
1543 will trigger illegalproto warnings, declaring that they were
1544 detected in the prototype for C<name>.
1546 The return value is C<true> if this is a valid prototype, and
1547 C<false> if it is not, regardless of whether C<warn> was C<true> or
1550 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1557 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1559 STRLEN len, origlen;
1560 char *p = proto ? SvPV(proto, len) : NULL;
1561 bool bad_proto = FALSE;
1562 bool in_brackets = FALSE;
1563 bool after_slash = FALSE;
1564 char greedy_proto = ' ';
1565 bool proto_after_greedy_proto = FALSE;
1566 bool must_be_last = FALSE;
1567 bool underscore = FALSE;
1568 bool bad_proto_after_underscore = FALSE;
1570 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1576 for (; len--; p++) {
1579 proto_after_greedy_proto = TRUE;
1581 if (!strchr(";@%", *p))
1582 bad_proto_after_underscore = TRUE;
1585 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1592 in_brackets = FALSE;
1593 else if ((*p == '@' || *p == '%')
1597 must_be_last = TRUE;
1606 after_slash = FALSE;
1611 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1614 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1615 origlen, UNI_DISPLAY_ISPRINT)
1616 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1618 if (proto_after_greedy_proto)
1619 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1620 "Prototype after '%c' for %"SVf" : %s",
1621 greedy_proto, SVfARG(name), p);
1623 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1624 "Missing ']' in prototype for %"SVf" : %s",
1627 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1628 "Illegal character in prototype for %"SVf" : %s",
1630 if (bad_proto_after_underscore)
1631 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1632 "Illegal character after '_' in prototype for %"SVf" : %s",
1636 return (! (proto_after_greedy_proto || bad_proto) );
1641 * This subroutine has nothing to do with tilting, whether at windmills
1642 * or pinball tables. Its name is short for "increment line". It
1643 * increments the current line number in CopLINE(PL_curcop) and checks
1644 * to see whether the line starts with a comment of the form
1645 * # line 500 "foo.pm"
1646 * If so, it sets the current line number and file to the values in the comment.
1650 S_incline(pTHX_ const char *s)
1658 PERL_ARGS_ASSERT_INCLINE;
1660 COPLINE_INC_WITH_HERELINES;
1661 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1662 && s+1 == PL_bufend && *s == ';') {
1663 /* fake newline in string eval */
1664 CopLINE_dec(PL_curcop);
1669 while (SPACE_OR_TAB(*s))
1671 if (strnEQ(s, "line", 4))
1675 if (SPACE_OR_TAB(*s))
1679 while (SPACE_OR_TAB(*s))
1687 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1689 while (SPACE_OR_TAB(*s))
1691 if (*s == '"' && (t = strchr(s+1, '"'))) {
1697 while (!isSPACE(*t))
1701 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1703 if (*e != '\n' && *e != '\0')
1704 return; /* false alarm */
1706 if (!grok_atoUV(n, &uv, &e))
1708 line_num = ((line_t)uv) - 1;
1711 const STRLEN len = t - s;
1713 if (!PL_rsfp && !PL_parser->filtered) {
1714 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1715 * to *{"::_<newfilename"} */
1716 /* However, the long form of evals is only turned on by the
1717 debugger - usually they're "(eval %lu)" */
1718 GV * const cfgv = CopFILEGV(PL_curcop);
1721 STRLEN tmplen2 = len;
1725 if (tmplen2 + 2 <= sizeof smallbuf)
1728 Newx(tmpbuf2, tmplen2 + 2, char);
1733 memcpy(tmpbuf2 + 2, s, tmplen2);
1736 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1738 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1739 /* adjust ${"::_<newfilename"} to store the new file name */
1740 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1741 /* The line number may differ. If that is the case,
1742 alias the saved lines that are in the array.
1743 Otherwise alias the whole array. */
1744 if (CopLINE(PL_curcop) == line_num) {
1745 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1746 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1748 else if (GvAV(cfgv)) {
1749 AV * const av = GvAV(cfgv);
1750 const I32 start = CopLINE(PL_curcop)+1;
1751 I32 items = AvFILLp(av) - start;
1753 AV * const av2 = GvAVn(gv2);
1754 SV **svp = AvARRAY(av) + start;
1755 I32 l = (I32)line_num+1;
1757 av_store(av2, l++, SvREFCNT_inc(*svp++));
1762 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1765 CopFILE_free(PL_curcop);
1766 CopFILE_setn(PL_curcop, s, len);
1768 CopLINE_set(PL_curcop, line_num);
1771 #define skipspace(s) skipspace_flags(s, 0)
1775 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1777 AV *av = CopFILEAVx(PL_curcop);
1780 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1782 sv = *av_fetch(av, 0, 1);
1783 SvUPGRADE(sv, SVt_PVMG);
1785 if (!SvPOK(sv)) sv_setpvs(sv,"");
1787 sv_catsv(sv, orig_sv);
1789 sv_catpvn(sv, buf, len);
1794 if (PL_parser->preambling == NOLINE)
1795 av_store(av, CopLINE(PL_curcop), sv);
1801 * Called to gobble the appropriate amount and type of whitespace.
1802 * Skips comments as well.
1806 S_skipspace_flags(pTHX_ char *s, U32 flags)
1808 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1809 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1810 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1813 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1815 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1816 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1817 LEX_NO_NEXT_CHUNK : 0));
1819 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1820 if (PL_linestart > PL_bufptr)
1821 PL_bufptr = PL_linestart;
1829 * Check the unary operators to ensure there's no ambiguity in how they're
1830 * used. An ambiguous piece of code would be:
1832 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1833 * the +5 is its argument.
1842 if (PL_oldoldbufptr != PL_last_uni)
1844 while (isSPACE(*PL_last_uni))
1847 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1848 s += UTF ? UTF8SKIP(s) : 1;
1849 if ((t = strchr(s, '(')) && t < PL_bufptr)
1852 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1853 "Warning: Use of \"%"UTF8f"\" without parentheses is ambiguous",
1854 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1858 * LOP : macro to build a list operator. Its behaviour has been replaced
1859 * with a subroutine, S_lop() for which LOP is just another name.
1862 #define LOP(f,x) return lop(f,x,s)
1866 * Build a list operator (or something that might be one). The rules:
1867 * - if we have a next token, then it's a list operator (no parens) for
1868 * which the next token has already been parsed; e.g.,
1871 * - if the next thing is an opening paren, then it's a function
1872 * - else it's a list operator
1876 S_lop(pTHX_ I32 f, int x, char *s)
1878 PERL_ARGS_ASSERT_LOP;
1883 PL_last_lop = PL_oldbufptr;
1884 PL_last_lop_op = (OPCODE)f;
1889 return REPORT(FUNC);
1892 return REPORT(FUNC);
1895 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1896 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1897 return REPORT(LSTOP);
1903 * When the lexer realizes it knows the next token (for instance,
1904 * it is reordering tokens for the parser) then it can call S_force_next
1905 * to know what token to return the next time the lexer is called. Caller
1906 * will need to set PL_nextval[] and possibly PL_expect to ensure
1907 * the lexer handles the token correctly.
1911 S_force_next(pTHX_ I32 type)
1915 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1916 tokereport(type, &NEXTVAL_NEXTTOKE);
1919 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1920 PL_nexttype[PL_nexttoke] = type;
1922 if (PL_lex_state != LEX_KNOWNEXT) {
1923 PL_lex_defer = PL_lex_state;
1924 PL_lex_state = LEX_KNOWNEXT;
1931 * This subroutine handles postfix deref syntax after the arrow has already
1932 * been emitted. @* $* etc. are emitted as two separate token right here.
1933 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1934 * only the first, leaving yylex to find the next.
1938 S_postderef(pTHX_ int const funny, char const next)
1940 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1941 assert(strchr("*[{", next));
1943 PL_expect = XOPERATOR;
1944 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1945 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1946 PL_lex_state = LEX_INTERPEND;
1947 force_next(POSTJOIN);
1953 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1954 && !PL_lex_brackets)
1956 PL_expect = XOPERATOR;
1965 int yyc = PL_parser->yychar;
1966 if (yyc != YYEMPTY) {
1968 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1969 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1970 PL_lex_allbrackets--;
1972 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1973 } else if (yyc == '('/*)*/) {
1974 PL_lex_allbrackets--;
1979 PL_parser->yychar = YYEMPTY;
1984 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1986 SV * const sv = newSVpvn_utf8(start, len,
1989 && !is_invariant_string((const U8*)start, len)
1990 && is_utf8_string((const U8*)start, len));
1996 * When the lexer knows the next thing is a word (for instance, it has
1997 * just seen -> and it knows that the next char is a word char, then
1998 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2002 * char *start : buffer position (must be within PL_linestr)
2003 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2004 * int check_keyword : if true, Perl checks to make sure the word isn't
2005 * a keyword (do this if the word is a label, e.g. goto FOO)
2006 * int allow_pack : if true, : characters will also be allowed (require,
2007 * use, etc. do this)
2011 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2016 PERL_ARGS_ASSERT_FORCE_WORD;
2018 start = skipspace(start);
2020 if (isIDFIRST_lazy_if(s,UTF)
2021 || (allow_pack && *s == ':') )
2023 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2024 if (check_keyword) {
2025 char *s2 = PL_tokenbuf;
2027 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2029 if (keyword(s2, len2, 0))
2032 if (token == METHOD) {
2037 PL_expect = XOPERATOR;
2040 NEXTVAL_NEXTTOKE.opval
2041 = (OP*)newSVOP(OP_CONST,0,
2042 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2043 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2051 * Called when the lexer wants $foo *foo &foo etc, but the program
2052 * text only contains the "foo" portion. The first argument is a pointer
2053 * to the "foo", and the second argument is the type symbol to prefix.
2054 * Forces the next token to be a "WORD".
2055 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2059 S_force_ident(pTHX_ const char *s, int kind)
2061 PERL_ARGS_ASSERT_FORCE_IDENT;
2064 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2065 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2066 UTF ? SVf_UTF8 : 0));
2067 NEXTVAL_NEXTTOKE.opval = o;
2070 o->op_private = OPpCONST_ENTERED;
2071 /* XXX see note in pp_entereval() for why we forgo typo
2072 warnings if the symbol must be introduced in an eval.
2074 gv_fetchpvn_flags(s, len,
2075 (PL_in_eval ? GV_ADDMULTI
2076 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2077 kind == '$' ? SVt_PV :
2078 kind == '@' ? SVt_PVAV :
2079 kind == '%' ? SVt_PVHV :
2087 S_force_ident_maybe_lex(pTHX_ char pit)
2089 NEXTVAL_NEXTTOKE.ival = pit;
2094 Perl_str_to_version(pTHX_ SV *sv)
2099 const char *start = SvPV_const(sv,len);
2100 const char * const end = start + len;
2101 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2103 PERL_ARGS_ASSERT_STR_TO_VERSION;
2105 while (start < end) {
2109 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2114 retval += ((NV)n)/nshift;
2123 * Forces the next token to be a version number.
2124 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2125 * and if "guessing" is TRUE, then no new token is created (and the caller
2126 * must use an alternative parsing method).
2130 S_force_version(pTHX_ char *s, int guessing)
2135 PERL_ARGS_ASSERT_FORCE_VERSION;
2143 while (isDIGIT(*d) || *d == '_' || *d == '.')
2145 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2147 s = scan_num(s, &pl_yylval);
2148 version = pl_yylval.opval;
2149 ver = cSVOPx(version)->op_sv;
2150 if (SvPOK(ver) && !SvNIOK(ver)) {
2151 SvUPGRADE(ver, SVt_PVNV);
2152 SvNV_set(ver, str_to_version(ver));
2153 SvNOK_on(ver); /* hint that it is a version */
2156 else if (guessing) {
2161 /* NOTE: The parser sees the package name and the VERSION swapped */
2162 NEXTVAL_NEXTTOKE.opval = version;
2169 * S_force_strict_version
2170 * Forces the next token to be a version number using strict syntax rules.
2174 S_force_strict_version(pTHX_ char *s)
2177 const char *errstr = NULL;
2179 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2181 while (isSPACE(*s)) /* leading whitespace */
2184 if (is_STRICT_VERSION(s,&errstr)) {
2186 s = (char *)scan_version(s, ver, 0);
2187 version = newSVOP(OP_CONST, 0, ver);
2189 else if ((*s != ';' && *s != '{' && *s != '}' )
2190 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2194 yyerror(errstr); /* version required */
2198 /* NOTE: The parser sees the package name and the VERSION swapped */
2199 NEXTVAL_NEXTTOKE.opval = version;
2207 * Tokenize a quoted string passed in as an SV. It finds the next
2208 * chunk, up to end of string or a backslash. It may make a new
2209 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2214 S_tokeq(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_TOKEQ;
2225 assert (!SvIsCOW(sv));
2226 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2230 /* This is relying on the SV being "well formed" with a trailing '\0' */
2231 while (s < send && !(*s == '\\' && s[1] == '\\'))
2236 if ( PL_hints & HINT_NEW_STRING ) {
2237 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2238 SVs_TEMP | SvUTF8(sv));
2242 if (s + 1 < send && (s[1] == '\\'))
2243 s++; /* all that, just for this */
2248 SvCUR_set(sv, d - SvPVX_const(sv));
2250 if ( PL_hints & HINT_NEW_STRING )
2251 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2256 * Now come three functions related to double-quote context,
2257 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2258 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2259 * interact with PL_lex_state, and create fake ( ... ) argument lists
2260 * to handle functions and concatenation.
2264 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2269 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2271 * Pattern matching will set PL_lex_op to the pattern-matching op to
2272 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2274 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2276 * Everything else becomes a FUNC.
2278 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2279 * had an OP_CONST or OP_READLINE). This just sets us up for a
2280 * call to S_sublex_push().
2284 S_sublex_start(pTHX)
2286 const I32 op_type = pl_yylval.ival;
2288 if (op_type == OP_NULL) {
2289 pl_yylval.opval = PL_lex_op;
2293 if (op_type == OP_CONST) {
2294 SV *sv = PL_lex_stuff;
2295 PL_lex_stuff = NULL;
2298 if (SvTYPE(sv) == SVt_PVIV) {
2299 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2301 const char * const p = SvPV_const(sv, len);
2302 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2306 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2310 PL_sublex_info.super_state = PL_lex_state;
2311 PL_sublex_info.sub_inwhat = (U16)op_type;
2312 PL_sublex_info.sub_op = PL_lex_op;
2313 PL_lex_state = LEX_INTERPPUSH;
2317 pl_yylval.opval = PL_lex_op;
2327 * Create a new scope to save the lexing state. The scope will be
2328 * ended in S_sublex_done. Returns a '(', starting the function arguments
2329 * to the uc, lc, etc. found before.
2330 * Sets PL_lex_state to LEX_INTERPCONCAT.
2337 const bool is_heredoc = PL_multi_close == '<';
2340 PL_lex_state = PL_sublex_info.super_state;
2341 SAVEI8(PL_lex_dojoin);
2342 SAVEI32(PL_lex_brackets);
2343 SAVEI32(PL_lex_allbrackets);
2344 SAVEI32(PL_lex_formbrack);
2345 SAVEI8(PL_lex_fakeeof);
2346 SAVEI32(PL_lex_casemods);
2347 SAVEI32(PL_lex_starts);
2348 SAVEI8(PL_lex_state);
2349 SAVEI8(PL_lex_defer);
2350 SAVESPTR(PL_lex_repl);
2351 SAVEVPTR(PL_lex_inpat);
2352 SAVEI16(PL_lex_inwhat);
2355 SAVECOPLINE(PL_curcop);
2356 SAVEI32(PL_multi_end);
2357 SAVEI32(PL_parser->herelines);
2358 PL_parser->herelines = 0;
2360 SAVEI8(PL_multi_close);
2361 SAVEPPTR(PL_bufptr);
2362 SAVEPPTR(PL_bufend);
2363 SAVEPPTR(PL_oldbufptr);
2364 SAVEPPTR(PL_oldoldbufptr);
2365 SAVEPPTR(PL_last_lop);
2366 SAVEPPTR(PL_last_uni);
2367 SAVEPPTR(PL_linestart);
2368 SAVESPTR(PL_linestr);
2369 SAVEGENERICPV(PL_lex_brackstack);
2370 SAVEGENERICPV(PL_lex_casestack);
2371 SAVEGENERICPV(PL_parser->lex_shared);
2372 SAVEBOOL(PL_parser->lex_re_reparsing);
2373 SAVEI32(PL_copline);
2375 /* The here-doc parser needs to be able to peek into outer lexing
2376 scopes to find the body of the here-doc. So we put PL_linestr and
2377 PL_bufptr into lex_shared, to ‘share’ those values.
2379 PL_parser->lex_shared->ls_linestr = PL_linestr;
2380 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2382 PL_linestr = PL_lex_stuff;
2383 PL_lex_repl = PL_sublex_info.repl;
2384 PL_lex_stuff = NULL;
2385 PL_sublex_info.repl = NULL;
2387 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2388 set for an inner quote-like operator and then an error causes scope-
2389 popping. We must not have a PL_lex_stuff value left dangling, as
2390 that breaks assumptions elsewhere. See bug #123617. */
2391 SAVEGENERICSV(PL_lex_stuff);
2392 SAVEGENERICSV(PL_sublex_info.repl);
2394 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2395 = SvPVX(PL_linestr);
2396 PL_bufend += SvCUR(PL_linestr);
2397 PL_last_lop = PL_last_uni = NULL;
2398 SAVEFREESV(PL_linestr);
2399 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2401 PL_lex_dojoin = FALSE;
2402 PL_lex_brackets = PL_lex_formbrack = 0;
2403 PL_lex_allbrackets = 0;
2404 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2405 Newx(PL_lex_brackstack, 120, char);
2406 Newx(PL_lex_casestack, 12, char);
2407 PL_lex_casemods = 0;
2408 *PL_lex_casestack = '\0';
2410 PL_lex_state = LEX_INTERPCONCAT;
2412 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2413 PL_copline = NOLINE;
2415 Newxz(shared, 1, LEXSHARED);
2416 shared->ls_prev = PL_parser->lex_shared;
2417 PL_parser->lex_shared = shared;
2419 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2420 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2421 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2422 PL_lex_inpat = PL_sublex_info.sub_op;
2424 PL_lex_inpat = NULL;
2426 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2427 PL_in_eval &= ~EVAL_RE_REPARSING;
2434 * Restores lexer state after a S_sublex_push.
2440 if (!PL_lex_starts++) {
2441 SV * const sv = newSVpvs("");
2442 if (SvUTF8(PL_linestr))
2444 PL_expect = XOPERATOR;
2445 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2449 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2450 PL_lex_state = LEX_INTERPCASEMOD;
2454 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2455 assert(PL_lex_inwhat != OP_TRANSR);
2457 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2458 PL_linestr = PL_lex_repl;
2460 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2461 PL_bufend += SvCUR(PL_linestr);
2462 PL_last_lop = PL_last_uni = NULL;
2463 PL_lex_dojoin = FALSE;
2464 PL_lex_brackets = 0;
2465 PL_lex_allbrackets = 0;
2466 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2467 PL_lex_casemods = 0;
2468 *PL_lex_casestack = '\0';
2470 if (SvEVALED(PL_lex_repl)) {
2471 PL_lex_state = LEX_INTERPNORMAL;
2473 /* we don't clear PL_lex_repl here, so that we can check later
2474 whether this is an evalled subst; that means we rely on the
2475 logic to ensure sublex_done() is called again only via the
2476 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2479 PL_lex_state = LEX_INTERPCONCAT;
2482 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2483 CopLINE(PL_curcop) +=
2484 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2485 + PL_parser->herelines;
2486 PL_parser->herelines = 0;
2491 const line_t l = CopLINE(PL_curcop);
2493 if (PL_multi_close == '<')
2494 PL_parser->herelines += l - PL_multi_end;
2495 PL_bufend = SvPVX(PL_linestr);
2496 PL_bufend += SvCUR(PL_linestr);
2497 PL_expect = XOPERATOR;
2502 PERL_STATIC_INLINE SV*
2503 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2505 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2506 * interior, hence to the "}". Finds what the name resolves to, returning
2507 * an SV* containing it; NULL if no valid one found */
2509 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2516 const U8* first_bad_char_loc;
2517 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2519 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2524 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2526 &first_bad_char_loc))
2528 /* If warnings are on, this will print a more detailed analysis of what
2529 * is wrong than the error message below */
2530 utf8n_to_uvchr(first_bad_char_loc,
2531 e - ((char *) first_bad_char_loc),
2534 /* We deliberately don't try to print the malformed character, which
2535 * might not print very well; it also may be just the first of many
2536 * malformations, so don't print what comes after it */
2537 yyerror_pv(Perl_form(aTHX_
2538 "Malformed UTF-8 character immediately after '%.*s'",
2539 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2544 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2545 /* include the <}> */
2546 e - backslash_ptr + 1);
2548 SvREFCNT_dec_NN(res);
2552 /* See if the charnames handler is the Perl core's, and if so, we can skip
2553 * the validation needed for a user-supplied one, as Perl's does its own
2555 table = GvHV(PL_hintgv); /* ^H */
2556 cvp = hv_fetchs(table, "charnames", FALSE);
2557 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2558 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2560 const char * const name = HvNAME(stash);
2561 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2562 && strEQ(name, "_charnames")) {
2567 /* Here, it isn't Perl's charname handler. We can't rely on a
2568 * user-supplied handler to validate the input name. For non-ut8 input,
2569 * look to see that the first character is legal. Then loop through the
2570 * rest checking that each is a continuation */
2572 /* This code makes the reasonable assumption that the only Latin1-range
2573 * characters that begin a character name alias are alphabetic, otherwise
2574 * would have to create a isCHARNAME_BEGIN macro */
2577 if (! isALPHAU(*s)) {
2582 if (! isCHARNAME_CONT(*s)) {
2585 if (*s == ' ' && *(s-1) == ' ') {
2588 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2589 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2590 "NO-BREAK SPACE in a charnames "
2591 "alias definition is deprecated");
2597 /* Similarly for utf8. For invariants can check directly; for other
2598 * Latin1, can calculate their code point and check; otherwise use a
2600 if (UTF8_IS_INVARIANT(*s)) {
2601 if (! isALPHAU(*s)) {
2605 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2606 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2612 if (! PL_utf8_charname_begin) {
2613 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2614 PL_utf8_charname_begin = _core_swash_init("utf8",
2615 "_Perl_Charname_Begin",
2617 1, 0, NULL, &flags);
2619 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2626 if (UTF8_IS_INVARIANT(*s)) {
2627 if (! isCHARNAME_CONT(*s)) {
2630 if (*s == ' ' && *(s-1) == ' ') {
2635 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2636 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2640 if (*s == *NBSP_UTF8
2641 && *(s+1) == *(NBSP_UTF8+1)
2642 && ckWARN_d(WARN_DEPRECATED))
2644 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2645 "NO-BREAK SPACE in a charnames "
2646 "alias definition is deprecated");
2651 if (! PL_utf8_charname_continue) {
2652 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2653 PL_utf8_charname_continue = _core_swash_init("utf8",
2654 "_Perl_Charname_Continue",
2656 1, 0, NULL, &flags);
2658 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2665 if (*(s-1) == ' ') {
2668 "charnames alias definitions may not contain trailing "
2669 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2670 (int)(s - backslash_ptr + 1), backslash_ptr,
2671 (int)(e - s + 1), s + 1
2673 UTF ? SVf_UTF8 : 0);
2677 if (SvUTF8(res)) { /* Don't accept malformed input */
2678 const U8* first_bad_char_loc;
2680 const char* const str = SvPV_const(res, len);
2681 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2682 /* If warnings are on, this will print a more detailed analysis of
2683 * what is wrong than the error message below */
2684 utf8n_to_uvchr(first_bad_char_loc,
2685 (char *) first_bad_char_loc - str,
2688 /* We deliberately don't try to print the malformed character,
2689 * which might not print very well; it also may be just the first
2690 * of many malformations, so don't print what comes after it */
2693 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2694 (int) (e - backslash_ptr + 1), backslash_ptr,
2695 (int) ((char *) first_bad_char_loc - str), str
2706 /* The final %.*s makes sure that should the trailing NUL be missing
2707 * that this print won't run off the end of the string */
2710 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2711 (int)(s - backslash_ptr + 1), backslash_ptr,
2712 (int)(e - s + 1), s + 1
2714 UTF ? SVf_UTF8 : 0);
2721 "charnames alias definitions may not contain a sequence of "
2722 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2723 (int)(s - backslash_ptr + 1), backslash_ptr,
2724 (int)(e - s + 1), s + 1
2726 UTF ? SVf_UTF8 : 0);
2733 Extracts the next constant part of a pattern, double-quoted string,
2734 or transliteration. This is terrifying code.
2736 For example, in parsing the double-quoted string "ab\x63$d", it would
2737 stop at the '$' and return an OP_CONST containing 'abc'.
2739 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2740 processing a pattern (PL_lex_inpat is true), a transliteration
2741 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2743 Returns a pointer to the character scanned up to. If this is
2744 advanced from the start pointer supplied (i.e. if anything was
2745 successfully parsed), will leave an OP_CONST for the substring scanned
2746 in pl_yylval. Caller must intuit reason for not parsing further
2747 by looking at the next characters herself.
2751 \N{FOO} => \N{U+hex_for_character_FOO}
2752 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2755 all other \-char, including \N and \N{ apart from \N{ABC}
2758 @ and $ where it appears to be a var, but not for $ as tail anchor
2762 In transliterations:
2763 characters are VERY literal, except for - not at the start or end
2764 of the string, which indicates a range. If the range is in bytes,
2765 scan_const expands the range to the full set of intermediate
2766 characters. If the range is in utf8, the hyphen is replaced with
2767 a certain range mark which will be handled by pmtrans() in op.c.
2769 In double-quoted strings:
2771 double-quoted style: \r and \n
2772 constants: \x31, etc.
2773 deprecated backrefs: \1 (in substitution replacements)
2774 case and quoting: \U \Q \E
2777 scan_const does *not* construct ops to handle interpolated strings.
2778 It stops processing as soon as it finds an embedded $ or @ variable
2779 and leaves it to the caller to work out what's going on.
2781 embedded arrays (whether in pattern or not) could be:
2782 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2784 $ in double-quoted strings must be the symbol of an embedded scalar.
2786 $ in pattern could be $foo or could be tail anchor. Assumption:
2787 it's a tail anchor if $ is the last thing in the string, or if it's
2788 followed by one of "()| \r\n\t"
2790 \1 (backreferences) are turned into $1 in substitutions
2792 The structure of the code is
2793 while (there's a character to process) {
2794 handle transliteration ranges
2795 skip regexp comments /(?#comment)/ and codes /(?{code})/
2796 skip #-initiated comments in //x patterns
2797 check for embedded arrays
2798 check for embedded scalars
2800 deprecate \1 in substitution replacements
2801 handle string-changing backslashes \l \U \Q \E, etc.
2802 switch (what was escaped) {
2803 handle \- in a transliteration (becomes a literal -)
2804 if a pattern and not \N{, go treat as regular character
2805 handle \132 (octal characters)
2806 handle \x15 and \x{1234} (hex characters)
2807 handle \N{name} (named characters, also \N{3,5} in a pattern)
2808 handle \cV (control characters)
2809 handle printf-style backslashes (\f, \r, \n, etc)
2812 } (end if backslash)
2813 handle regular character
2814 } (end while character to read)
2819 S_scan_const(pTHX_ char *start)
2821 char *send = PL_bufend; /* end of the constant */
2822 SV *sv = newSV(send - start); /* sv for the constant. See note below
2824 char *s = start; /* start of the constant */
2825 char *d = SvPVX(sv); /* destination for copies */
2826 bool dorange = FALSE; /* are we in a translit range? */
2827 bool didrange = FALSE; /* did we just finish a range? */
2828 bool in_charclass = FALSE; /* within /[...]/ */
2829 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2830 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2831 UTF8? But, this can show as true
2832 when the source isn't utf8, as for
2833 example when it is entirely composed
2835 SV *res; /* result from charnames */
2836 STRLEN offset_to_max; /* The offset in the output to where the range
2837 high-end character is temporarily placed */
2839 /* Note on sizing: The scanned constant is placed into sv, which is
2840 * initialized by newSV() assuming one byte of output for every byte of
2841 * input. This routine expects newSV() to allocate an extra byte for a
2842 * trailing NUL, which this routine will append if it gets to the end of
2843 * the input. There may be more bytes of input than output (eg., \N{LATIN
2844 * CAPITAL LETTER A}), or more output than input if the constant ends up
2845 * recoded to utf8, but each time a construct is found that might increase
2846 * the needed size, SvGROW() is called. Its size parameter each time is
2847 * based on the best guess estimate at the time, namely the length used so
2848 * far, plus the length the current construct will occupy, plus room for
2849 * the trailing NUL, plus one byte for every input byte still unscanned */
2851 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2854 int backslash_N = 0; /* ? was the character from \N{} */
2855 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2856 platform-specific like \x65 */
2859 PERL_ARGS_ASSERT_SCAN_CONST;
2861 assert(PL_lex_inwhat != OP_TRANSR);
2862 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2863 /* If we are doing a trans and we know we want UTF8 set expectation */
2864 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2865 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2868 /* Protect sv from errors and fatal warnings. */
2869 ENTER_with_name("scan_const");
2873 || dorange /* Handle tr/// range at right edge of input */
2876 /* get transliterations out of the way (they're most literal) */
2877 if (PL_lex_inwhat == OP_TRANS) {
2879 /* But there isn't any special handling necessary unless there is a
2880 * range, so for most cases we just drop down and handle the value
2881 * as any other. There are two exceptions.
2883 * 1. A minus sign indicates that we are actually going to have
2884 * a range. In this case, skip the '-', set a flag, then drop
2885 * down to handle what should be the end range value.
2886 * 2. After we've handled that value, the next time through, that
2887 * flag is set and we fix up the range.
2889 * Ranges entirely within Latin1 are expanded out entirely, in
2890 * order to avoid the significant overhead of making a swash.
2891 * Ranges that extend above Latin1 have to have a swash, so there
2892 * is no advantage to abbreviate them here, so they are stored here
2893 * as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte signifies a
2894 * hyphen without any possible ambiguity. On EBCDIC machines, if
2895 * the range is expressed as Unicode, the Latin1 portion is
2896 * expanded out even if the entire range extends above Latin1.
2897 * This is because each code point in it has to be processed here
2898 * individually to get its native translation */
2902 /* Here, we don't think we're in a range. If we've processed
2903 * at least one character, then see if this next one is a '-',
2904 * indicating the previous one was the start of a range. But
2905 * don't bother if we're too close to the end for the minus to
2907 if (*s != '-' || s >= send - 1 || s == start) {
2909 /* A regular character. Process like any other, but first
2910 * clear any flags */
2914 non_portable_endpoint = 0;
2917 /* Drops down to generic code to process current byte */
2920 if (didrange) { /* Something like y/A-C-Z// */
2921 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2926 s++; /* Skip past the minus */
2928 /* d now points to where the end-range character will be
2929 * placed. Save it so won't have to go finding it later,
2930 * and drop down to get that character. (Actually we
2931 * instead save the offset, to handle the case where a
2932 * realloc in the meantime could change the actual
2933 * pointer). We'll finish processing the range the next
2934 * time through the loop */
2935 offset_to_max = d - SvPVX_const(sv);
2937 } /* End of not a range */
2939 /* Here we have parsed a range. Now must handle it. At this
2941 * 'sv' is a SV* that contains the output string we are
2942 * constructing. The final two characters in that string
2943 * are the range start and range end, in order.
2944 * 'd' points to just beyond the range end in the 'sv' string,
2945 * where we would next place something
2946 * 'offset_to_max' is the offset in 'sv' at which the character
2947 * before 'd' begins.
2949 const char * max_ptr = SvPVX_const(sv) + offset_to_max;
2950 const char * min_ptr;
2952 IV range_max; /* last character in range */
2955 #ifndef EBCDIC /* Not meaningful except in EBCDIC, so initialize to false */
2956 const bool convert_unicode = FALSE;
2957 const IV real_range_max = 0;
2959 bool convert_unicode;
2960 IV real_range_max = 0;
2963 /* Get the range-ends code point values. */
2965 /* We know the utf8 is valid, because we just constructed
2966 * it ourselves in previous loop iterations */
2967 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
2968 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
2969 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
2972 min_ptr = max_ptr - 1;
2973 range_min = * (U8*) min_ptr;
2974 range_max = * (U8*) max_ptr;
2978 /* On EBCDIC platforms, we may have to deal with portable
2979 * ranges. These happen if at least one range endpoint is a
2980 * Unicode value (\N{...}), or if the range is a subset of
2981 * [A-Z] or [a-z], and both ends are literal characters,
2982 * like 'A', and not like \x{C1} */
2983 if ((convert_unicode
2984 = cBOOL(backslash_N) /* \N{} forces Unicode, hence
2986 || ( ! non_portable_endpoint
2987 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
2988 || (isUPPER_A(range_min) && isUPPER_A(range_max))))
2991 /* Special handling is needed for these portable ranges.
2992 * They are defined to all be in Unicode terms, which
2993 * include all Unicode code points between the end points.
2994 * Convert to Unicode to get the Unicode range. Later we
2995 * will convert each code point in the range back to
2997 range_min = NATIVE_TO_UNI(range_min);
2998 range_max = NATIVE_TO_UNI(range_max);
3002 if (range_min > range_max) {
3003 if (convert_unicode) {
3004 /* Need to convert back to native for meaningful
3005 * messages for this platform */
3006 range_min = UNI_TO_NATIVE(range_min);
3007 range_max = UNI_TO_NATIVE(range_max);
3010 /* Use the characters themselves for the error message if
3011 * ASCII printables; otherwise some visible representation
3013 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3015 "Invalid range \"%c-%c\" in transliteration operator",
3016 (char)range_min, (char)range_max);
3018 else if (convert_unicode) {
3019 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3021 "Invalid range \"\\N{U+%04"UVXf"}-\\N{U+%04"UVXf"}\""
3022 " in transliteration operator",
3023 range_min, range_max);
3026 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3028 "Invalid range \"\\x{%04"UVXf"}-\\x{%04"UVXf"}\""
3029 " in transliteration operator",
3030 range_min, range_max);
3036 /* We try to avoid creating a swash. If the upper end of
3037 * this range is below 256, this range won't force a swash;
3038 * otherwise it does force a swash, and as long as we have
3039 * to have one, we might as well not expand things out.
3040 * But if it's EBCDIC, we may have to look at each
3041 * character below 256 if we have to convert to/from
3045 && (range_min > 255 || ! convert_unicode)
3048 /* Move the high character one byte to the right; then
3049 * insert between it and the range begin, an illegal
3050 * byte which serves to indicate this is a range (using
3051 * a '-' could be ambiguous). */
3053 while (e-- > max_ptr) {
3056 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3060 /* Here, we're going to expand out the range. For EBCDIC
3061 * the range can extend above 255 (not so in ASCII), so
3062 * for EBCDIC, split it into the parts above and below
3065 if (range_max > 255) {
3066 real_range_max = range_max;
3072 /* Here we need to expand out the string to contain each
3073 * character in the range. Grow the output to handle this */
3075 save_offset = min_ptr - SvPVX_const(sv);
3077 /* The base growth is the number of code points in the range */
3078 grow = range_max - range_min + 1;
3081 /* But if the output is UTF-8, some of those characters may
3082 * need two bytes (since the maximum range value here is
3083 * 255, the max bytes per character is two). On ASCII
3084 * platforms, it's not much trouble to get an accurate
3085 * count of what's needed. But on EBCDIC, the ones that
3086 * need 2 bytes are scattered around, so just use a worst
3087 * case value instead of calculating for that platform. */
3091 /* Only those above 127 require 2 bytes. This may be
3092 * everything in the range, or not */
3093 if (range_min > 127) {
3096 else if (range_max > 127) {
3097 grow += range_max - 127;
3102 /* Subtract 3 for the bytes that were already accounted for
3103 * (min, max, and the hyphen) */
3104 SvGROW(sv, SvLEN(sv) + grow - 3);
3105 d = SvPVX(sv) + save_offset; /* refresh d after realloc */
3107 /* Here, we expand out the range. On ASCII platforms, the
3108 * compiler should optimize out the 'convert_unicode==TRUE'
3109 * portion of this */
3110 if (convert_unicode) {
3113 /* Recall that the min and max are now in Unicode terms, so
3114 * we have to convert each character to its native
3117 for (i = range_min; i <= range_max; i++) {
3118 append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i),
3123 for (i = range_min; i <= range_max; i++) {
3124 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3131 /* Here, no conversions are necessary, which means that the
3132 * first character in the range is already in 'd' and
3133 * valid, so we can skip overwriting it */
3136 for (i = range_min + 1; i <= range_max; i++) {
3137 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3142 for (i = range_min + 1; i <= range_max; i++) {
3148 /* (Compilers should optimize this out for non-EBCDIC). If the
3149 * original range extended above 255, add in that portion */
3150 if (real_range_max) {
3151 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3152 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3153 if (real_range_max > 0x101)
3154 *d++ = (char) ILLEGAL_UTF8_BYTE;
3155 if (real_range_max > 0x100)
3156 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3160 /* mark the range as done, and continue */
3164 non_portable_endpoint = 0;
3168 } /* End of is a range */
3169 } /* End of transliteration. Joins main code after these else's */
3170 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3173 while (s1 >= start && *s1-- == '\\')
3176 in_charclass = TRUE;
3179 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3182 while (s1 >= start && *s1-- == '\\')
3185 in_charclass = FALSE;
3188 /* skip for regexp comments /(?#comment)/, except for the last
3189 * char, which will be done separately.
3190 * Stop on (?{..}) and friends */
3192 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3194 while (s+1 < send && *s != ')')
3197 else if (!PL_lex_casemods
3198 && ( s[2] == '{' /* This should match regcomp.c */
3199 || (s[2] == '?' && s[3] == '{')))
3205 /* likewise skip #-initiated comments in //x patterns */
3209 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3211 while (s+1 < send && *s != '\n')
3215 /* no further processing of single-quoted regex */
3216 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3217 goto default_action;
3219 /* check for embedded arrays
3220 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3222 else if (*s == '@' && s[1]) {
3223 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3225 if (strchr(":'{$", s[1]))
3227 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3228 break; /* in regexp, neither @+ nor @- are interpolated */
3231 /* check for embedded scalars. only stop if we're sure it's a
3234 else if (*s == '$') {
3235 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3237 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3239 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3240 "Possible unintended interpolation of $\\ in regex");
3242 break; /* in regexp, $ might be tail anchor */
3246 /* End of else if chain - OP_TRANS rejoin rest */
3249 if (*s == '\\' && s+1 < send) {
3250 char* e; /* Can be used for ending '}', etc. */
3254 /* warn on \1 - \9 in substitution replacements, but note that \11
3255 * is an octal; and \19 is \1 followed by '9' */
3256 if (PL_lex_inwhat == OP_SUBST
3262 /* diag_listed_as: \%d better written as $%d */
3263 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3268 /* string-change backslash escapes */
3269 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3273 /* In a pattern, process \N, but skip any other backslash escapes.
3274 * This is because we don't want to translate an escape sequence
3275 * into a meta symbol and have the regex compiler use the meta
3276 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3277 * in spite of this, we do have to process \N here while the proper
3278 * charnames handler is in scope. See bugs #56444 and #62056.
3280 * There is a complication because \N in a pattern may also stand
3281 * for 'match a non-nl', and not mean a charname, in which case its
3282 * processing should be deferred to the regex compiler. To be a
3283 * charname it must be followed immediately by a '{', and not look
3284 * like \N followed by a curly quantifier, i.e., not something like
3285 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3287 else if (PL_lex_inpat
3290 || regcurly(s + 1)))
3293 goto default_action;
3299 if ((isALPHANUMERIC(*s)))
3300 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3301 "Unrecognized escape \\%c passed through",
3303 /* default action is to copy the quoted character */
3304 goto default_action;
3307 /* eg. \132 indicates the octal constant 0132 */
3308 case '0': case '1': case '2': case '3':
3309 case '4': case '5': case '6': case '7':
3311 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3313 uv = grok_oct(s, &len, &flags, NULL);
3315 if (len < 3 && s < send && isDIGIT(*s)
3316 && ckWARN(WARN_MISC))
3318 Perl_warner(aTHX_ packWARN(WARN_MISC),
3319 "%s", form_short_octal_warning(s, len));
3322 goto NUM_ESCAPE_INSERT;
3324 /* eg. \o{24} indicates the octal constant \024 */
3329 bool valid = grok_bslash_o(&s, &uv, &error,
3330 TRUE, /* Output warning */
3331 FALSE, /* Not strict */
3332 TRUE, /* Output warnings for
3339 goto NUM_ESCAPE_INSERT;
3342 /* eg. \x24 indicates the hex constant 0x24 */
3347 bool valid = grok_bslash_x(&s, &uv, &error,
3348 TRUE, /* Output warning */
3349 FALSE, /* Not strict */
3350 TRUE, /* Output warnings for
3360 /* Insert oct or hex escaped character. There will always be
3361 * enough room in sv since such escapes will be longer than any
3362 * UTF-8 sequence they can end up as, except if they force us
3363 * to recode the rest of the string into utf8 */
3365 /* Here uv is the ordinal of the next character being added */
3366 if (UVCHR_IS_INVARIANT(uv)) {
3370 if (!has_utf8 && uv > 255) {
3371 /* Might need to recode whatever we have accumulated so
3372 * far if it contains any chars variant in utf8 or
3375 SvCUR_set(sv, d - SvPVX_const(sv));
3378 /* See Note on sizing above. */
3379 sv_utf8_upgrade_flags_grow(
3381 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3382 /* Above-latin1 in string
3383 * implies no encoding */
3384 |SV_UTF8_NO_ENCODING,
3385 UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
3386 d = SvPVX(sv) + SvCUR(sv);
3391 d = (char*)uvchr_to_utf8((U8*)d, uv);
3392 if (PL_lex_inwhat == OP_TRANS
3393 && PL_sublex_info.sub_op)
3395 PL_sublex_info.sub_op->op_private |=
3396 (PL_lex_repl ? OPpTRANS_FROM_UTF
3405 non_portable_endpoint++;
3410 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3411 * named character, like \N{LATIN SMALL LETTER A}, or a named
3412 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3413 * GRAVE} (except y/// can't handle the latter, croaking). For
3414 * convenience all three forms are referred to as "named
3415 * characters" below.
3417 * For patterns, \N also can mean to match a non-newline. Code
3418 * before this 'switch' statement should already have handled
3419 * this situation, and hence this code only has to deal with
3420 * the named character cases.
3422 * For non-patterns, the named characters are converted to
3423 * their string equivalents. In patterns, named characters are
3424 * not converted to their ultimate forms for the same reasons
3425 * that other escapes aren't. Instead, they are converted to
3426 * the \N{U+...} form to get the value from the charnames that
3427 * is in effect right now, while preserving the fact that it
3428 * was a named character, so that the regex compiler knows
3431 * The structure of this section of code (besides checking for
3432 * errors and upgrading to utf8) is:
3433 * If the named character is of the form \N{U+...}, pass it
3434 * through if a pattern; otherwise convert the code point
3436 * Otherwise must be some \N{NAME}: convert to
3437 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3439 * Transliteration is an exception. The conversion to utf8 is
3440 * only done if the code point requires it to be representable.
3442 * Here, 's' points to the 'N'; the test below is guaranteed to
3443 * succeed if we are being called on a pattern, as we already
3444 * know from a test above that the next character is a '{'. A
3445 * non-pattern \N must mean 'named character', which requires
3449 yyerror("Missing braces on \\N{}");
3454 /* If there is no matching '}', it is an error. */
3455 if (! (e = strchr(s, '}'))) {
3456 if (! PL_lex_inpat) {
3457 yyerror("Missing right brace on \\N{}");
3459 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3464 /* Here it looks like a named character */
3466 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3467 s += 2; /* Skip to next char after the 'U+' */
3470 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3471 /* Check the syntax. */
3474 if (!isXDIGIT(*s)) {
3477 "Invalid hexadecimal number in \\N{U+...}"
3485 else if ((*s == '.' || *s == '_')
3491 /* Pass everything through unchanged.
3492 * +1 is for the '}' */
3493 Copy(orig_s, d, e - orig_s + 1, char);
3494 d += e - orig_s + 1;
3496 else { /* Not a pattern: convert the hex to string */
3497 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3498 | PERL_SCAN_SILENT_ILLDIGIT
3499 | PERL_SCAN_DISALLOW_PREFIX;
3501 uv = grok_hex(s, &len, &flags, NULL);
3502 if (len == 0 || (len != (STRLEN)(e - s)))
3505 /* For non-tr///, if the destination is not in utf8,
3506 * unconditionally recode it to be so. This is
3507 * because \N{} implies Unicode semantics, and scalars
3508 * have to be in utf8 to guarantee those semantics.
3509 * tr/// doesn't care about Unicode rules, so no need
3510 * there to upgrade to UTF-8 for small enough code
3512 if (! has_utf8 && ( uv > 0xFF
3513 || PL_lex_inwhat != OP_TRANS))
3515 SvCUR_set(sv, d - SvPVX_const(sv));
3518 /* See Note on sizing above. */
3519 sv_utf8_upgrade_flags_grow(
3521 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3522 UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
3523 d = SvPVX(sv) + SvCUR(sv);
3527 /* Add the (Unicode) code point to the output. */
3528 if (OFFUNI_IS_INVARIANT(uv)) {
3529 *d++ = (char) LATIN1_TO_NATIVE(uv);
3532 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3536 else /* Here is \N{NAME} but not \N{U+...}. */
3537 if ((res = get_and_check_backslash_N_name(s, e)))
3540 const char *str = SvPV_const(res, len);
3543 if (! len) { /* The name resolved to an empty string */
3544 Copy("\\N{}", d, 4, char);
3548 /* In order to not lose information for the regex
3549 * compiler, pass the result in the specially made
3550 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3551 * the code points in hex of each character
3552 * returned by charnames */
3554 const char *str_end = str + len;
3555 const STRLEN off = d - SvPVX_const(sv);
3557 if (! SvUTF8(res)) {
3558 /* For the non-UTF-8 case, we can determine the
3559 * exact length needed without having to parse
3560 * through the string. Each character takes up
3561 * 2 hex digits plus either a trailing dot or
3563 const char initial_text[] = "\\N{U+";
3564 const STRLEN initial_len = sizeof(initial_text)
3566 d = off + SvGROW(sv, off
3569 /* +1 for trailing NUL */
3572 + (STRLEN)(send - e));
3573 Copy(initial_text, d, initial_len, char);
3575 while (str < str_end) {
3578 my_snprintf(hex_string,
3582 /* The regex compiler is
3583 * expecting Unicode, not
3585 (U8) NATIVE_TO_LATIN1(*str));
3586 PERL_MY_SNPRINTF_POST_GUARD(len,
3587 sizeof(hex_string));
3588 Copy(hex_string, d, 3, char);
3592 d--; /* Below, we will overwrite the final
3593 dot with a right brace */
3596 STRLEN char_length; /* cur char's byte length */
3598 /* and the number of bytes after this is
3599 * translated into hex digits */
3600 STRLEN output_length;
3602 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3603 * for max('U+', '.'); and 1 for NUL */
3604 char hex_string[2 * UTF8_MAXBYTES + 5];
3606 /* Get the first character of the result. */
3607 U32 uv = utf8n_to_uvchr((U8 *) str,
3611 /* Convert first code point to Unicode hex,
3612 * including the boiler plate before it. */
3614 my_snprintf(hex_string, sizeof(hex_string),
3616 (unsigned int) NATIVE_TO_UNI(uv));
3618 /* Make sure there is enough space to hold it */
3619 d = off + SvGROW(sv, off
3621 + (STRLEN)(send - e)
3622 + 2); /* '}' + NUL */
3624 Copy(hex_string, d, output_length, char);
3627 /* For each subsequent character, append dot and
3628 * its Unicode code point in hex */
3629 while ((str += char_length) < str_end) {
3630 const STRLEN off = d - SvPVX_const(sv);
3631 U32 uv = utf8n_to_uvchr((U8 *) str,
3636 my_snprintf(hex_string,
3639 (unsigned int) NATIVE_TO_UNI(uv));
3641 d = off + SvGROW(sv, off
3643 + (STRLEN)(send - e)
3644 + 2); /* '}' + NUL */
3645 Copy(hex_string, d, output_length, char);
3650 *d++ = '}'; /* Done. Add the trailing brace */
3653 else { /* Here, not in a pattern. Convert the name to a
3656 if (PL_lex_inwhat == OP_TRANS) {
3657 str = SvPV_const(res, len);
3658 if (len > ((SvUTF8(res))
3662 yyerror(Perl_form(aTHX_
3663 "%.*s must not be a named sequence"
3664 " in transliteration operator",
3665 /* +1 to include the "}" */
3666 (int) (e + 1 - start), start));
3667 goto end_backslash_N;
3670 else if (! SvUTF8(res)) {
3671 /* Make sure \N{} return is UTF-8. This is because
3672 * \N{} implies Unicode semantics, and scalars have to
3673 * be in utf8 to guarantee those semantics; but not
3674 * needed in tr/// */
3675 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3676 str = SvPV_const(res, len);
3679 /* Upgrade destination to be utf8 if this new
3681 if (! has_utf8 && SvUTF8(res)) {
3682 SvCUR_set(sv, d - SvPVX_const(sv));
3685 /* See Note on sizing above. */
3686 sv_utf8_upgrade_flags_grow(sv,
3687 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3688 len + (STRLEN)(send - s) + 1);
3689 d = SvPVX(sv) + SvCUR(sv);
3691 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3693 /* See Note on sizing above. (NOTE: SvCUR() is not
3694 * set correctly here). */
3695 const STRLEN off = d - SvPVX_const(sv);
3696 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3698 Copy(str, d, len, char);
3704 } /* End \N{NAME} */
3708 backslash_N++; /* \N{} is defined to be Unicode */
3710 s = e + 1; /* Point to just after the '}' */
3713 /* \c is a control character */
3717 *d++ = grok_bslash_c(*s++, 1);
3720 yyerror("Missing control char name in \\c");
3723 non_portable_endpoint++;
3727 /* printf-style backslashes, formfeeds, newlines, etc */
3753 } /* end if (backslash) */
3756 /* If we started with encoded form, or already know we want it,
3757 then encode the next character */
3758 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3761 /* One might think that it is wasted effort in the case of the
3762 * source being utf8 (this_utf8 == TRUE) to take the next character
3763 * in the source, convert it to an unsigned value, and then convert
3764 * it back again. But the source has not been validated here. The
3765 * routine that does the conversion checks for errors like
3768 const UV nextuv = (this_utf8)
3769 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3771 const STRLEN need = UVCHR_SKIP(nextuv);
3773 SvCUR_set(sv, d - SvPVX_const(sv));
3776 /* See Note on sizing above. */
3777 sv_utf8_upgrade_flags_grow(sv,
3778 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3779 need + (STRLEN)(send - s) + 1);
3780 d = SvPVX(sv) + SvCUR(sv);
3782 } else if (need > len) {
3783 /* encoded value larger than old, may need extra space (NOTE:
3784 * SvCUR() is not set correctly here). See Note on sizing
3786 const STRLEN off = d - SvPVX_const(sv);
3787 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3791 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3796 } /* while loop to process each character */
3798 /* terminate the string and set up the sv */
3800 SvCUR_set(sv, d - SvPVX_const(sv));
3801 if (SvCUR(sv) >= SvLEN(sv))
3802 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3803 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3806 if (IN_ENCODING && !has_utf8) {
3807 sv_recode_to_utf8(sv, _get_encoding());
3813 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3814 PL_sublex_info.sub_op->op_private |=
3815 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3819 /* shrink the sv if we allocated more than we used */
3820 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3821 SvPV_shrink_to_cur(sv);
3824 /* return the substring (via pl_yylval) only if we parsed anything */
3827 for (; s2 < s; s2++) {
3829 COPLINE_INC_WITH_HERELINES;
3831 SvREFCNT_inc_simple_void_NN(sv);
3832 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3833 && ! PL_parser->lex_re_reparsing)
3835 const char *const key = PL_lex_inpat ? "qr" : "q";
3836 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3840 if (PL_lex_inwhat == OP_TRANS) {
3843 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3846 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3854 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3857 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3859 LEAVE_with_name("scan_const");
3864 * Returns TRUE if there's more to the expression (e.g., a subscript),
3867 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3869 * ->[ and ->{ return TRUE
3870 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3871 * { and [ outside a pattern are always subscripts, so return TRUE
3872 * if we're outside a pattern and it's not { or [, then return FALSE
3873 * if we're in a pattern and the first char is a {
3874 * {4,5} (any digits around the comma) returns FALSE
3875 * if we're in a pattern and the first char is a [
3877 * [SOMETHING] has a funky algorithm to decide whether it's a
3878 * character class or not. It has to deal with things like
3879 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3880 * anything else returns TRUE
3883 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3886 S_intuit_more(pTHX_ char *s)
3888 PERL_ARGS_ASSERT_INTUIT_MORE;
3890 if (PL_lex_brackets)
3892 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3894 if (*s == '-' && s[1] == '>'
3895 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3896 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3897 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3899 if (*s != '{' && *s != '[')
3904 /* In a pattern, so maybe we have {n,m}. */
3912 /* On the other hand, maybe we have a character class */
3915 if (*s == ']' || *s == '^')
3918 /* this is terrifying, and it works */
3921 const char * const send = strchr(s,']');
3922 unsigned char un_char, last_un_char;
3923 char tmpbuf[sizeof PL_tokenbuf * 4];
3925 if (!send) /* has to be an expression */
3927 weight = 2; /* let's weigh the evidence */
3931 else if (isDIGIT(*s)) {
3933 if (isDIGIT(s[1]) && s[2] == ']')
3939 Zero(seen,256,char);
3941 for (; s < send; s++) {
3942 last_un_char = un_char;
3943 un_char = (unsigned char)*s;
3948 weight -= seen[un_char] * 10;
3949 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3951 char *tmp = PL_bufend;
3952 PL_bufend = (char*)send;
3953 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3955 len = (int)strlen(tmpbuf);
3956 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3957 UTF ? SVf_UTF8 : 0, SVt_PV))
3964 && strchr("[#!%*<>()-=",s[1]))
3966 if (/*{*/ strchr("])} =",s[2]))
3975 if (strchr("wds]",s[1]))
3977 else if (seen[(U8)'\''] || seen[(U8)'"'])
3979 else if (strchr("rnftbxcav",s[1]))
3981 else if (isDIGIT(s[1])) {
3983 while (s[1] && isDIGIT(s[1]))
3993 if (strchr("aA01! ",last_un_char))
3995 if (strchr("zZ79~",s[1]))
3997 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3998 weight -= 5; /* cope with negative subscript */
4001 if (!isWORDCHAR(last_un_char)
4002 && !(last_un_char == '$' || last_un_char == '@'
4003 || last_un_char == '&')
4004 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4008 if (keyword(d, s - d, 0))
4011 if (un_char == last_un_char + 1)
4013 weight -= seen[un_char];
4018 if (weight >= 0) /* probably a character class */
4028 * Does all the checking to disambiguate
4030 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4031 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4033 * First argument is the stuff after the first token, e.g. "bar".
4035 * Not a method if foo is a filehandle.
4036 * Not a method if foo is a subroutine prototyped to take a filehandle.
4037 * Not a method if it's really "Foo $bar"
4038 * Method if it's "foo $bar"
4039 * Not a method if it's really "print foo $bar"
4040 * Method if it's really "foo package::" (interpreted as package->foo)
4041 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4042 * Not a method if bar is a filehandle or package, but is quoted with
4047 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4049 char *s = start + (*start == '$');
4050 char tmpbuf[sizeof PL_tokenbuf];
4053 /* Mustn't actually add anything to a symbol table.
4054 But also don't want to "initialise" any placeholder
4055 constants that might already be there into full
4056 blown PVGVs with attached PVCV. */
4058 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4060 PERL_ARGS_ASSERT_INTUIT_METHOD;
4062 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4064 if (cv && SvPOK(cv)) {
4065 const char *proto = CvPROTO(cv);
4067 while (*proto && (isSPACE(*proto) || *proto == ';'))
4074 if (*start == '$') {
4075 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4076 || isUPPER(*PL_tokenbuf))
4081 return *s == '(' ? FUNCMETH : METHOD;
4084 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4085 /* start is the beginning of the possible filehandle/object,
4086 * and s is the end of it
4087 * tmpbuf is a copy of it (but with single quotes as double colons)
4090 if (!keyword(tmpbuf, len, 0)) {
4091 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4096 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4097 if (indirgv && GvCVu(indirgv))
4099 /* filehandle or package name makes it a method */
4100 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4102 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4103 return 0; /* no assumptions -- "=>" quotes bareword */
4105 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4106 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4107 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4111 return *s == '(' ? FUNCMETH : METHOD;
4117 /* Encoded script support. filter_add() effectively inserts a
4118 * 'pre-processing' function into the current source input stream.
4119 * Note that the filter function only applies to the current source file
4120 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4122 * The datasv parameter (which may be NULL) can be used to pass
4123 * private data to this instance of the filter. The filter function
4124 * can recover the SV using the FILTER_DATA macro and use it to
4125 * store private buffers and state information.
4127 * The supplied datasv parameter is upgraded to a PVIO type
4128 * and the IoDIRP/IoANY field is used to store the function pointer,
4129 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4130 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4131 * private use must be set using malloc'd pointers.
4135 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4143 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4144 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4146 if (!PL_rsfp_filters)
4147 PL_rsfp_filters = newAV();
4150 SvUPGRADE(datasv, SVt_PVIO);
4151 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4152 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4153 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4154 FPTR2DPTR(void *, IoANY(datasv)),
4155 SvPV_nolen(datasv)));
4156 av_unshift(PL_rsfp_filters, 1);
4157 av_store(PL_rsfp_filters, 0, datasv) ;
4159 !PL_parser->filtered
4160 && PL_parser->lex_flags & LEX_EVALBYTES
4161 && PL_bufptr < PL_bufend
4163 const char *s = PL_bufptr;
4164 while (s < PL_bufend) {
4166 SV *linestr = PL_parser->linestr;
4167 char *buf = SvPVX(linestr);
4168 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4169 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4170 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4171 STRLEN const linestart_pos = PL_parser->linestart - buf;
4172 STRLEN const last_uni_pos =
4173 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4174 STRLEN const last_lop_pos =
4175 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4176 av_push(PL_rsfp_filters, linestr);
4177 PL_parser->linestr =
4178 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4179 buf = SvPVX(PL_parser->linestr);
4180 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4181 PL_parser->bufptr = buf + bufptr_pos;
4182 PL_parser->oldbufptr = buf + oldbufptr_pos;
4183 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4184 PL_parser->linestart = buf + linestart_pos;
4185 if (PL_parser->last_uni)
4186 PL_parser->last_uni = buf + last_uni_pos;
4187 if (PL_parser->last_lop)
4188 PL_parser->last_lop = buf + last_lop_pos;
4189 SvLEN(linestr) = SvCUR(linestr);
4190 SvCUR(linestr) = s-SvPVX(linestr);
4191 PL_parser->filtered = 1;
4201 /* Delete most recently added instance of this filter function. */
4203 Perl_filter_del(pTHX_ filter_t funcp)
4207 PERL_ARGS_ASSERT_FILTER_DEL;
4210 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4211 FPTR2DPTR(void*, funcp)));
4213 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4215 /* if filter is on top of stack (usual case) just pop it off */
4216 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4217 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4218 sv_free(av_pop(PL_rsfp_filters));
4222 /* we need to search for the correct entry and clear it */
4223 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4227 /* Invoke the idxth filter function for the current rsfp. */
4228 /* maxlen 0 = read one text line */
4230 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4234 /* This API is bad. It should have been using unsigned int for maxlen.
4235 Not sure if we want to change the API, but if not we should sanity
4236 check the value here. */
4237 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4239 PERL_ARGS_ASSERT_FILTER_READ;
4241 if (!PL_parser || !PL_rsfp_filters)
4243 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4244 /* Provide a default input filter to make life easy. */
4245 /* Note that we append to the line. This is handy. */
4246 DEBUG_P(PerlIO_printf(Perl_debug_log,
4247 "filter_read %d: from rsfp\n", idx));
4248 if (correct_length) {
4251 const int old_len = SvCUR(buf_sv);
4253 /* ensure buf_sv is large enough */
4254 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4255 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4256 correct_length)) <= 0) {
4257 if (PerlIO_error(PL_rsfp))
4258 return -1; /* error */
4260 return 0 ; /* end of file */
4262 SvCUR_set(buf_sv, old_len + len) ;
4263 SvPVX(buf_sv)[old_len + len] = '\0';
4266 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4267 if (PerlIO_error(PL_rsfp))
4268 return -1; /* error */
4270 return 0 ; /* end of file */
4273 return SvCUR(buf_sv);
4275 /* Skip this filter slot if filter has been deleted */
4276 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4277 DEBUG_P(PerlIO_printf(Perl_debug_log,
4278 "filter_read %d: skipped (filter deleted)\n",
4280 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4282 if (SvTYPE(datasv) != SVt_PVIO) {
4283 if (correct_length) {
4285 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4286 if (!remainder) return 0; /* eof */
4287 if (correct_length > remainder) correct_length = remainder;
4288 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4289 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4292 const char *s = SvEND(datasv);
4293 const char *send = SvPVX(datasv) + SvLEN(datasv);
4301 if (s == send) return 0; /* eof */
4302 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4303 SvCUR_set(datasv, s-SvPVX(datasv));
4305 return SvCUR(buf_sv);
4307 /* Get function pointer hidden within datasv */
4308 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4309 DEBUG_P(PerlIO_printf(Perl_debug_log,
4310 "filter_read %d: via function %p (%s)\n",
4311 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4312 /* Call function. The function is expected to */
4313 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4314 /* Return: <0:error, =0:eof, >0:not eof */
4315 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4319 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4321 PERL_ARGS_ASSERT_FILTER_GETS;
4323 #ifdef PERL_CR_FILTER
4324 if (!PL_rsfp_filters) {
4325 filter_add(S_cr_textfilter,NULL);
4328 if (PL_rsfp_filters) {
4330 SvCUR_set(sv, 0); /* start with empty line */
4331 if (FILTER_READ(0, sv, 0) > 0)
4332 return ( SvPVX(sv) ) ;
4337 return (sv_gets(sv, PL_rsfp, append));
4341 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4345 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4347 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4351 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4352 && (gv = gv_fetchpvn_flags(pkgname,
4354 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4356 return GvHV(gv); /* Foo:: */
4359 /* use constant CLASS => 'MyClass' */
4360 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4361 if (gv && GvCV(gv)) {
4362 SV * const sv = cv_const_sv(GvCV(gv));
4364 return gv_stashsv(sv, 0);
4367 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4372 S_tokenize_use(pTHX_ int is_use, char *s) {
4373 PERL_ARGS_ASSERT_TOKENIZE_USE;
4375 if (PL_expect != XSTATE)
4376 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4377 is_use ? "use" : "no"));
4380 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4381 s = force_version(s, TRUE);
4382 if (*s == ';' || *s == '}'
4383 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4384 NEXTVAL_NEXTTOKE.opval = NULL;
4387 else if (*s == 'v') {
4388 s = force_word(s,WORD,FALSE,TRUE);
4389 s = force_version(s, FALSE);
4393 s = force_word(s,WORD,FALSE,TRUE);
4394 s = force_version(s, FALSE);
4396 pl_yylval.ival = is_use;
4400 static const char* const exp_name[] =
4401 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4402 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4407 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4409 S_word_takes_any_delimeter(char *p, STRLEN len)
4411 return (len == 1 && strchr("msyq", p[0]))
4413 && ((p[0] == 't' && p[1] == 'r')
4414 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4418 S_check_scalar_slice(pTHX_ char *s)
4421 while (*s == ' ' || *s == '\t') s++;
4422 if (*s == 'q' && s[1] == 'w'
4423 && !isWORDCHAR_lazy_if(s+2,UTF))
4425 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4426 s += UTF ? UTF8SKIP(s) : 1;
4427 if (*s == '}' || *s == ']')
4428 pl_yylval.ival = OPpSLICEWARNING;
4434 Works out what to call the token just pulled out of the input
4435 stream. The yacc parser takes care of taking the ops we return and
4436 stitching them into a tree.
4439 The type of the next token
4442 Switch based on the current state:
4443 - if we already built the token before, use it
4444 - if we have a case modifier in a string, deal with that
4445 - handle other cases of interpolation inside a string
4446 - scan the next line if we are inside a format
4447 In the normal state switch on the next character:
4449 if alphabetic, go to key lookup
4450 unrecoginized character - croak
4451 - 0/4/26: handle end-of-line or EOF
4452 - cases for whitespace
4453 - \n and #: handle comments and line numbers
4454 - various operators, brackets and sigils
4457 - 'v': vstrings (or go to key lookup)
4458 - 'x' repetition operator (or go to key lookup)
4459 - other ASCII alphanumerics (key lookup begins here):
4462 scan built-in keyword (but do nothing with it yet)
4463 check for statement label
4464 check for lexical subs
4465 goto just_a_word if there is one
4466 see whether built-in keyword is overridden
4467 switch on keyword number:
4468 - default: just_a_word:
4469 not a built-in keyword; handle bareword lookup
4470 disambiguate between method and sub call
4471 fall back to bareword
4472 - cases for built-in keywords
4480 char *s = PL_bufptr;
4484 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4488 /* orig_keyword, gvp, and gv are initialized here because
4489 * jump to the label just_a_word_zero can bypass their
4490 * initialization later. */
4491 I32 orig_keyword = 0;
4496 SV* tmp = newSVpvs("");
4497 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4498 (IV)CopLINE(PL_curcop),
4499 lex_state_names[PL_lex_state],
4500 exp_name[PL_expect],
4501 pv_display(tmp, s, strlen(s), 0, 60));
4505 /* when we've already built the next token, just pull it out of the queue */
4508 pl_yylval = PL_nextval[PL_nexttoke];
4510 PL_lex_state = PL_lex_defer;
4511 PL_lex_defer = LEX_NORMAL;
4515 next_type = PL_nexttype[PL_nexttoke];
4516 if (next_type & (7<<24)) {
4517 if (next_type & (1<<24)) {
4518 if (PL_lex_brackets > 100)
4519 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4520 PL_lex_brackstack[PL_lex_brackets++] =
4521 (char) ((next_type >> 16) & 0xff);
4523 if (next_type & (2<<24))
4524 PL_lex_allbrackets++;
4525 if (next_type & (4<<24))
4526 PL_lex_allbrackets--;
4527 next_type &= 0xffff;
4529 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4533 switch (PL_lex_state) {
4535 case LEX_INTERPNORMAL:
4538 /* interpolated case modifiers like \L \U, including \Q and \E.
4539 when we get here, PL_bufptr is at the \
4541 case LEX_INTERPCASEMOD:
4543 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4545 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4546 PL_bufptr, PL_bufend, *PL_bufptr);
4548 /* handle \E or end of string */
4549 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4551 if (PL_lex_casemods) {
4552 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4553 PL_lex_casestack[PL_lex_casemods] = '\0';
4555 if (PL_bufptr != PL_bufend
4556 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4557 || oldmod == 'F')) {
4559 PL_lex_state = LEX_INTERPCONCAT;
4561 PL_lex_allbrackets--;
4564 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4565 /* Got an unpaired \E */
4566 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4567 "Useless use of \\E");
4569 if (PL_bufptr != PL_bufend)
4571 PL_lex_state = LEX_INTERPCONCAT;
4575 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4576 "### Saw case modifier\n"); });
4578 if (s[1] == '\\' && s[2] == 'E') {
4580 PL_lex_state = LEX_INTERPCONCAT;
4585 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4586 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4587 if ((*s == 'L' || *s == 'U' || *s == 'F')
4588 && (strchr(PL_lex_casestack, 'L')
4589 || strchr(PL_lex_casestack, 'U')
4590 || strchr(PL_lex_casestack, 'F')))
4592 PL_lex_casestack[--PL_lex_casemods] = '\0';
4593 PL_lex_allbrackets--;
4596 if (PL_lex_casemods > 10)
4597 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4598 PL_lex_casestack[PL_lex_casemods++] = *s;
4599 PL_lex_casestack[PL_lex_casemods] = '\0';
4600 PL_lex_state = LEX_INTERPCONCAT;
4601 NEXTVAL_NEXTTOKE.ival = 0;
4602 force_next((2<<24)|'(');
4604 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4606 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4608 NEXTVAL_NEXTTOKE.ival = OP_LC;
4610 NEXTVAL_NEXTTOKE.ival = OP_UC;
4612 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4614 NEXTVAL_NEXTTOKE.ival = OP_FC;
4616 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4620 if (PL_lex_starts) {
4623 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4624 if (PL_lex_casemods == 1 && PL_lex_inpat)
4627 AopNOASSIGN(OP_CONCAT);
4633 case LEX_INTERPPUSH:
4634 return REPORT(sublex_push());
4636 case LEX_INTERPSTART:
4637 if (PL_bufptr == PL_bufend)
4638 return REPORT(sublex_done());
4639 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4640 "### Interpolated variable\n"); });
4642 /* for /@a/, we leave the joining for the regex engine to do
4643 * (unless we're within \Q etc) */
4644 PL_lex_dojoin = (*PL_bufptr == '@'
4645 && (!PL_lex_inpat || PL_lex_casemods));
4646 PL_lex_state = LEX_INTERPNORMAL;
4647 if (PL_lex_dojoin) {
4648 NEXTVAL_NEXTTOKE.ival = 0;
4650 force_ident("\"", '$');
4651 NEXTVAL_NEXTTOKE.ival = 0;
4653 NEXTVAL_NEXTTOKE.ival = 0;
4654 force_next((2<<24)|'(');
4655 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4658 /* Convert (?{...}) and friends to 'do {...}' */
4659 if (PL_lex_inpat && *PL_bufptr == '(') {
4660 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4662 if (*PL_bufptr != '{')
4664 PL_expect = XTERMBLOCK;
4668 if (PL_lex_starts++) {
4670 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4671 if (!PL_lex_casemods && PL_lex_inpat)
4674 AopNOASSIGN(OP_CONCAT);
4678 case LEX_INTERPENDMAYBE:
4679 if (intuit_more(PL_bufptr)) {
4680 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4686 /* Treat state as LEX_NORMAL if we have no inner lexing scope.
4687 XXX This hack can be removed if we stop setting PL_lex_state to
4688 LEX_KNOWNEXT, as can the hack under LEX_INTREPCONCAT below. */
4689 if (UNLIKELY(!PL_lex_inwhat)) {
4690 PL_lex_state = LEX_NORMAL;
4694 if (PL_lex_dojoin) {
4695 const U8 dojoin_was = PL_lex_dojoin;
4696 PL_lex_dojoin = FALSE;
4697 PL_lex_state = LEX_INTERPCONCAT;
4698 PL_lex_allbrackets--;
4699 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4701 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4702 && SvEVALED(PL_lex_repl))
4704 if (PL_bufptr != PL_bufend)
4705 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4708 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4709 re_eval_str. If the here-doc body’s length equals the previous
4710 value of re_eval_start, re_eval_start will now be null. So
4711 check re_eval_str as well. */
4712 if (PL_parser->lex_shared->re_eval_start
4713 || PL_parser->lex_shared->re_eval_str) {
4715 if (*PL_bufptr != ')')
4716 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4718 /* having compiled a (?{..}) expression, return the original
4719 * text too, as a const */
4720 if (PL_parser->lex_shared->re_eval_str) {
4721 sv = PL_parser->lex_shared->re_eval_str;
4722 PL_parser->lex_shared->re_eval_str = NULL;
4724 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4725 SvPV_shrink_to_cur(sv);
4727 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4728 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4729 NEXTVAL_NEXTTOKE.opval =
4730 (OP*)newSVOP(OP_CONST, 0,
4733 PL_parser->lex_shared->re_eval_start = NULL;
4739 case LEX_INTERPCONCAT:
4741 if (PL_lex_brackets)
4742 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4743 (long) PL_lex_brackets);
4745 /* Treat state as LEX_NORMAL when not in an inner lexing scope.
4746 XXX This hack can be removed if we stop setting PL_lex_state to
4748 if (UNLIKELY(!PL_lex_inwhat)) {
4749 PL_lex_state = LEX_NORMAL;
4753 if (PL_bufptr == PL_bufend)
4754 return REPORT(sublex_done());
4756 /* m'foo' still needs to be parsed for possible (?{...}) */
4757 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4758 SV *sv = newSVsv(PL_linestr);
4760 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4764 s = scan_const(PL_bufptr);
4766 PL_lex_state = LEX_INTERPCASEMOD;
4768 PL_lex_state = LEX_INTERPSTART;
4771 if (s != PL_bufptr) {
4772 NEXTVAL_NEXTTOKE = pl_yylval;
4775 if (PL_lex_starts++) {
4776 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4777 if (!PL_lex_casemods && PL_lex_inpat)
4780 AopNOASSIGN(OP_CONCAT);
4790 s = scan_formline(PL_bufptr);
4791 if (!PL_lex_formbrack)
4800 /* We really do *not* want PL_linestr ever becoming a COW. */
4801 assert (!SvIsCOW(PL_linestr));
4803 PL_oldoldbufptr = PL_oldbufptr;
4805 PL_parser->saw_infix_sigil = 0;
4810 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4813 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4814 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4816 SVs_TEMP | SVf_UTF8),
4817 10, UNI_DISPLAY_ISPRINT)
4818 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4819 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4820 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4821 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4825 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4826 UTF8fARG(UTF, (s - d), d),
4831 goto fake_eof; /* emulate EOF on ^D or ^Z */
4833 if ((!PL_rsfp || PL_lex_inwhat)
4834 && (!PL_parser->filtered || s+1 < PL_bufend)) {
4838 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
4840 yyerror((const char *)
4842 ? "Format not terminated"
4843 : "Missing right curly or square bracket"));
4845 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4846 "### Tokener got EOF\n");
4850 if (s++ < PL_bufend)
4851 goto retry; /* ignore stray nulls */
4854 if (!PL_in_eval && !PL_preambled) {
4855 PL_preambled = TRUE;
4857 /* Generate a string of Perl code to load the debugger.
4858 * If PERL5DB is set, it will return the contents of that,
4859 * otherwise a compile-time require of perl5db.pl. */
4861 const char * const pdb = PerlEnv_getenv("PERL5DB");
4864 sv_setpv(PL_linestr, pdb);
4865 sv_catpvs(PL_linestr,";");
4867 SETERRNO(0,SS_NORMAL);
4868 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4870 PL_parser->preambling = CopLINE(PL_curcop);
4872 sv_setpvs(PL_linestr,"");
4873 if (PL_preambleav) {
4874 SV **svp = AvARRAY(PL_preambleav);
4875 SV **const end = svp + AvFILLp(PL_preambleav);
4877 sv_catsv(PL_linestr, *svp);
4879 sv_catpvs(PL_linestr, ";");
4881 sv_free(MUTABLE_SV(PL_preambleav));
4882 PL_preambleav = NULL;
4885 sv_catpvs(PL_linestr,
4886 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4887 if (PL_minus_n || PL_minus_p) {
4888 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4890 sv_catpvs(PL_linestr,"chomp;");
4893 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4894 || *PL_splitstr == '"')
4895 && strchr(PL_splitstr + 1, *PL_splitstr))
4896 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4898 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4899 bytes can be used as quoting characters. :-) */
4900 const char *splits = PL_splitstr;
4901 sv_catpvs(PL_linestr, "our @F=split(q\0");
4904 if (*splits == '\\')
4905 sv_catpvn(PL_linestr, splits, 1);
4906 sv_catpvn(PL_linestr, splits, 1);
4907 } while (*splits++);
4908 /* This loop will embed the trailing NUL of
4909 PL_linestr as the last thing it does before
4911 sv_catpvs(PL_linestr, ");");
4915 sv_catpvs(PL_linestr,"our @F=split(' ');");
4918 sv_catpvs(PL_linestr, "\n");
4919 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4920 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4921 PL_last_lop = PL_last_uni = NULL;
4922 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4923 update_debugger_info(PL_linestr, NULL, 0);
4928 bof = PL_rsfp ? TRUE : FALSE;
4931 fake_eof = LEX_FAKE_EOF;
4933 PL_bufptr = PL_bufend;
4934 COPLINE_INC_WITH_HERELINES;
4935 if (!lex_next_chunk(fake_eof)) {
4936 CopLINE_dec(PL_curcop);
4938 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4940 CopLINE_dec(PL_curcop);
4942 /* If it looks like the start of a BOM or raw UTF-16,
4943 * check if it in fact is. */
4946 || *(U8*)s == BOM_UTF8_FIRST_BYTE
4950 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4951 bof = (offset == (Off_t)SvCUR(PL_linestr));
4952 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4953 /* offset may include swallowed CR */
4955 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4959 s = swallow_bom((U8*)s);
4962 if (PL_parser->in_pod) {
4963 /* Incest with pod. */
4964 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4965 sv_setpvs(PL_linestr, "");
4966 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4967 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4968 PL_last_lop = PL_last_uni = NULL;
4969 PL_parser->in_pod = 0;
4972 if (PL_rsfp || PL_parser->filtered)
4974 } while (PL_parser->in_pod);
4975 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4976 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4977 PL_last_lop = PL_last_uni = NULL;
4978 if (CopLINE(PL_curcop) == 1) {
4979 while (s < PL_bufend && isSPACE(*s))
4981 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4985 if (*s == '#' && *(s+1) == '!')
4987 #ifdef ALTERNATE_SHEBANG
4989 static char const as[] = ALTERNATE_SHEBANG;
4990 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4991 d = s + (sizeof(as) - 1);
4993 #endif /* ALTERNATE_SHEBANG */
5002 while (*d && !isSPACE(*d))
5006 #ifdef ARG_ZERO_IS_SCRIPT
5007 if (ipathend > ipath) {
5009 * HP-UX (at least) sets argv[0] to the script name,
5010 * which makes $^X incorrect. And Digital UNIX and Linux,
5011 * at least, set argv[0] to the basename of the Perl
5012 * interpreter. So, having found "#!", we'll set it right.
5014 SV* copfilesv = CopFILESV(PL_curcop);
5017 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5019 assert(SvPOK(x) || SvGMAGICAL(x));
5020 if (sv_eq(x, copfilesv)) {
5021 sv_setpvn(x, ipath, ipathend - ipath);
5027 const char *bstart = SvPV_const(copfilesv, blen);
5028 const char * const lstart = SvPV_const(x, llen);
5030 bstart += blen - llen;
5031 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5032 sv_setpvn(x, ipath, ipathend - ipath);
5039 /* Anything to do if no copfilesv? */
5041 TAINT_NOT; /* $^X is always tainted, but that's OK */
5043 #endif /* ARG_ZERO_IS_SCRIPT */
5048 d = instr(s,"perl -");
5050 d = instr(s,"perl");
5051 if (d && d[4] == '6')
5054 /* avoid getting into infinite loops when shebang
5055 * line contains "Perl" rather than "perl" */
5057 for (d = ipathend-4; d >= ipath; --d) {
5058 if (isALPHA_FOLD_EQ(*d, 'p')
5059 && !ibcmp(d, "perl", 4))
5069 #ifdef ALTERNATE_SHEBANG
5071 * If the ALTERNATE_SHEBANG on this system starts with a
5072 * character that can be part of a Perl expression, then if
5073 * we see it but not "perl", we're probably looking at the
5074 * start of Perl code, not a request to hand off to some
5075 * other interpreter. Similarly, if "perl" is there, but
5076 * not in the first 'word' of the line, we assume the line
5077 * contains the start of the Perl program.
5079 if (d && *s != '#') {
5080 const char *c = ipath;
5081 while (*c && !strchr("; \t\r\n\f\v#", *c))
5084 d = NULL; /* "perl" not in first word; ignore */
5086 *s = '#'; /* Don't try to parse shebang line */
5088 #endif /* ALTERNATE_SHEBANG */
5093 && !instr(s,"indir")
5094 && instr(PL_origargv[0],"perl"))
5101 while (s < PL_bufend && isSPACE(*s))
5103 if (s < PL_bufend) {
5104 Newx(newargv,PL_origargc+3,char*);
5106 while (s < PL_bufend && !isSPACE(*s))
5109 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5112 newargv = PL_origargv;
5115 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5117 Perl_croak(aTHX_ "Can't exec %s", ipath);
5120 while (*d && !isSPACE(*d))
5122 while (SPACE_OR_TAB(*d))
5126 const bool switches_done = PL_doswitches;
5127 const U32 oldpdb = PL_perldb;
5128 const bool oldn = PL_minus_n;
5129 const bool oldp = PL_minus_p;
5133 bool baduni = FALSE;
5135 const char *d2 = d1 + 1;
5136 if (parse_unicode_opts((const char **)&d2)
5140 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5141 const char * const m = d1;
5142 while (*d1 && !isSPACE(*d1))
5144 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5147 d1 = moreswitches(d1);
5149 if (PL_doswitches && !switches_done) {
5150 int argc = PL_origargc;
5151 char **argv = PL_origargv;
5154 } while (argc && argv[0][0] == '-' && argv[0][1]);
5155 init_argv_symbols(argc,argv);
5157 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5158 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5159 /* if we have already added "LINE: while (<>) {",
5160 we must not do it again */
5162 sv_setpvs(PL_linestr, "");
5163 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5164 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5165 PL_last_lop = PL_last_uni = NULL;
5166 PL_preambled = FALSE;
5167 if (PERLDB_LINE_OR_SAVESRC)
5168 (void)gv_fetchfile(PL_origfilename);
5175 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5176 PL_lex_state = LEX_FORMLINE;
5177 force_next(FORMRBRACK);
5182 #ifdef PERL_STRICT_CR
5183 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5185 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5187 case ' ': case '\t': case '\f': case '\v':
5192 if (PL_lex_state != LEX_NORMAL
5193 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5195 const bool in_comment = *s == '#';
5196 if (*s == '#' && s == PL_linestart && PL_in_eval
5197 && !PL_rsfp && !PL_parser->filtered) {
5198 /* handle eval qq[#line 1 "foo"\n ...] */
5199 CopLINE_dec(PL_curcop);
5203 while (d < PL_bufend && *d != '\n')
5207 else if (d > PL_bufend)
5208 /* Found by Ilya: feed random input to Perl. */
5209 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5212 if (in_comment && d == PL_bufend
5213 && PL_lex_state == LEX_INTERPNORMAL
5214 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5215 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5218 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5219 PL_lex_state = LEX_FORMLINE;
5220 force_next(FORMRBRACK);
5225 while (s < PL_bufend && *s != '\n')
5233 else if (s > PL_bufend)
5234 /* Found by Ilya: feed random input to Perl. */
5235 Perl_croak(aTHX_ "panic: input overflow");
5239 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5247 while (s < PL_bufend && SPACE_OR_TAB(*s))
5250 if (strnEQ(s,"=>",2)) {
5251 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5252 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5253 OPERATOR('-'); /* unary minus */
5256 case 'r': ftst = OP_FTEREAD; break;
5257 case 'w': ftst = OP_FTEWRITE; break;
5258 case 'x': ftst = OP_FTEEXEC; break;
5259 case 'o': ftst = OP_FTEOWNED; break;
5260 case 'R': ftst = OP_FTRREAD; break;
5261 case 'W': ftst = OP_FTRWRITE; break;
5262 case 'X': ftst = OP_FTREXEC; break;
5263 case 'O': ftst = OP_FTROWNED; break;
5264 case 'e': ftst = OP_FTIS; break;
5265 case 'z': ftst = OP_FTZERO; break;
5266 case 's': ftst = OP_FTSIZE; break;
5267 case 'f': ftst = OP_FTFILE; break;
5268 case 'd': ftst = OP_FTDIR; break;
5269 case 'l': ftst = OP_FTLINK; break;
5270 case 'p': ftst = OP_FTPIPE; break;
5271 case 'S': ftst = OP_FTSOCK; break;
5272 case 'u': ftst = OP_FTSUID; break;
5273 case 'g': ftst = OP_FTSGID; break;
5274 case 'k': ftst = OP_FTSVTX; break;
5275 case 'b': ftst = OP_FTBLK; break;
5276 case 'c': ftst = OP_FTCHR; break;
5277 case 't': ftst = OP_FTTTY; break;
5278 case 'T': ftst = OP_FTTEXT; break;
5279 case 'B': ftst = OP_FTBINARY; break;
5280 case 'M': case 'A': case 'C':
5281 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5283 case 'M': ftst = OP_FTMTIME; break;
5284 case 'A': ftst = OP_FTATIME; break;
5285 case 'C': ftst = OP_FTCTIME; break;
5293 PL_last_uni = PL_oldbufptr;
5294 PL_last_lop_op = (OPCODE)ftst;
5295 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5296 "### Saw file test %c\n", (int)tmp);
5301 /* Assume it was a minus followed by a one-letter named
5302 * subroutine call (or a -bareword), then. */
5303 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5304 "### '-%c' looked like a file test but was not\n",
5311 const char tmp = *s++;
5314 if (PL_expect == XOPERATOR)
5319 else if (*s == '>') {
5322 if (((*s == '$' || *s == '&') && s[1] == '*')
5323 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5324 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5325 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5328 PL_expect = XPOSTDEREF;
5331 if (isIDFIRST_lazy_if(s,UTF)) {
5332 s = force_word(s,METHOD,FALSE,TRUE);
5340 if (PL_expect == XOPERATOR) {
5342 && !PL_lex_allbrackets
5343 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5351 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5353 OPERATOR('-'); /* unary minus */
5359 const char tmp = *s++;
5362 if (PL_expect == XOPERATOR)
5367 if (PL_expect == XOPERATOR) {
5369 && !PL_lex_allbrackets
5370 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5378 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5385 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5386 if (PL_expect != XOPERATOR) {
5387 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5388 PL_expect = XOPERATOR;
5389 force_ident(PL_tokenbuf, '*');
5397 if (*s == '=' && !PL_lex_allbrackets
5398 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5406 && !PL_lex_allbrackets
5407 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5412 PL_parser->saw_infix_sigil = 1;
5417 if (PL_expect == XOPERATOR) {
5419 && !PL_lex_allbrackets
5420 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5425 PL_parser->saw_infix_sigil = 1;
5428 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5429 PL_tokenbuf[0] = '%';
5430 s = scan_ident(s, PL_tokenbuf + 1,
5431 sizeof PL_tokenbuf - 1, FALSE);
5433 if (!PL_tokenbuf[1]) {
5436 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5438 PL_tokenbuf[0] = '@';
5440 PL_expect = XOPERATOR;
5441 force_ident_maybe_lex('%');
5446 bof = FEATURE_BITWISE_IS_ENABLED;
5447 if (bof && s[1] == '.')
5449 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5450 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5456 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5458 if (PL_lex_brackets > 100)
5459 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5460 PL_lex_brackstack[PL_lex_brackets++] = 0;
5461 PL_lex_allbrackets++;
5463 const char tmp = *s++;
5468 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5470 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5473 Perl_ck_warner_d(aTHX_
5474 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5475 "Smartmatch is experimental");
5479 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5481 BCop(OP_SCOMPLEMENT);
5483 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5485 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5492 goto just_a_word_zero_gv;
5498 switch (PL_expect) {
5500 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5502 PL_bufptr = s; /* update in case we back off */
5505 "Use of := for an empty attribute list is not allowed");
5512 PL_expect = XTERMBLOCK;
5516 while (isIDFIRST_lazy_if(s,UTF)) {
5519 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5520 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5521 if (tmp < 0) tmp = -tmp;
5536 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5538 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5539 COPLINE_SET_FROM_MULTI_END;
5541 /* MUST advance bufptr here to avoid bogus
5542 "at end of line" context messages from yyerror().
5544 PL_bufptr = s + len;
5545 yyerror("Unterminated attribute parameter in attribute list");
5549 return REPORT(0); /* EOF indicator */
5553 sv_catsv(sv, PL_lex_stuff);
5554 attrs = op_append_elem(OP_LIST, attrs,
5555 newSVOP(OP_CONST, 0, sv));
5556 SvREFCNT_dec_NN(PL_lex_stuff);
5557 PL_lex_stuff = NULL;
5560 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5562 if (PL_in_my == KEY_our) {
5563 deprecate(":unique");
5566 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5569 /* NOTE: any CV attrs applied here need to be part of
5570 the CVf_BUILTIN_ATTRS define in cv.h! */
5571 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5573 CvLVALUE_on(PL_compcv);
5575 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5577 deprecate(":locked");
5579 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5581 CvMETHOD_on(PL_compcv);
5583 else if (!PL_in_my && len == 5
5584 && strnEQ(SvPVX(sv), "const", len))
5587 Perl_ck_warner_d(aTHX_
5588 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5589 ":const is experimental"
5591 CvANONCONST_on(PL_compcv);
5592 if (!CvANON(PL_compcv))
5593 yyerror(":const is not permitted on named "
5596 /* After we've set the flags, it could be argued that
5597 we don't need to do the attributes.pm-based setting
5598 process, and shouldn't bother appending recognized
5599 flags. To experiment with that, uncomment the
5600 following "else". (Note that's already been
5601 uncommented. That keeps the above-applied built-in
5602 attributes from being intercepted (and possibly
5603 rejected) by a package's attribute routines, but is
5604 justified by the performance win for the common case
5605 of applying only built-in attributes.) */
5607 attrs = op_append_elem(OP_LIST, attrs,
5608 newSVOP(OP_CONST, 0,
5612 if (*s == ':' && s[1] != ':')
5615 break; /* require real whitespace or :'s */
5616 /* XXX losing whitespace on sequential attributes here */
5621 && !(PL_expect == XOPERATOR
5622 ? (*s == '=' || *s == ')')
5623 : (*s == '{' || *s == '(')))
5625 const char q = ((*s == '\'') ? '"' : '\'');
5626 /* If here for an expression, and parsed no attrs, back
5628 if (PL_expect == XOPERATOR && !attrs) {
5632 /* MUST advance bufptr here to avoid bogus "at end of line"
5633 context messages from yyerror().
5636 yyerror( (const char *)
5638 ? Perl_form(aTHX_ "Invalid separator character "
5639 "%c%c%c in attribute list", q, *s, q)
5640 : "Unterminated attribute list" ) );
5648 NEXTVAL_NEXTTOKE.opval = attrs;
5654 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5658 PL_lex_allbrackets--;
5662 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5663 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5667 PL_lex_allbrackets++;
5670 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5677 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5680 PL_lex_allbrackets--;
5686 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5689 if (PL_lex_brackets <= 0)
5690 /* diag_listed_as: Unmatched right %s bracket */
5691 yyerror("Unmatched right square bracket");
5694 PL_lex_allbrackets--;
5695 if (PL_lex_state == LEX_INTERPNORMAL) {
5696 if (PL_lex_brackets == 0) {
5697 if (*s == '-' && s[1] == '>')
5698 PL_lex_state = LEX_INTERPENDMAYBE;
5699 else if (*s != '[' && *s != '{')
5700 PL_lex_state = LEX_INTERPEND;
5707 if (PL_lex_brackets > 100) {
5708 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5710 switch (PL_expect) {
5713 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5714 PL_lex_allbrackets++;
5715 OPERATOR(HASHBRACK);
5717 while (s < PL_bufend && SPACE_OR_TAB(*s))
5720 PL_tokenbuf[0] = '\0';
5721 if (d < PL_bufend && *d == '-') {
5722 PL_tokenbuf[0] = '-';
5724 while (d < PL_bufend && SPACE_OR_TAB(*d))
5727 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5728 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5730 while (d < PL_bufend && SPACE_OR_TAB(*d))
5733 const char minus = (PL_tokenbuf[0] == '-');
5734 s = force_word(s + minus, WORD, FALSE, TRUE);
5742 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5743 PL_lex_allbrackets++;
5748 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5749 PL_lex_allbrackets++;
5753 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5754 PL_lex_allbrackets++;
5759 if (PL_oldoldbufptr == PL_last_lop)
5760 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5762 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5763 PL_lex_allbrackets++;
5766 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5768 /* This hack is to get the ${} in the message. */
5770 yyerror("syntax error");
5773 OPERATOR(HASHBRACK);
5775 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5776 /* ${...} or @{...} etc., but not print {...}
5777 * Skip the disambiguation and treat this as a block.
5779 goto block_expectation;
5781 /* This hack serves to disambiguate a pair of curlies
5782 * as being a block or an anon hash. Normally, expectation
5783 * determines that, but in cases where we're not in a
5784 * position to expect anything in particular (like inside
5785 * eval"") we have to resolve the ambiguity. This code
5786 * covers the case where the first term in the curlies is a
5787 * quoted string. Most other cases need to be explicitly
5788 * disambiguated by prepending a "+" before the opening
5789 * curly in order to force resolution as an anon hash.
5791 * XXX should probably propagate the outer expectation
5792 * into eval"" to rely less on this hack, but that could
5793 * potentially break current behavior of eval"".
5797 if (*s == '\'' || *s == '"' || *s == '`') {
5798 /* common case: get past first string, handling escapes */
5799 for (t++; t < PL_bufend && *t != *s;)
5804 else if (*s == 'q') {
5807 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5808 && !isWORDCHAR(*t))))
5810 /* skip q//-like construct */
5812 char open, close, term;
5815 while (t < PL_bufend && isSPACE(*t))
5817 /* check for q => */
5818 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5819 OPERATOR(HASHBRACK);
5823 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5827 for (t++; t < PL_bufend; t++) {
5828 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5830 else if (*t == open)
5834 for (t++; t < PL_bufend; t++) {
5835 if (*t == '\\' && t+1 < PL_bufend)
5837 else if (*t == close && --brackets <= 0)
5839 else if (*t == open)
5846 /* skip plain q word */
5847 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5850 else if (isWORDCHAR_lazy_if(t,UTF)) {
5852 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5855 while (t < PL_bufend && isSPACE(*t))
5857 /* if comma follows first term, call it an anon hash */
5858 /* XXX it could be a comma expression with loop modifiers */
5859 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5860 || (*t == '=' && t[1] == '>')))
5861 OPERATOR(HASHBRACK);
5862 if (PL_expect == XREF)
5865 /* If there is an opening brace or 'sub:', treat it
5866 as a term to make ${{...}}{k} and &{sub:attr...}
5867 dwim. Otherwise, treat it as a statement, so
5868 map {no strict; ...} works.
5875 if (strnEQ(s, "sub", 3)) {
5886 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5892 pl_yylval.ival = CopLINE(PL_curcop);
5893 PL_copline = NOLINE; /* invalidate current command line number */
5894 TOKEN(formbrack ? '=' : '{');
5896 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5900 if (PL_lex_brackets <= 0)
5901 /* diag_listed_as: Unmatched right %s bracket */
5902 yyerror("Unmatched right curly bracket");
5904 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5905 PL_lex_allbrackets--;
5906 if (PL_lex_state == LEX_INTERPNORMAL) {
5907 if (PL_lex_brackets == 0) {
5908 if (PL_expect & XFAKEBRACK) {
5909 PL_expect &= XENUMMASK;
5910 PL_lex_state = LEX_INTERPEND;
5912 return yylex(); /* ignore fake brackets */
5914 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5915 && SvEVALED(PL_lex_repl))
5916 PL_lex_state = LEX_INTERPEND;
5917 else if (*s == '-' && s[1] == '>')
5918 PL_lex_state = LEX_INTERPENDMAYBE;
5919 else if (*s != '[' && *s != '{')
5920 PL_lex_state = LEX_INTERPEND;
5923 if (PL_expect & XFAKEBRACK) {
5924 PL_expect &= XENUMMASK;
5926 return yylex(); /* ignore fake brackets */
5928 force_next(formbrack ? '.' : '}');
5929 if (formbrack) LEAVE;
5930 if (formbrack == 2) { /* means . where arguments were expected */
5936 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5939 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5940 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5947 if (PL_expect == XOPERATOR) {
5948 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5949 && isIDFIRST_lazy_if(s,UTF))
5951 CopLINE_dec(PL_curcop);
5952 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5953 CopLINE_inc(PL_curcop);
5956 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5958 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5959 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5965 PL_parser->saw_infix_sigil = 1;
5966 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
5972 PL_tokenbuf[0] = '&';
5973 s = scan_ident(s - 1, PL_tokenbuf + 1,
5974 sizeof PL_tokenbuf - 1, TRUE);
5975 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5976 if (PL_tokenbuf[1]) {
5977 force_ident_maybe_lex('&');
5986 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5987 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5995 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
5997 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5998 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6002 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6006 const char tmp = *s++;
6008 if (!PL_lex_allbrackets
6009 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6017 if (!PL_lex_allbrackets
6018 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6027 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6028 && strchr("+-*/%.^&|<",tmp))
6029 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6030 "Reversed %c= operator",(int)tmp);
6032 if (PL_expect == XSTATE
6034 && (s == PL_linestart+1 || s[-2] == '\n') )
6036 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6037 || PL_lex_state != LEX_NORMAL) {
6042 if (strnEQ(s,"=cut",4)) {
6056 PL_parser->in_pod = 1;
6060 if (PL_expect == XBLOCK) {
6062 #ifdef PERL_STRICT_CR
6063 while (SPACE_OR_TAB(*t))
6065 while (SPACE_OR_TAB(*t) || *t == '\r')
6068 if (*t == '\n' || *t == '#') {
6071 SAVEI8(PL_parser->form_lex_state);
6072 SAVEI32(PL_lex_formbrack);
6073 PL_parser->form_lex_state = PL_lex_state;
6074 PL_lex_formbrack = PL_lex_brackets + 1;
6078 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6087 const char tmp = *s++;
6089 /* was this !=~ where !~ was meant?
6090 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6092 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6093 const char *t = s+1;
6095 while (t < PL_bufend && isSPACE(*t))
6098 if (*t == '/' || *t == '?'
6099 || ((*t == 'm' || *t == 's' || *t == 'y')
6100 && !isWORDCHAR(t[1]))
6101 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6103 "!=~ should be !~");
6105 if (!PL_lex_allbrackets
6106 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6119 if (PL_expect != XOPERATOR) {
6120 if (s[1] != '<' && !strchr(s,'>'))
6122 if (s[1] == '<' && s[2] != '>')
6123 s = scan_heredoc(s);
6125 s = scan_inputsymbol(s);
6126 PL_expect = XOPERATOR;
6127 TOKEN(sublex_start());
6133 if (*s == '=' && !PL_lex_allbrackets
6134 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6139 SHop(OP_LEFT_SHIFT);
6144 if (!PL_lex_allbrackets
6145 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6153 if (!PL_lex_allbrackets
6154 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6163 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6171 const char tmp = *s++;
6173 if (*s == '=' && !PL_lex_allbrackets
6174 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6179 SHop(OP_RIGHT_SHIFT);
6181 else if (tmp == '=') {
6182 if (!PL_lex_allbrackets
6183 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6192 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6201 if (PL_expect == XOPERATOR) {
6202 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6203 return deprecate_commaless_var_list();
6206 else if (PL_expect == XPOSTDEREF) {
6209 POSTDEREF(DOLSHARP);
6214 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6215 PL_tokenbuf[0] = '@';
6216 s = scan_ident(s + 1, PL_tokenbuf + 1,
6217 sizeof PL_tokenbuf - 1, FALSE);
6218 if (PL_expect == XOPERATOR) {
6220 if (PL_bufptr > s) {
6222 PL_bufptr = PL_oldbufptr;
6224 no_op("Array length", d);
6226 if (!PL_tokenbuf[1])
6228 PL_expect = XOPERATOR;
6229 force_ident_maybe_lex('#');
6233 PL_tokenbuf[0] = '$';
6234 s = scan_ident(s, PL_tokenbuf + 1,
6235 sizeof PL_tokenbuf - 1, FALSE);
6236 if (PL_expect == XOPERATOR) {
6238 if (PL_bufptr > s) {
6240 PL_bufptr = PL_oldbufptr;
6244 if (!PL_tokenbuf[1]) {
6246 yyerror("Final $ should be \\$ or $name");
6252 const char tmp = *s;
6253 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6256 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6257 && intuit_more(s)) {
6259 PL_tokenbuf[0] = '@';
6260 if (ckWARN(WARN_SYNTAX)) {
6263 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6264 t += UTF ? UTF8SKIP(t) : 1;
6266 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6267 while (t < PL_bufend && *t != ']')
6269 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6270 "Multidimensional syntax %"UTF8f" not supported",
6271 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6275 else if (*s == '{') {
6277 PL_tokenbuf[0] = '%';
6278 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6279 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6281 char tmpbuf[sizeof PL_tokenbuf];
6284 } while (isSPACE(*t));
6285 if (isIDFIRST_lazy_if(t,UTF)) {
6287 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6292 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6294 "You need to quote \"%"UTF8f"\"",
6295 UTF8fARG(UTF, len, tmpbuf));
6301 PL_expect = XOPERATOR;
6302 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6303 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6304 if (!islop || PL_last_lop_op == OP_GREPSTART)
6305 PL_expect = XOPERATOR;
6306 else if (strchr("$@\"'`q", *s))
6307 PL_expect = XTERM; /* e.g. print $fh "foo" */
6308 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6309 PL_expect = XTERM; /* e.g. print $fh &sub */
6310 else if (isIDFIRST_lazy_if(s,UTF)) {
6311 char tmpbuf[sizeof PL_tokenbuf];
6313 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6314 if ((t2 = keyword(tmpbuf, len, 0))) {
6315 /* binary operators exclude handle interpretations */
6327 PL_expect = XTERM; /* e.g. print $fh length() */
6332 PL_expect = XTERM; /* e.g. print $fh subr() */
6335 else if (isDIGIT(*s))
6336 PL_expect = XTERM; /* e.g. print $fh 3 */
6337 else if (*s == '.' && isDIGIT(s[1]))
6338 PL_expect = XTERM; /* e.g. print $fh .3 */
6339 else if ((*s == '?' || *s == '-' || *s == '+')
6340 && !isSPACE(s[1]) && s[1] != '=')
6341 PL_expect = XTERM; /* e.g. print $fh -1 */
6342 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6344 PL_expect = XTERM; /* e.g. print $fh /.../
6345 XXX except DORDOR operator
6347 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6349 PL_expect = XTERM; /* print $fh <<"EOF" */
6352 force_ident_maybe_lex('$');
6356 if (PL_expect == XOPERATOR)
6358 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6359 PL_tokenbuf[0] = '@';
6360 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6362 if (!PL_tokenbuf[1]) {
6365 if (PL_lex_state == LEX_NORMAL)
6367 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6369 PL_tokenbuf[0] = '%';
6371 /* Warn about @ where they meant $. */
6372 if (*s == '[' || *s == '{') {
6373 if (ckWARN(WARN_SYNTAX)) {
6374 S_check_scalar_slice(aTHX_ s);
6378 PL_expect = XOPERATOR;
6379 force_ident_maybe_lex('@');
6382 case '/': /* may be division, defined-or, or pattern */
6383 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6384 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6385 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6390 else if (PL_expect == XOPERATOR) {
6392 if (*s == '=' && !PL_lex_allbrackets
6393 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6401 /* Disable warning on "study /blah/" */
6402 if (PL_oldoldbufptr == PL_last_uni
6403 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6404 || memNE(PL_last_uni, "study", 5)
6405 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6408 s = scan_pat(s,OP_MATCH);
6409 TERM(sublex_start());
6412 case '?': /* conditional */
6414 if (!PL_lex_allbrackets
6415 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6420 PL_lex_allbrackets++;
6424 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6425 #ifdef PERL_STRICT_CR
6428 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6430 && (s == PL_linestart || s[-1] == '\n') )
6433 formbrack = 2; /* dot seen where arguments expected */
6436 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6440 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6443 if (!PL_lex_allbrackets
6444 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6452 pl_yylval.ival = OPf_SPECIAL;
6458 if (*s == '=' && !PL_lex_allbrackets
6459 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6467 case '0': case '1': case '2': case '3': case '4':
6468 case '5': case '6': case '7': case '8': case '9':
6469 s = scan_num(s, &pl_yylval);
6470 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6471 if (PL_expect == XOPERATOR)
6476 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6479 COPLINE_SET_FROM_MULTI_END;
6480 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6481 if (PL_expect == XOPERATOR) {
6482 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6483 return deprecate_commaless_var_list();
6488 pl_yylval.ival = OP_CONST;
6489 TERM(sublex_start());
6492 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6495 printbuf("### Saw string before %s\n", s);
6497 PerlIO_printf(Perl_debug_log,
6498 "### Saw unterminated string\n");
6500 if (PL_expect == XOPERATOR) {
6501 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6502 return deprecate_commaless_var_list();
6509 pl_yylval.ival = OP_CONST;
6510 /* FIXME. I think that this can be const if char *d is replaced by
6511 more localised variables. */
6512 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6513 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6514 pl_yylval.ival = OP_STRINGIFY;
6518 if (pl_yylval.ival == OP_CONST)
6519 COPLINE_SET_FROM_MULTI_END;
6520 TERM(sublex_start());
6523 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6526 printbuf("### Saw backtick string before %s\n", s);
6528 PerlIO_printf(Perl_debug_log,
6529 "### Saw unterminated backtick string\n");
6531 if (PL_expect == XOPERATOR)
6532 no_op("Backticks",s);
6535 pl_yylval.ival = OP_BACKTICK;
6536 TERM(sublex_start());
6540 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6542 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6544 if (PL_expect == XOPERATOR)
6545 no_op("Backslash",s);
6549 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6550 char *start = s + 2;
6551 while (isDIGIT(*start) || *start == '_')
6553 if (*start == '.' && isDIGIT(start[1])) {
6554 s = scan_num(s, &pl_yylval);
6557 else if ((*start == ':' && start[1] == ':')
6558 || (PL_expect == XSTATE && *start == ':'))
6560 else if (PL_expect == XSTATE) {
6562 while (d < PL_bufend && isSPACE(*d)) d++;
6563 if (*d == ':') goto keylookup;
6565 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6566 if (!isALPHA(*start) && (PL_expect == XTERM
6567 || PL_expect == XREF || PL_expect == XSTATE
6568 || PL_expect == XTERMORDORDOR)) {
6569 GV *const gv = gv_fetchpvn_flags(s, start - s,
6570 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6572 s = scan_num(s, &pl_yylval);
6579 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6632 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6634 /* Some keywords can be followed by any delimiter, including ':' */
6635 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6637 /* x::* is just a word, unless x is "CORE" */
6638 if (!anydelim && *s == ':' && s[1] == ':') {
6639 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6644 while (d < PL_bufend && isSPACE(*d))
6645 d++; /* no comments skipped here, or s### is misparsed */
6647 /* Is this a word before a => operator? */
6648 if (*d == '=' && d[1] == '>') {
6652 = (OP*)newSVOP(OP_CONST, 0,
6653 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6654 pl_yylval.opval->op_private = OPpCONST_BARE;
6658 /* Check for plugged-in keyword */
6662 char *saved_bufptr = PL_bufptr;
6664 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6666 if (result == KEYWORD_PLUGIN_DECLINE) {
6667 /* not a plugged-in keyword */
6668 PL_bufptr = saved_bufptr;
6669 } else if (result == KEYWORD_PLUGIN_STMT) {
6670 pl_yylval.opval = o;
6672 if (!PL_nexttoke) PL_expect = XSTATE;
6673 return REPORT(PLUGSTMT);
6674 } else if (result == KEYWORD_PLUGIN_EXPR) {
6675 pl_yylval.opval = o;
6677 if (!PL_nexttoke) PL_expect = XOPERATOR;
6678 return REPORT(PLUGEXPR);
6680 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6685 /* Check for built-in keyword */
6686 tmp = keyword(PL_tokenbuf, len, 0);
6688 /* Is this a label? */
6689 if (!anydelim && PL_expect == XSTATE
6690 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6692 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6693 pl_yylval.pval[len] = '\0';
6694 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6699 /* Check for lexical sub */
6700 if (PL_expect != XOPERATOR) {
6701 char tmpbuf[sizeof PL_tokenbuf + 1];
6703 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6704 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6705 if (off != NOT_IN_PAD) {
6706 assert(off); /* we assume this is boolean-true below */
6707 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6708 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6709 HEK * const stashname = HvNAME_HEK(stash);
6710 sv = newSVhek(stashname);
6711 sv_catpvs(sv, "::");
6712 sv_catpvn_flags(sv, PL_tokenbuf, len,
6713 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6714 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6724 rv2cv_op = newOP(OP_PADANY, 0);
6725 rv2cv_op->op_targ = off;
6726 cv = find_lexical_cv(off);
6734 if (tmp < 0) { /* second-class keyword? */
6735 GV *ogv = NULL; /* override (winner) */
6736 GV *hgv = NULL; /* hidden (loser) */
6737 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6739 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6740 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6742 && (cv = GvCVu(gv)))
6744 if (GvIMPORTED_CV(gv))
6746 else if (! CvMETHOD(cv))
6750 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6753 && (isGV_with_GP(gv)
6754 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6755 : SvPCS_IMPORTED(gv)
6756 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6764 tmp = 0; /* overridden by import or by GLOBAL */
6767 && -tmp==KEY_lock /* XXX generalizable kludge */
6770 tmp = 0; /* any sub overrides "weak" keyword */
6772 else { /* no override */
6774 if (tmp == KEY_dump) {
6775 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6776 "dump() better written as CORE::dump()");
6780 if (hgv && tmp != KEY_x) /* never ambiguous */
6781 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6782 "Ambiguous call resolved as CORE::%s(), "
6783 "qualify as such or use &",
6788 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6789 && (!anydelim || *s != '#')) {
6790 /* no override, and not s### either; skipspace is safe here
6791 * check for => on following line */
6793 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6794 STRLEN soff = s - SvPVX(PL_linestr);
6795 s = skipspace_flags(s, LEX_NO_INCLINE);
6796 arrow = *s == '=' && s[1] == '>';
6797 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6798 s = SvPVX(PL_linestr) + soff;
6806 default: /* not a keyword */
6807 /* Trade off - by using this evil construction we can pull the
6808 variable gv into the block labelled keylookup. If not, then
6809 we have to give it function scope so that the goto from the
6810 earlier ':' case doesn't bypass the initialisation. */
6812 just_a_word_zero_gv:
6824 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6828 /* Get the rest if it looks like a package qualifier */
6830 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6832 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6835 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6836 UTF8fARG(UTF, len, PL_tokenbuf),
6837 *s == '\'' ? "'" : "::");
6842 if (PL_expect == XOPERATOR) {
6843 if (PL_bufptr == PL_linestart) {
6844 CopLINE_dec(PL_curcop);
6845 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6846 CopLINE_inc(PL_curcop);
6849 no_op("Bareword",s);
6852 /* See if the name is "Foo::",
6853 in which case Foo is a bareword
6854 (and a package name). */
6857 && PL_tokenbuf[len - 2] == ':'
6858 && PL_tokenbuf[len - 1] == ':')
6860 if (ckWARN(WARN_BAREWORD)
6861 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6862 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6863 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6864 UTF8fARG(UTF, len, PL_tokenbuf));
6866 PL_tokenbuf[len] = '\0';
6875 /* if we saw a global override before, get the right name */
6878 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6881 SV * const tmp_sv = sv;
6882 sv = newSVpvs("CORE::GLOBAL::");
6883 sv_catsv(sv, tmp_sv);
6884 SvREFCNT_dec(tmp_sv);
6888 /* Presume this is going to be a bareword of some sort. */
6890 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6891 pl_yylval.opval->op_private = OPpCONST_BARE;
6893 /* And if "Foo::", then that's what it certainly is. */
6899 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6900 const_op->op_private = OPpCONST_BARE;
6902 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6906 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6909 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6912 /* Use this var to track whether intuit_method has been
6913 called. intuit_method returns 0 or > 255. */
6916 /* See if it's the indirect object for a list operator. */
6919 && PL_oldoldbufptr < PL_bufptr
6920 && (PL_oldoldbufptr == PL_last_lop
6921 || PL_oldoldbufptr == PL_last_uni)
6922 && /* NO SKIPSPACE BEFORE HERE! */
6924 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
6927 bool immediate_paren = *s == '(';
6929 /* (Now we can afford to cross potential line boundary.) */
6932 /* Two barewords in a row may indicate method call. */
6934 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$')
6935 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
6940 /* If not a declared subroutine, it's an indirect object. */
6941 /* (But it's an indir obj regardless for sort.) */
6942 /* Also, if "_" follows a filetest operator, it's a bareword */
6945 ( !immediate_paren && (PL_last_lop_op == OP_SORT
6947 && (PL_last_lop_op != OP_MAPSTART
6948 && PL_last_lop_op != OP_GREPSTART))))
6949 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6950 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
6954 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6959 PL_expect = XOPERATOR;
6962 /* Is this a word before a => operator? */
6963 if (*s == '=' && s[1] == '>' && !pkgname) {
6966 if (gvp || (lex && !off)) {
6967 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6968 /* This is our own scalar, created a few lines
6969 above, so this is safe. */
6971 sv_setpv(sv, PL_tokenbuf);
6972 if (UTF && !IN_BYTES
6973 && is_utf8_string((U8*)PL_tokenbuf, len))
6980 /* If followed by a paren, it's certainly a subroutine. */
6985 while (SPACE_OR_TAB(*d))
6987 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6992 NEXTVAL_NEXTTOKE.opval =
6993 off ? rv2cv_op : pl_yylval.opval;
6995 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6996 else op_free(rv2cv_op), force_next(WORD);
7001 /* If followed by var or block, call it a method (unless sub) */
7003 if ((*s == '$' || *s == '{') && !cv) {
7005 PL_last_lop = PL_oldbufptr;
7006 PL_last_lop_op = OP_METHOD;
7007 if (!PL_lex_allbrackets
7008 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7010 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7012 PL_expect = XBLOCKTERM;
7014 return REPORT(METHOD);
7017 /* If followed by a bareword, see if it looks like indir obj. */
7019 if (tmp == 1 && !orig_keyword
7020 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7021 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
7024 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7026 sv_setpvn(sv, PL_tokenbuf, len);
7027 if (UTF && !IN_BYTES
7028 && is_utf8_string((U8*)PL_tokenbuf, len))
7030 else SvUTF8_off(sv);
7033 if (tmp == METHOD && !PL_lex_allbrackets
7034 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7036 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7041 /* Not a method, so call it a subroutine (if defined) */
7044 /* Check for a constant sub */
7045 if ((sv = cv_const_sv_or_av(cv))) {
7048 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7049 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7050 if (SvTYPE(sv) == SVt_PVAV)
7051 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7054 pl_yylval.opval->op_private = 0;
7055 pl_yylval.opval->op_folded = 1;
7056 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7061 op_free(pl_yylval.opval);
7063 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7064 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7065 PL_last_lop = PL_oldbufptr;
7066 PL_last_lop_op = OP_ENTERSUB;
7067 /* Is there a prototype? */
7071 STRLEN protolen = CvPROTOLEN(cv);
7072 const char *proto = CvPROTO(cv);
7074 proto = S_strip_spaces(aTHX_ proto, &protolen);
7077 if ((optional = *proto == ';'))
7080 while (*proto == ';');
7084 *proto == '$' || *proto == '_'
7085 || *proto == '*' || *proto == '+'
7090 *proto == '\\' && proto[1] && proto[2] == '\0'
7093 UNIPROTO(UNIOPSUB,optional);
7094 if (*proto == '\\' && proto[1] == '[') {
7095 const char *p = proto + 2;
7096 while(*p && *p != ']')
7098 if(*p == ']' && !p[1])
7099 UNIPROTO(UNIOPSUB,optional);
7101 if (*proto == '&' && *s == '{') {
7103 sv_setpvs(PL_subname, "__ANON__");
7105 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7106 if (!PL_lex_allbrackets
7107 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7109 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7114 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7116 force_next(off ? PRIVATEREF : WORD);
7117 if (!PL_lex_allbrackets
7118 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7120 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7125 /* Call it a bare word */
7127 if (PL_hints & HINT_STRICT_SUBS)
7128 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7131 /* after "print" and similar functions (corresponding to
7132 * "F? L" in opcode.pl), whatever wasn't already parsed as
7133 * a filehandle should be subject to "strict subs".
7134 * Likewise for the optional indirect-object argument to system
7135 * or exec, which can't be a bareword */
7136 if ((PL_last_lop_op == OP_PRINT
7137 || PL_last_lop_op == OP_PRTF
7138 || PL_last_lop_op == OP_SAY
7139 || PL_last_lop_op == OP_SYSTEM
7140 || PL_last_lop_op == OP_EXEC)
7141 && (PL_hints & HINT_STRICT_SUBS))
7142 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7143 if (lastchar != '-') {
7144 if (ckWARN(WARN_RESERVED)) {
7148 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7150 /* PL_warn_reserved is constant */
7151 GCC_DIAG_IGNORE(-Wformat-nonliteral);
7152 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7162 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7163 && saw_infix_sigil) {
7164 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7165 "Operator or semicolon missing before %c%"UTF8f,
7167 UTF8fARG(UTF, strlen(PL_tokenbuf),
7169 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7170 "Ambiguous use of %c resolved as operator %c",
7171 lastchar, lastchar);
7178 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7183 (OP*)newSVOP(OP_CONST, 0,
7184 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7187 case KEY___PACKAGE__:
7189 (OP*)newSVOP(OP_CONST, 0,
7191 ? newSVhek(HvNAME_HEK(PL_curstash))
7198 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7199 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7202 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7204 gv_init(gv,stash,"DATA",4,0);
7207 GvIOp(gv) = newIO();
7208 IoIFP(GvIOp(gv)) = PL_rsfp;
7209 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
7211 const int fd = PerlIO_fileno(PL_rsfp);
7213 fcntl(fd,F_SETFD, FD_CLOEXEC);
7217 /* Mark this internal pseudo-handle as clean */
7218 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7219 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7220 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7222 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7223 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7224 /* if the script was opened in binmode, we need to revert
7225 * it to text mode for compatibility; but only iff it has CRs
7226 * XXX this is a questionable hack at best. */
7227 if (PL_bufend-PL_bufptr > 2
7228 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7231 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7232 loc = PerlIO_tell(PL_rsfp);
7233 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7236 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7238 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7239 #endif /* NETWARE */
7241 PerlIO_seek(PL_rsfp, loc, 0);
7245 #ifdef PERLIO_LAYERS
7248 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7249 else if (IN_ENCODING) {
7255 XPUSHs(_get_encoding());
7257 call_method("name", G_SCALAR);
7261 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7262 Perl_form(aTHX_ ":encoding(%"SVf")",
7275 FUN0OP(CvCLONE(PL_compcv)
7276 ? newOP(OP_RUNCV, 0)
7277 : newPVOP(OP_RUNCV,0,NULL));
7286 if (PL_expect == XSTATE) {
7297 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7298 if ((*s == ':' && s[1] == ':')
7299 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7303 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7307 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7308 UTF8fARG(UTF, len, PL_tokenbuf));
7311 else if (tmp == KEY_require || tmp == KEY_do
7313 /* that's a way to remember we saw "CORE::" */
7325 LOP(OP_ACCEPT,XTERM);
7328 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7333 LOP(OP_ATAN2,XTERM);
7339 LOP(OP_BINMODE,XTERM);
7342 LOP(OP_BLESS,XTERM);
7351 /* We have to disambiguate the two senses of
7352 "continue". If the next token is a '{' then
7353 treat it as the start of a continue block;
7354 otherwise treat it as a control operator.
7364 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7374 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7383 if (!PL_cryptseen) {
7384 PL_cryptseen = TRUE;
7388 LOP(OP_CRYPT,XTERM);
7391 LOP(OP_CHMOD,XTERM);
7394 LOP(OP_CHOWN,XTERM);
7397 LOP(OP_CONNECT,XTERM);
7417 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7419 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7420 && !keyword(PL_tokenbuf + 1, len, 0)) {
7423 force_ident_maybe_lex('&');
7428 if (orig_keyword == KEY_do) {
7437 PL_hints |= HINT_BLOCK_SCOPE;
7447 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7448 STR_WITH_LEN("NDBM_File::"),
7449 STR_WITH_LEN("DB_File::"),
7450 STR_WITH_LEN("GDBM_File::"),
7451 STR_WITH_LEN("SDBM_File::"),
7452 STR_WITH_LEN("ODBM_File::"),
7454 LOP(OP_DBMOPEN,XTERM);
7466 pl_yylval.ival = CopLINE(PL_curcop);
7470 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7482 if (*s == '{') { /* block eval */
7483 PL_expect = XTERMBLOCK;
7484 UNIBRACK(OP_ENTERTRY);
7486 else { /* string eval */
7488 UNIBRACK(OP_ENTEREVAL);
7493 UNIBRACK(-OP_ENTEREVAL);
7507 case KEY_endhostent:
7513 case KEY_endservent:
7516 case KEY_endprotoent:
7527 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7529 pl_yylval.ival = CopLINE(PL_curcop);
7531 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7534 if ((PL_bufend - p) >= 3
7535 && strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7539 else if ((PL_bufend - p) >= 4
7540 && strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7543 /* skip optional package name, as in "for my abc $x (..)" */
7544 if (isIDFIRST_lazy_if(p,UTF)) {
7545 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7549 Perl_croak(aTHX_ "Missing $ on loop variable");
7554 LOP(OP_FORMLINE,XTERM);
7563 LOP(OP_FCNTL,XTERM);
7569 LOP(OP_FLOCK,XTERM);
7572 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7577 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7582 LOP(OP_GREPSTART, XREF);
7599 case KEY_getpriority:
7600 LOP(OP_GETPRIORITY,XTERM);
7602 case KEY_getprotobyname:
7605 case KEY_getprotobynumber:
7606 LOP(OP_GPBYNUMBER,XTERM);
7608 case KEY_getprotoent:
7620 case KEY_getpeername:
7621 UNI(OP_GETPEERNAME);
7623 case KEY_gethostbyname:
7626 case KEY_gethostbyaddr:
7627 LOP(OP_GHBYADDR,XTERM);
7629 case KEY_gethostent:
7632 case KEY_getnetbyname:
7635 case KEY_getnetbyaddr:
7636 LOP(OP_GNBYADDR,XTERM);
7641 case KEY_getservbyname:
7642 LOP(OP_GSBYNAME,XTERM);
7644 case KEY_getservbyport:
7645 LOP(OP_GSBYPORT,XTERM);
7647 case KEY_getservent:
7650 case KEY_getsockname:
7651 UNI(OP_GETSOCKNAME);
7653 case KEY_getsockopt:
7654 LOP(OP_GSOCKOPT,XTERM);
7669 pl_yylval.ival = CopLINE(PL_curcop);
7670 Perl_ck_warner_d(aTHX_
7671 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7672 "given is experimental");
7677 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7685 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7687 pl_yylval.ival = CopLINE(PL_curcop);
7691 LOP(OP_INDEX,XTERM);
7697 LOP(OP_IOCTL,XTERM);
7725 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7730 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7744 LOP(OP_LISTEN,XTERM);
7753 s = scan_pat(s,OP_MATCH);
7754 TERM(sublex_start());
7757 LOP(OP_MAPSTART, XREF);
7760 LOP(OP_MKDIR,XTERM);
7763 LOP(OP_MSGCTL,XTERM);
7766 LOP(OP_MSGGET,XTERM);
7769 LOP(OP_MSGRCV,XTERM);
7772 LOP(OP_MSGSND,XTERM);
7778 yyerror(Perl_form(aTHX_
7779 "Can't redeclare \"%s\" in \"%s\"",
7780 tmp == KEY_my ? "my" :
7781 tmp == KEY_state ? "state" : "our",
7782 PL_in_my == KEY_my ? "my" :
7783 PL_in_my == KEY_state ? "state" : "our"));
7785 PL_in_my = (U16)tmp;
7787 if (isIDFIRST_lazy_if(s,UTF)) {
7788 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7789 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7791 if (!FEATURE_LEXSUBS_IS_ENABLED)
7793 "Experimental \"%s\" subs not enabled",
7794 tmp == KEY_my ? "my" :
7795 tmp == KEY_state ? "state" : "our");
7796 Perl_ck_warner_d(aTHX_
7797 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7798 "The lexical_subs feature is experimental");
7801 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7802 if (!PL_in_my_stash) {
7806 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7807 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7808 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7818 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7823 s = tokenize_use(0, s);
7827 if (*s == '(' || (s = skipspace(s), *s == '('))
7830 if (!PL_lex_allbrackets
7831 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7833 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7840 if (isIDFIRST_lazy_if(s,UTF)) {
7842 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7844 for (t=d; isSPACE(*t);)
7846 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7848 && !(t[0] == '=' && t[1] == '>')
7849 && !(t[0] == ':' && t[1] == ':')
7850 && !keyword(s, d-s, 0)
7852 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7853 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7854 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7860 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7862 pl_yylval.ival = OP_OR;
7872 LOP(OP_OPEN_DIR,XTERM);
7875 checkcomma(s,PL_tokenbuf,"filehandle");
7879 checkcomma(s,PL_tokenbuf,"filehandle");
7898 s = force_word(s,WORD,FALSE,TRUE);
7900 s = force_strict_version(s);
7904 LOP(OP_PIPE_OP,XTERM);
7907 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7910 COPLINE_SET_FROM_MULTI_END;
7911 pl_yylval.ival = OP_CONST;
7912 TERM(sublex_start());
7919 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7922 COPLINE_SET_FROM_MULTI_END;
7923 PL_expect = XOPERATOR;
7924 if (SvCUR(PL_lex_stuff)) {
7925 int warned_comma = !ckWARN(WARN_QW);
7926 int warned_comment = warned_comma;
7927 d = SvPV_force(PL_lex_stuff, len);
7929 for (; isSPACE(*d) && len; --len, ++d)
7934 if (!warned_comma || !warned_comment) {
7935 for (; !isSPACE(*d) && len; --len, ++d) {
7936 if (!warned_comma && *d == ',') {
7937 Perl_warner(aTHX_ packWARN(WARN_QW),
7938 "Possible attempt to separate words with commas");
7941 else if (!warned_comment && *d == '#') {
7942 Perl_warner(aTHX_ packWARN(WARN_QW),
7943 "Possible attempt to put comments in qw() list");
7949 for (; !isSPACE(*d) && len; --len, ++d)
7952 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7953 words = op_append_elem(OP_LIST, words,
7954 newSVOP(OP_CONST, 0, tokeq(sv)));
7959 words = newNULLLIST();
7960 SvREFCNT_dec_NN(PL_lex_stuff);
7961 PL_lex_stuff = NULL;
7962 PL_expect = XOPERATOR;
7963 pl_yylval.opval = sawparens(words);
7968 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7971 pl_yylval.ival = OP_STRINGIFY;
7972 if (SvIVX(PL_lex_stuff) == '\'')
7973 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7974 TERM(sublex_start());
7977 s = scan_pat(s,OP_QR);
7978 TERM(sublex_start());
7981 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7984 pl_yylval.ival = OP_BACKTICK;
7985 TERM(sublex_start());
7993 s = force_version(s, FALSE);
7995 else if (*s != 'v' || !isDIGIT(s[1])
7996 || (s = force_version(s, TRUE), *s == 'v'))
7998 *PL_tokenbuf = '\0';
7999 s = force_word(s,WORD,TRUE,TRUE);
8000 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8001 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8002 GV_ADD | (UTF ? SVf_UTF8 : 0));
8004 yyerror("<> at require-statement should be quotes");
8006 if (orig_keyword == KEY_require) {
8012 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8014 PL_last_uni = PL_oldbufptr;
8015 PL_last_lop_op = OP_REQUIRE;
8017 return REPORT( (int)REQUIRE );
8026 LOP(OP_RENAME,XTERM);
8035 LOP(OP_RINDEX,XTERM);
8044 UNIDOR(OP_READLINE);
8047 UNIDOR(OP_BACKTICK);
8056 LOP(OP_REVERSE,XTERM);
8059 UNIDOR(OP_READLINK);
8066 if (pl_yylval.opval)
8067 TERM(sublex_start());
8069 TOKEN(1); /* force error */
8072 checkcomma(s,PL_tokenbuf,"filehandle");
8082 LOP(OP_SELECT,XTERM);
8088 LOP(OP_SEMCTL,XTERM);
8091 LOP(OP_SEMGET,XTERM);
8094 LOP(OP_SEMOP,XTERM);
8100 LOP(OP_SETPGRP,XTERM);
8102 case KEY_setpriority:
8103 LOP(OP_SETPRIORITY,XTERM);
8105 case KEY_sethostent:
8111 case KEY_setservent:
8114 case KEY_setprotoent:
8124 LOP(OP_SEEKDIR,XTERM);
8126 case KEY_setsockopt:
8127 LOP(OP_SSOCKOPT,XTERM);
8133 LOP(OP_SHMCTL,XTERM);
8136 LOP(OP_SHMGET,XTERM);
8139 LOP(OP_SHMREAD,XTERM);
8142 LOP(OP_SHMWRITE,XTERM);
8145 LOP(OP_SHUTDOWN,XTERM);
8154 LOP(OP_SOCKET,XTERM);
8156 case KEY_socketpair:
8157 LOP(OP_SOCKPAIR,XTERM);
8160 checkcomma(s,PL_tokenbuf,"subroutine name");
8163 s = force_word(s,WORD,TRUE,TRUE);
8167 LOP(OP_SPLIT,XTERM);
8170 LOP(OP_SPRINTF,XTERM);
8173 LOP(OP_SPLICE,XTERM);
8188 LOP(OP_SUBSTR,XTERM);
8194 char * const tmpbuf = PL_tokenbuf + 1;
8195 expectation attrful;
8196 bool have_name, have_proto;
8197 const int key = tmp;
8198 SV *format_name = NULL;
8203 if (isIDFIRST_lazy_if(s,UTF)
8205 || (*s == ':' && s[1] == ':'))
8209 attrful = XATTRBLOCK;
8210 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8212 if (key == KEY_format)
8213 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8215 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8217 PL_tokenbuf, len + 1, 0
8219 sv_setpvn(PL_subname, tmpbuf, len);
8221 sv_setsv(PL_subname,PL_curstname);
8222 sv_catpvs(PL_subname,"::");
8223 sv_catpvn(PL_subname,tmpbuf,len);
8225 if (SvUTF8(PL_linestr))
8226 SvUTF8_on(PL_subname);
8233 if (key == KEY_my || key == KEY_our || key==KEY_state)
8236 /* diag_listed_as: Missing name in "%s sub" */
8238 "Missing name in \"%s\"", PL_bufptr);
8240 PL_expect = XTERMBLOCK;
8241 attrful = XATTRTERM;
8242 sv_setpvs(PL_subname,"?");
8246 if (key == KEY_format) {
8248 NEXTVAL_NEXTTOKE.opval
8249 = (OP*)newSVOP(OP_CONST,0, format_name);
8250 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8256 /* Look for a prototype */
8257 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8258 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8259 COPLINE_SET_FROM_MULTI_END;
8261 Perl_croak(aTHX_ "Prototype not terminated");
8262 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8270 if (*s == ':' && s[1] != ':')
8271 PL_expect = attrful;
8272 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8273 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8274 key == KEY_DESTROY || key == KEY_BEGIN ||
8275 key == KEY_UNITCHECK || key == KEY_CHECK ||
8276 key == KEY_INIT || key == KEY_END ||
8277 key == KEY_my || key == KEY_state ||
8280 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8281 else if (*s != ';' && *s != '}')
8282 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8286 NEXTVAL_NEXTTOKE.opval =
8287 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8288 PL_lex_stuff = NULL;
8293 sv_setpvs(PL_subname, "__ANON__");
8295 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8298 force_ident_maybe_lex('&');
8303 LOP(OP_SYSTEM,XREF);
8306 LOP(OP_SYMLINK,XTERM);
8309 LOP(OP_SYSCALL,XTERM);
8312 LOP(OP_SYSOPEN,XTERM);
8315 LOP(OP_SYSSEEK,XTERM);
8318 LOP(OP_SYSREAD,XTERM);
8321 LOP(OP_SYSWRITE,XTERM);
8326 TERM(sublex_start());
8347 LOP(OP_TRUNCATE,XTERM);
8359 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8361 pl_yylval.ival = CopLINE(PL_curcop);
8365 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8367 pl_yylval.ival = CopLINE(PL_curcop);
8371 LOP(OP_UNLINK,XTERM);
8377 LOP(OP_UNPACK,XTERM);
8380 LOP(OP_UTIME,XTERM);
8386 LOP(OP_UNSHIFT,XTERM);
8389 s = tokenize_use(1, s);
8399 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8401 pl_yylval.ival = CopLINE(PL_curcop);
8402 Perl_ck_warner_d(aTHX_
8403 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8404 "when is experimental");
8408 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8410 pl_yylval.ival = CopLINE(PL_curcop);
8414 PL_hints |= HINT_BLOCK_SCOPE;
8421 LOP(OP_WAITPID,XTERM);
8427 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8428 * we use the same number on EBCDIC */
8429 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8433 if (PL_expect == XOPERATOR) {
8434 if (*s == '=' && !PL_lex_allbrackets
8435 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8445 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8447 pl_yylval.ival = OP_XOR;
8456 Looks up an identifier in the pad or in a package
8459 PRIVATEREF if this is a lexical name.
8460 WORD if this belongs to a package.
8463 if we're in a my declaration
8464 croak if they tried to say my($foo::bar)
8465 build the ops for a my() declaration
8466 if it's an access to a my() variable
8467 build ops for access to a my() variable
8468 if in a dq string, and they've said @foo and we can't find @foo
8470 build ops for a bareword
8474 S_pending_ident(pTHX)
8477 const char pit = (char)pl_yylval.ival;
8478 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8479 /* All routes through this function want to know if there is a colon. */
8480 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8482 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8483 "### Pending identifier '%s'\n", PL_tokenbuf); });
8485 /* if we're in a my(), we can't allow dynamics here.
8486 $foo'bar has already been turned into $foo::bar, so
8487 just check for colons.
8489 if it's a legal name, the OP is a PADANY.
8492 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8494 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8495 "variable %s in \"our\"",
8496 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8497 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8501 /* "my" variable %s can't be in a package */
8502 /* PL_no_myglob is constant */
8503 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8504 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8505 PL_in_my == KEY_my ? "my" : "state",
8506 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8508 UTF ? SVf_UTF8 : 0);
8512 pl_yylval.opval = newOP(OP_PADANY, 0);
8513 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8514 UTF ? SVf_UTF8 : 0);
8520 build the ops for accesses to a my() variable.
8525 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8527 if (tmp != NOT_IN_PAD) {
8528 /* might be an "our" variable" */
8529 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8530 /* build ops for a bareword */
8531 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8532 HEK * const stashname = HvNAME_HEK(stash);
8533 SV * const sym = newSVhek(stashname);
8534 sv_catpvs(sym, "::");
8535 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8536 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8537 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8541 ((PL_tokenbuf[0] == '$') ? SVt_PV
8542 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8547 pl_yylval.opval = newOP(OP_PADANY, 0);
8548 pl_yylval.opval->op_targ = tmp;
8554 Whine if they've said @foo in a doublequoted string,
8555 and @foo isn't a variable we can find in the symbol
8558 if (ckWARN(WARN_AMBIGUOUS)
8560 && PL_lex_state != LEX_NORMAL
8561 && !PL_lex_brackets)
8563 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8564 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8565 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8566 /* DO NOT warn for @- and @+ */
8567 && !( PL_tokenbuf[2] == '\0'
8568 && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8571 /* Downgraded from fatal to warning 20000522 mjd */
8572 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8573 "Possible unintended interpolation of %"UTF8f
8575 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8579 /* build ops for a bareword */
8580 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8581 newSVpvn_flags(PL_tokenbuf + 1,
8583 UTF ? SVf_UTF8 : 0 ));
8584 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8586 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8587 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8588 | ( UTF ? SVf_UTF8 : 0 ),
8589 ((PL_tokenbuf[0] == '$') ? SVt_PV
8590 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8596 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8598 PERL_ARGS_ASSERT_CHECKCOMMA;
8600 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8601 if (ckWARN(WARN_SYNTAX)) {
8604 for (w = s+2; *w && level; w++) {
8612 /* the list of chars below is for end of statements or
8613 * block / parens, boolean operators (&&, ||, //) and branch
8614 * constructs (or, and, if, until, unless, while, err, for).
8615 * Not a very solid hack... */
8616 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8617 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8618 "%s (...) interpreted as function",name);
8621 while (s < PL_bufend && isSPACE(*s))
8625 while (s < PL_bufend && isSPACE(*s))
8627 if (isIDFIRST_lazy_if(s,UTF)) {
8628 const char * const w = s;
8629 s += UTF ? UTF8SKIP(s) : 1;
8630 while (isWORDCHAR_lazy_if(s,UTF))
8631 s += UTF ? UTF8SKIP(s) : 1;
8632 while (s < PL_bufend && isSPACE(*s))
8637 if (keyword(w, s - w, 0))
8640 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8641 if (gv && GvCVu(gv))
8645 Copy(w, tmpbuf+1, s - w, char);
8647 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8648 if (off != NOT_IN_PAD) return;
8650 Perl_croak(aTHX_ "No comma allowed after %s", what);
8655 /* S_new_constant(): do any overload::constant lookup.
8657 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8658 Best used as sv=new_constant(..., sv, ...).
8659 If s, pv are NULL, calls subroutine with one argument,
8660 and <type> is used with error messages only.
8661 <type> is assumed to be well formed UTF-8 */
8664 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8665 SV *sv, SV *pv, const char *type, STRLEN typelen)
8668 HV * table = GvHV(PL_hintgv); /* ^H */
8673 const char *why1 = "", *why2 = "", *why3 = "";
8675 PERL_ARGS_ASSERT_NEW_CONSTANT;
8676 /* We assume that this is true: */
8677 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8680 /* charnames doesn't work well if there have been errors found */
8681 if (PL_error_count > 0 && *key == 'c')
8683 SvREFCNT_dec_NN(sv);
8684 return &PL_sv_undef;
8687 sv_2mortal(sv); /* Parent created it permanently */
8689 || ! (PL_hints & HINT_LOCALIZE_HH)
8690 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8695 /* Here haven't found what we're looking for. If it is charnames,
8696 * perhaps it needs to be loaded. Try doing that before giving up */
8698 Perl_load_module(aTHX_
8700 newSVpvs("_charnames"),
8701 /* version parameter; no need to specify it, as if
8702 * we get too early a version, will fail anyway,
8703 * not being able to find '_charnames' */
8708 assert(sp == PL_stack_sp);
8709 table = GvHV(PL_hintgv);
8711 && (PL_hints & HINT_LOCALIZE_HH)
8712 && (cvp = hv_fetch(table, key, keylen, FALSE))
8718 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8719 msg = Perl_form(aTHX_
8720 "Constant(%.*s) unknown",
8721 (int)(type ? typelen : len),
8727 why3 = "} is not defined";
8730 msg = Perl_form(aTHX_
8731 /* The +3 is for '\N{'; -4 for that, plus '}' */
8732 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8736 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8737 (int)(type ? typelen : len),
8738 (type ? type: s), why1, why2, why3);
8741 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8742 return SvREFCNT_inc_simple_NN(sv);
8747 pv = newSVpvn_flags(s, len, SVs_TEMP);
8749 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8751 typesv = &PL_sv_undef;
8753 PUSHSTACKi(PERLSI_OVERLOAD);
8765 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8769 /* Check the eval first */
8770 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8772 const char * errstr;
8773 sv_catpvs(errsv, "Propagated");
8774 errstr = SvPV_const(errsv, errlen);
8775 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8777 res = SvREFCNT_inc_simple_NN(sv);
8781 SvREFCNT_inc_simple_void_NN(res);
8790 why1 = "Call to &{$^H{";
8792 why3 = "}} did not return a defined value";
8794 (void)sv_2mortal(sv);
8801 PERL_STATIC_INLINE void
8802 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8803 PERL_ARGS_ASSERT_PARSE_IDENT;
8807 Perl_croak(aTHX_ "%s", ident_too_long);
8808 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8809 /* The UTF-8 case must come first, otherwise things
8810 * like c\N{COMBINING TILDE} would start failing, as the
8811 * isWORDCHAR_A case below would gobble the 'c' up.
8814 char *t = *s + UTF8SKIP(*s);
8815 while (isIDCONT_utf8((U8*)t))
8817 if (*d + (t - *s) > e)
8818 Perl_croak(aTHX_ "%s", ident_too_long);
8819 Copy(*s, *d, t - *s, char);
8823 else if ( isWORDCHAR_A(**s) ) {
8826 } while (isWORDCHAR_A(**s) && *d < e);
8828 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8833 else if (allow_package && **s == ':' && (*s)[1] == ':'
8834 /* Disallow things like Foo::$bar. For the curious, this is
8835 * the code path that triggers the "Bad name after" warning
8836 * when looking for barewords.
8838 && (*s)[2] != '$') {
8848 /* Returns a NUL terminated string, with the length of the string written to
8852 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8855 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8856 bool is_utf8 = cBOOL(UTF);
8858 PERL_ARGS_ASSERT_SCAN_WORD;
8860 parse_ident(&s, &d, e, allow_package, is_utf8);
8866 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8867 * iff Unicode semantics are to be used. The legal ones are any of:
8868 * a) all ASCII characters except:
8869 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
8871 * The final case currently doesn't get this far in the program, so we
8872 * don't test for it. If that were to change, it would be ok to allow it.
8873 * c) When not under Unicode rules, any upper Latin1 character
8874 * d) Otherwise, when unicode rules are used, all XIDS characters.
8876 * Because all ASCII characters have the same representation whether
8877 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8878 * '{' without knowing if is UTF-8 or not.
8879 * EBCDIC already uses the rules that ASCII platforms will use after the
8880 * deprecation cycle; see comment below about the deprecation. */
8882 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8883 (isGRAPH_A(*(s)) || ((is_utf8) \
8884 ? isIDFIRST_utf8((U8*) (s)) \
8886 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8888 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8889 (isGRAPH_A(*(s)) || ((is_utf8) \
8890 ? isIDFIRST_utf8((U8*) (s)) \
8891 : ! isASCII_utf8((U8*) (s))))
8895 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8897 I32 herelines = PL_parser->herelines;
8898 SSize_t bracket = -1;
8901 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8902 bool is_utf8 = cBOOL(UTF);
8903 I32 orig_copline = 0, tmp_copline = 0;
8905 PERL_ARGS_ASSERT_SCAN_IDENT;
8907 if (isSPACE(*s) || !*s)
8910 while (isDIGIT(*s)) {
8912 Perl_croak(aTHX_ "%s", ident_too_long);
8916 else { /* See if it is a "normal" identifier */
8917 parse_ident(&s, &d, e, 1, is_utf8);
8922 /* Either a digit variable, or parse_ident() found an identifier
8923 (anything valid as a bareword), so job done and return. */
8924 if (PL_lex_state != LEX_NORMAL)
8925 PL_lex_state = LEX_INTERPENDMAYBE;
8929 /* Here, it is not a run-of-the-mill identifier name */
8931 if (*s == '$' && s[1]
8932 && (isIDFIRST_lazy_if(s+1,is_utf8)
8933 || isDIGIT_A((U8)s[1])
8936 || strnEQ(s+1,"::",2)) )
8938 /* Dereferencing a value in a scalar variable.
8939 The alternatives are different syntaxes for a scalar variable.
8940 Using ' as a leading package separator isn't allowed. :: is. */
8943 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8945 bracket = s - SvPVX(PL_linestr);
8947 orig_copline = CopLINE(PL_curcop);
8948 if (s < PL_bufend && isSPACE(*s)) {
8952 if ((s <= PL_bufend - (is_utf8)
8955 && VALID_LEN_ONE_IDENT(s, is_utf8))
8957 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8958 * because often it has no graphic representation. (We can't get to
8959 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8962 ? ! isGRAPH_utf8( (U8*) s)
8963 : (! isGRAPH_L1( (U8) *s)
8964 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8966 deprecate("literal non-graphic characters in variable names");
8970 const STRLEN skip = UTF8SKIP(s);
8973 for ( i = 0; i < skip; i++ )
8981 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8982 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8986 /* Warn about ambiguous code after unary operators if {...} notation isn't
8987 used. There's no difference in ambiguity; it's merely a heuristic
8988 about when not to warn. */
8989 else if (ck_uni && bracket == -1)
8991 if (bracket != -1) {
8992 /* If we were processing {...} notation then... */
8993 if (isIDFIRST_lazy_if(d,is_utf8)) {
8994 /* if it starts as a valid identifier, assume that it is one.
8995 (the later check for } being at the expected point will trap
8996 cases where this doesn't pan out.) */
8997 d += is_utf8 ? UTF8SKIP(d) : 1;
8998 parse_ident(&s, &d, e, 1, is_utf8);
9000 tmp_copline = CopLINE(PL_curcop);
9001 if (s < PL_bufend && isSPACE(*s)) {
9004 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9005 /* ${foo[0]} and ${foo{bar}} notation. */
9006 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9007 const char * const brack =
9009 ((*s == '[') ? "[...]" : "{...}");
9010 orig_copline = CopLINE(PL_curcop);
9011 CopLINE_set(PL_curcop, tmp_copline);
9012 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9013 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9014 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9015 funny, dest, brack, funny, dest, brack);
9016 CopLINE_set(PL_curcop, orig_copline);
9019 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9020 PL_lex_allbrackets++;
9024 /* Handle extended ${^Foo} variables
9025 * 1999-02-27 mjd-perl-patch@plover.com */
9026 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9030 while (isWORDCHAR(*s) && d < e) {
9034 Perl_croak(aTHX_ "%s", ident_too_long);
9039 tmp_copline = CopLINE(PL_curcop);
9040 if (s < PL_bufend && isSPACE(*s)) {
9044 /* Expect to find a closing } after consuming any trailing whitespace.
9048 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9049 PL_lex_state = LEX_INTERPEND;
9052 if (PL_lex_state == LEX_NORMAL) {
9053 if (ckWARN(WARN_AMBIGUOUS)
9054 && (keyword(dest, d - dest, 0)
9055 || get_cvn_flags(dest, d - dest, is_utf8
9059 SV *tmp = newSVpvn_flags( dest, d - dest,
9060 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9063 orig_copline = CopLINE(PL_curcop);
9064 CopLINE_set(PL_curcop, tmp_copline);
9065 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9066 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9067 funny, SVfARG(tmp), funny, SVfARG(tmp));
9068 CopLINE_set(PL_curcop, orig_copline);
9073 /* Didn't find the closing } at the point we expected, so restore
9074 state such that the next thing to process is the opening { and */
9075 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9076 CopLINE_set(PL_curcop, orig_copline);
9077 PL_parser->herelines = herelines;
9081 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9082 PL_lex_state = LEX_INTERPEND;
9087 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9089 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9090 * found in the parse starting at 's', based on the subset that are valid
9091 * in this context input to this routine in 'valid_flags'. Advances s.
9092 * Returns TRUE if the input should be treated as a valid flag, so the next
9093 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9094 * upon first call on the current regex. This routine will set it to any
9095 * charset modifier found. The caller shouldn't change it. This way,
9096 * another charset modifier encountered in the parse can be detected as an
9097 * error, as we have decided to allow only one */
9100 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9102 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9103 if (isWORDCHAR_lazy_if(*s, UTF)) {
9104 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9105 UTF ? SVf_UTF8 : 0);
9107 /* Pretend that it worked, so will continue processing before
9116 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9117 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9118 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9119 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9120 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9121 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9122 case LOCALE_PAT_MOD:
9124 goto multiple_charsets;
9126 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9129 case UNICODE_PAT_MOD:
9131 goto multiple_charsets;
9133 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9136 case ASCII_RESTRICT_PAT_MOD:
9138 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9142 /* Error if previous modifier wasn't an 'a', but if it was, see
9143 * if, and accept, a second occurrence (only) */
9145 || get_regex_charset(*pmfl)
9146 != REGEX_ASCII_RESTRICTED_CHARSET)
9148 goto multiple_charsets;
9150 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9154 case DEPENDS_PAT_MOD:
9156 goto multiple_charsets;
9158 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9167 if (*charset != c) {
9168 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9170 else if (c == 'a') {
9171 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9172 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9175 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9178 /* Pretend that it worked, so will continue processing before dieing */
9184 S_scan_pat(pTHX_ char *start, I32 type)
9188 const char * const valid_flags =
9189 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9190 char charset = '\0'; /* character set modifier */
9191 unsigned int x_mod_count = 0;
9193 PERL_ARGS_ASSERT_SCAN_PAT;
9195 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9197 Perl_croak(aTHX_ "Search pattern not terminated");
9199 pm = (PMOP*)newPMOP(type, 0);
9200 if (PL_multi_open == '?') {
9201 /* This is the only point in the code that sets PMf_ONCE: */
9202 pm->op_pmflags |= PMf_ONCE;
9204 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9205 allows us to restrict the list needed by reset to just the ??
9207 assert(type != OP_TRANS);
9209 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9212 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9215 elements = mg->mg_len / sizeof(PMOP**);
9216 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9217 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9218 mg->mg_len = elements * sizeof(PMOP**);
9219 PmopSTASH_set(pm,PL_curstash);
9223 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9224 * anon CV. False positives like qr/[(?{]/ are harmless */
9226 if (type == OP_QR) {
9228 char *e, *p = SvPV(PL_lex_stuff, len);
9230 for (; p < e; p++) {
9231 if (p[0] == '(' && p[1] == '?'
9232 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9234 pm->op_pmflags |= PMf_HAS_CV;
9238 pm->op_pmflags |= PMf_IS_QR;
9241 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9242 &s, &charset, &x_mod_count))
9244 /* issue a warning if /c is specified,but /g is not */
9245 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9247 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9248 "Use of /c modifier is meaningless without /g" );
9251 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9253 PL_lex_op = (OP*)pm;
9254 pl_yylval.ival = OP_MATCH;
9259 S_scan_subst(pTHX_ char *start)
9266 char charset = '\0'; /* character set modifier */
9267 unsigned int x_mod_count = 0;
9270 PERL_ARGS_ASSERT_SCAN_SUBST;
9272 pl_yylval.ival = OP_NULL;
9274 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9277 Perl_croak(aTHX_ "Substitution pattern not terminated");
9281 first_start = PL_multi_start;
9282 first_line = CopLINE(PL_curcop);
9283 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9285 SvREFCNT_dec_NN(PL_lex_stuff);
9286 PL_lex_stuff = NULL;
9287 Perl_croak(aTHX_ "Substitution replacement not terminated");
9289 PL_multi_start = first_start; /* so whole substitution is taken together */
9291 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9295 if (*s == EXEC_PAT_MOD) {
9299 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9300 &s, &charset, &x_mod_count))
9306 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
9308 if ((pm->op_pmflags & PMf_CONTINUE)) {
9309 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9313 SV * const repl = newSVpvs("");
9316 pm->op_pmflags |= PMf_EVAL;
9319 sv_catpvs(repl, "eval ");
9321 sv_catpvs(repl, "do ");
9323 sv_catpvs(repl, "{");
9324 sv_catsv(repl, PL_sublex_info.repl);
9325 sv_catpvs(repl, "}");
9327 SvREFCNT_dec(PL_sublex_info.repl);
9328 PL_sublex_info.repl = repl;
9330 if (CopLINE(PL_curcop) != first_line) {
9331 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9332 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9333 CopLINE(PL_curcop) - first_line;
9334 CopLINE_set(PL_curcop, first_line);
9337 PL_lex_op = (OP*)pm;
9338 pl_yylval.ival = OP_SUBST;
9343 S_scan_trans(pTHX_ char *start)
9350 bool nondestruct = 0;
9353 PERL_ARGS_ASSERT_SCAN_TRANS;
9355 pl_yylval.ival = OP_NULL;
9357 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9359 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9363 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9365 SvREFCNT_dec_NN(PL_lex_stuff);
9366 PL_lex_stuff = NULL;
9367 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9370 complement = del = squash = 0;
9374 complement = OPpTRANS_COMPLEMENT;
9377 del = OPpTRANS_DELETE;
9380 squash = OPpTRANS_SQUASH;
9392 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9393 o->op_private &= ~OPpTRANS_ALL;
9394 o->op_private |= del|squash|complement|
9395 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9396 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9399 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9406 Takes a pointer to the first < in <<FOO.
9407 Returns a pointer to the byte following <<FOO.
9409 This function scans a heredoc, which involves different methods
9410 depending on whether we are in a string eval, quoted construct, etc.
9411 This is because PL_linestr could containing a single line of input, or
9412 a whole string being evalled, or the contents of the current quote-
9415 The two basic methods are:
9416 - Steal lines from the input stream
9417 - Scan the heredoc in PL_linestr and remove it therefrom
9419 In a file scope or filtered eval, the first method is used; in a
9420 string eval, the second.
9422 In a quote-like operator, we have to choose between the two,
9423 depending on where we can find a newline. We peek into outer lex-
9424 ing scopes until we find one with a newline in it. If we reach the
9425 outermost lexing scope and it is a file, we use the stream method.
9426 Otherwise it is treated as an eval.
9430 S_scan_heredoc(pTHX_ char *s)
9432 I32 op_type = OP_SCALAR;
9439 const bool infile = PL_rsfp || PL_parser->filtered;
9440 const line_t origline = CopLINE(PL_curcop);
9441 LEXSHARED *shared = PL_parser->lex_shared;
9443 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9446 d = PL_tokenbuf + 1;
9447 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9448 *PL_tokenbuf = '\n';
9450 while (SPACE_OR_TAB(*peek))
9452 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9455 s = delimcpy(d, e, s, PL_bufend, term, &len);
9457 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9463 /* <<\FOO is equivalent to <<'FOO' */
9467 if (!isWORDCHAR_lazy_if(s,UTF))
9468 deprecate("bare << to mean <<\"\"");
9470 while (isWORDCHAR_lazy_if(peek,UTF)) {
9471 peek += UTF ? UTF8SKIP(peek) : 1;
9473 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9474 Copy(s, d, len, char);
9478 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9479 Perl_croak(aTHX_ "Delimiter for here document is too long");
9482 len = d - PL_tokenbuf;
9484 #ifndef PERL_STRICT_CR
9485 d = strchr(s, '\r');
9487 char * const olds = s;
9489 while (s < PL_bufend) {
9495 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9504 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9509 tmpstr = newSV_type(SVt_PVIV);
9513 SvIV_set(tmpstr, -1);
9515 else if (term == '`') {
9516 op_type = OP_BACKTICK;
9517 SvIV_set(tmpstr, '\\');
9520 PL_multi_start = origline + 1 + PL_parser->herelines;
9521 PL_multi_open = PL_multi_close = '<';
9522 /* inside a string eval or quote-like operator */
9523 if (!infile || PL_lex_inwhat) {
9526 char * const olds = s;
9527 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9528 /* These two fields are not set until an inner lexing scope is
9529 entered. But we need them set here. */
9530 shared->ls_bufptr = s;
9531 shared->ls_linestr = PL_linestr;
9533 /* Look for a newline. If the current buffer does not have one,
9534 peek into the line buffer of the parent lexing scope, going
9535 up as many levels as necessary to find one with a newline
9538 while (!(s = (char *)memchr(
9539 (void *)shared->ls_bufptr, '\n',
9540 SvEND(shared->ls_linestr)-shared->ls_bufptr
9542 shared = shared->ls_prev;
9543 /* shared is only null if we have gone beyond the outermost
9544 lexing scope. In a file, we will have broken out of the
9545 loop in the previous iteration. In an eval, the string buf-
9546 fer ends with "\n;", so the while condition above will have
9547 evaluated to false. So shared can never be null. Or so you
9548 might think. Odd syntax errors like s;@{<<; can gobble up
9549 the implicit semicolon at the end of a flie, causing the
9550 file handle to be closed even when we are not in a string
9551 eval. So shared may be null in that case. */
9552 if (UNLIKELY(!shared))
9554 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9555 most lexing scope. In a file, shared->ls_linestr at that
9556 level is just one line, so there is no body to steal. */
9557 if (infile && !shared->ls_prev) {
9563 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9566 linestr = shared->ls_linestr;
9567 bufend = SvEND(linestr);
9569 while (s < bufend - len + 1
9570 && memNE(s,PL_tokenbuf,len) )
9573 ++PL_parser->herelines;
9575 if (s >= bufend - len + 1) {
9578 sv_setpvn(tmpstr,d+1,s-d);
9580 /* the preceding stmt passes a newline */
9581 PL_parser->herelines++;
9583 /* s now points to the newline after the heredoc terminator.
9584 d points to the newline before the body of the heredoc.
9587 /* We are going to modify linestr in place here, so set
9588 aside copies of the string if necessary for re-evals or
9590 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9591 check shared->re_eval_str. */
9592 if (shared->re_eval_start || shared->re_eval_str) {
9593 /* Set aside the rest of the regexp */
9594 if (!shared->re_eval_str)
9595 shared->re_eval_str =
9596 newSVpvn(shared->re_eval_start,
9597 bufend - shared->re_eval_start);
9598 shared->re_eval_start -= s-d;
9601 && CxTYPE(cx) == CXt_EVAL
9602 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
9603 && cx->blk_eval.cur_text == linestr)
9605 cx->blk_eval.cur_text = newSVsv(linestr);
9606 SvSCREAM_on(cx->blk_eval.cur_text);
9608 /* Copy everything from s onwards back to d. */
9609 Move(s,d,bufend-s + 1,char);
9610 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9611 /* Setting PL_bufend only applies when we have not dug deeper
9612 into other scopes, because sublex_done sets PL_bufend to
9613 SvEND(PL_linestr). */
9614 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9621 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9622 term = PL_tokenbuf[1];
9624 linestr_save = PL_linestr; /* must restore this afterwards */
9625 d = s; /* and this */
9626 PL_linestr = newSVpvs("");
9627 PL_bufend = SvPVX(PL_linestr);
9629 PL_bufptr = PL_bufend;
9630 CopLINE_set(PL_curcop,
9631 origline + 1 + PL_parser->herelines);
9632 if (!lex_next_chunk(LEX_NO_TERM)
9633 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9634 /* Simply freeing linestr_save might seem simpler here, as it
9635 does not matter what PL_linestr points to, since we are
9636 about to croak; but in a quote-like op, linestr_save
9637 will have been prospectively freed already, via
9638 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9639 restore PL_linestr. */
9640 SvREFCNT_dec_NN(PL_linestr);
9641 PL_linestr = linestr_save;
9644 CopLINE_set(PL_curcop, origline);
9645 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9646 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9647 /* ^That should be enough to avoid this needing to grow: */
9648 sv_catpvs(PL_linestr, "\n\0");
9649 assert(s == SvPVX(PL_linestr));
9650 PL_bufend = SvEND(PL_linestr);
9653 PL_parser->herelines++;
9654 PL_last_lop = PL_last_uni = NULL;
9655 #ifndef PERL_STRICT_CR
9656 if (PL_bufend - PL_linestart >= 2) {
9657 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
9658 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9660 PL_bufend[-2] = '\n';
9662 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9664 else if (PL_bufend[-1] == '\r')
9665 PL_bufend[-1] = '\n';
9667 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9668 PL_bufend[-1] = '\n';
9670 if (*s == term && PL_bufend-s >= len
9671 && memEQ(s,PL_tokenbuf + 1,len)) {
9672 SvREFCNT_dec(PL_linestr);
9673 PL_linestr = linestr_save;
9674 PL_linestart = SvPVX(linestr_save);
9675 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9680 sv_catsv(tmpstr,PL_linestr);
9684 PL_multi_end = origline + PL_parser->herelines;
9685 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9686 SvPV_shrink_to_cur(tmpstr);
9689 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9691 else if (IN_ENCODING)
9692 sv_recode_to_utf8(tmpstr, _get_encoding());
9694 PL_lex_stuff = tmpstr;
9695 pl_yylval.ival = op_type;
9699 SvREFCNT_dec(tmpstr);
9700 CopLINE_set(PL_curcop, origline);
9701 missingterm(PL_tokenbuf + 1);
9705 takes: current position in input buffer
9706 returns: new position in input buffer
9707 side-effects: pl_yylval and lex_op are set.
9712 <<>> read from ARGV without magic open
9713 <FH> read from filehandle
9714 <pkg::FH> read from package qualified filehandle
9715 <pkg'FH> read from package qualified filehandle
9716 <$fh> read from filehandle in $fh
9722 S_scan_inputsymbol(pTHX_ char *start)
9724 char *s = start; /* current position in buffer */
9727 bool nomagicopen = FALSE;
9728 char *d = PL_tokenbuf; /* start of temp holding space */
9729 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9731 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9733 end = strchr(s, '\n');
9736 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9743 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9745 /* die if we didn't have space for the contents of the <>,
9746 or if it didn't end, or if we see a newline
9749 if (len >= (I32)sizeof PL_tokenbuf)
9750 Perl_croak(aTHX_ "Excessively long <> operator");
9752 Perl_croak(aTHX_ "Unterminated <> operator");
9757 Remember, only scalar variables are interpreted as filehandles by
9758 this code. Anything more complex (e.g., <$fh{$num}>) will be
9759 treated as a glob() call.
9760 This code makes use of the fact that except for the $ at the front,
9761 a scalar variable and a filehandle look the same.
9763 if (*d == '$' && d[1]) d++;
9765 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9766 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9767 d += UTF ? UTF8SKIP(d) : 1;
9769 /* If we've tried to read what we allow filehandles to look like, and
9770 there's still text left, then it must be a glob() and not a getline.
9771 Use scan_str to pull out the stuff between the <> and treat it
9772 as nothing more than a string.
9775 if (d - PL_tokenbuf != len) {
9776 pl_yylval.ival = OP_GLOB;
9777 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9779 Perl_croak(aTHX_ "Glob not terminated");
9783 bool readline_overriden = FALSE;
9785 /* we're in a filehandle read situation */
9788 /* turn <> into <ARGV> */
9790 Copy("ARGV",d,5,char);
9792 /* Check whether readline() is overriden */
9793 if ((gv_readline = gv_override("readline",8)))
9794 readline_overriden = TRUE;
9796 /* if <$fh>, create the ops to turn the variable into a
9800 /* try to find it in the pad for this block, otherwise find
9801 add symbol table ops
9803 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9804 if (tmp != NOT_IN_PAD) {
9805 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9806 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9807 HEK * const stashname = HvNAME_HEK(stash);
9808 SV * const sym = sv_2mortal(newSVhek(stashname));
9809 sv_catpvs(sym, "::");
9815 OP * const o = newOP(OP_PADSV, 0);
9817 PL_lex_op = readline_overriden
9818 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9819 op_append_elem(OP_LIST, o,
9820 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9821 : (OP*)newUNOP(OP_READLINE, 0, o);
9829 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9831 PL_lex_op = readline_overriden
9832 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9833 op_append_elem(OP_LIST,
9834 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9835 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9836 : (OP*)newUNOP(OP_READLINE, 0,
9837 newUNOP(OP_RV2SV, 0,
9838 newGVOP(OP_GV, 0, gv)));
9840 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9841 pl_yylval.ival = OP_NULL;
9844 /* If it's none of the above, it must be a literal filehandle
9845 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9847 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9848 PL_lex_op = readline_overriden
9849 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9850 op_append_elem(OP_LIST,
9851 newGVOP(OP_GV, 0, gv),
9852 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9853 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9854 pl_yylval.ival = OP_NULL;
9864 start position in buffer
9865 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9866 only if they are of the open/close form
9867 keep_delims preserve the delimiters around the string
9868 re_reparse compiling a run-time /(?{})/:
9869 collapse // to /, and skip encoding src
9870 delimp if non-null, this is set to the position of
9871 the closing delimiter, or just after it if
9872 the closing and opening delimiters differ
9873 (i.e., the opening delimiter of a substitu-
9875 returns: position to continue reading from buffer
9876 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9877 updates the read buffer.
9879 This subroutine pulls a string out of the input. It is called for:
9880 q single quotes q(literal text)
9881 ' single quotes 'literal text'
9882 qq double quotes qq(interpolate $here please)
9883 " double quotes "interpolate $here please"
9884 qx backticks qx(/bin/ls -l)
9885 ` backticks `/bin/ls -l`
9886 qw quote words @EXPORT_OK = qw( func() $spam )
9887 m// regexp match m/this/
9888 s/// regexp substitute s/this/that/
9889 tr/// string transliterate tr/this/that/
9890 y/// string transliterate y/this/that/
9891 ($*@) sub prototypes sub foo ($)
9892 (stuff) sub attr parameters sub foo : attr(stuff)
9893 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9895 In most of these cases (all but <>, patterns and transliterate)
9896 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9897 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9898 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9901 It skips whitespace before the string starts, and treats the first
9902 character as the delimiter. If the delimiter is one of ([{< then
9903 the corresponding "close" character )]}> is used as the closing
9904 delimiter. It allows quoting of delimiters, and if the string has
9905 balanced delimiters ([{<>}]) it allows nesting.
9907 On success, the SV with the resulting string is put into lex_stuff or,
9908 if that is already non-NULL, into lex_repl. The second case occurs only
9909 when parsing the RHS of the special constructs s/// and tr/// (y///).
9910 For convenience, the terminating delimiter character is stuffed into
9915 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9919 SV *sv; /* scalar value: string */
9920 const char *tmps; /* temp string, used for delimiter matching */
9921 char *s = start; /* current position in the buffer */
9922 char term; /* terminating character */
9923 char *to; /* current position in the sv's data */
9924 I32 brackets = 1; /* bracket nesting level */
9925 bool has_utf8 = FALSE; /* is there any utf8 content? */
9926 I32 termcode; /* terminating char. code */
9927 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9928 STRLEN termlen; /* length of terminating string */
9929 int last_off = 0; /* last position for nesting bracket */
9932 PERL_ARGS_ASSERT_SCAN_STR;
9934 /* skip space before the delimiter */
9939 /* mark where we are, in case we need to report errors */
9942 /* after skipping whitespace, the next character is the terminator */
9945 termcode = termstr[0] = term;
9949 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9950 Copy(s, termstr, termlen, U8);
9951 if (!UTF8_IS_INVARIANT(term))
9955 /* mark where we are */
9956 PL_multi_start = CopLINE(PL_curcop);
9957 PL_multi_open = term;
9958 herelines = PL_parser->herelines;
9960 /* find corresponding closing delimiter */
9961 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9962 termcode = termstr[0] = term = tmps[5];
9964 PL_multi_close = term;
9966 if (PL_multi_open == PL_multi_close) {
9967 keep_bracketed_quoted = FALSE;
9970 /* create a new SV to hold the contents. 79 is the SV's initial length.
9971 What a random number. */
9972 sv = newSV_type(SVt_PVIV);
9974 SvIV_set(sv, termcode);
9975 (void)SvPOK_only(sv); /* validate pointer */
9977 /* move past delimiter and try to read a complete string */
9979 sv_catpvn(sv, s, termlen);
9982 if (IN_ENCODING && !UTF && !re_reparse) {
9986 int offset = s - SvPVX_const(PL_linestr);
9987 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9988 &offset, (char*)termstr, termlen);
9992 if (SvIsCOW(PL_linestr)) {
9993 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9994 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9995 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9996 char *buf = SvPVX(PL_linestr);
9997 bufend_pos = PL_parser->bufend - buf;
9998 bufptr_pos = PL_parser->bufptr - buf;
9999 oldbufptr_pos = PL_parser->oldbufptr - buf;
10000 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
10001 linestart_pos = PL_parser->linestart - buf;
10002 last_uni_pos = PL_parser->last_uni
10003 ? PL_parser->last_uni - buf
10005 last_lop_pos = PL_parser->last_lop
10006 ? PL_parser->last_lop - buf
10008 re_eval_start_pos =
10009 PL_parser->lex_shared->re_eval_start ?
10010 PL_parser->lex_shared->re_eval_start - buf : 0;
10013 sv_force_normal(PL_linestr);
10015 buf = SvPVX(PL_linestr);
10016 PL_parser->bufend = buf + bufend_pos;
10017 PL_parser->bufptr = buf + bufptr_pos;
10018 PL_parser->oldbufptr = buf + oldbufptr_pos;
10019 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
10020 PL_parser->linestart = buf + linestart_pos;
10021 if (PL_parser->last_uni)
10022 PL_parser->last_uni = buf + last_uni_pos;
10023 if (PL_parser->last_lop)
10024 PL_parser->last_lop = buf + last_lop_pos;
10025 if (PL_parser->lex_shared->re_eval_start)
10026 PL_parser->lex_shared->re_eval_start =
10027 buf + re_eval_start_pos;
10030 ns = SvPVX_const(PL_linestr) + offset;
10031 svlast = SvEND(sv) - 1;
10033 for (; s < ns; s++) {
10034 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10035 COPLINE_INC_WITH_HERELINES;
10038 goto read_more_line;
10040 /* handle quoted delimiters */
10041 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10043 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10045 if ((svlast-1 - t) % 2) {
10046 if (!keep_bracketed_quoted) {
10047 *(svlast-1) = term;
10049 SvCUR_set(sv, SvCUR(sv) - 1);
10054 if (PL_multi_open == PL_multi_close) {
10060 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10061 /* At here, all closes are "was quoted" one,
10062 so we don't check PL_multi_close. */
10064 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
10069 else if (*t == PL_multi_open)
10077 SvCUR_set(sv, w - SvPVX_const(sv));
10079 last_off = w - SvPVX(sv);
10080 if (--brackets <= 0)
10085 if (!keep_delims) {
10086 SvCUR_set(sv, SvCUR(sv) - 1);
10092 /* extend sv if need be */
10093 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10094 /* set 'to' to the next character in the sv's string */
10095 to = SvPVX(sv)+SvCUR(sv);
10097 /* if open delimiter is the close delimiter read unbridle */
10098 if (PL_multi_open == PL_multi_close) {
10099 for (; s < PL_bufend; s++,to++) {
10100 /* embedded newlines increment the current line number */
10101 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10102 COPLINE_INC_WITH_HERELINES;
10103 /* handle quoted delimiters */
10104 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10105 if (!keep_bracketed_quoted
10107 || (re_reparse && s[1] == '\\'))
10110 else /* any other quotes are simply copied straight through */
10113 /* terminate when run out of buffer (the for() condition), or
10114 have found the terminator */
10115 else if (*s == term) {
10118 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10121 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10127 /* if the terminator isn't the same as the start character (e.g.,
10128 matched brackets), we have to allow more in the quoting, and
10129 be prepared for nested brackets.
10132 /* read until we run out of string, or we find the terminator */
10133 for (; s < PL_bufend; s++,to++) {
10134 /* embedded newlines increment the line count */
10135 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10136 COPLINE_INC_WITH_HERELINES;
10137 /* backslashes can escape the open or closing characters */
10138 if (*s == '\\' && s+1 < PL_bufend) {
10139 if (!keep_bracketed_quoted
10140 && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10147 /* allow nested opens and closes */
10148 else if (*s == PL_multi_close && --brackets <= 0)
10150 else if (*s == PL_multi_open)
10152 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10157 /* terminate the copied string and update the sv's end-of-string */
10159 SvCUR_set(sv, to - SvPVX_const(sv));
10162 * this next chunk reads more into the buffer if we're not done yet
10166 break; /* handle case where we are done yet :-) */
10168 #ifndef PERL_STRICT_CR
10169 if (to - SvPVX_const(sv) >= 2) {
10170 if ( (to[-2] == '\r' && to[-1] == '\n')
10171 || (to[-2] == '\n' && to[-1] == '\r'))
10175 SvCUR_set(sv, to - SvPVX_const(sv));
10177 else if (to[-1] == '\r')
10180 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10185 /* if we're out of file, or a read fails, bail and reset the current
10186 line marker so we can report where the unterminated string began
10188 COPLINE_INC_WITH_HERELINES;
10189 PL_bufptr = PL_bufend;
10190 if (!lex_next_chunk(0)) {
10192 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10198 /* at this point, we have successfully read the delimited string */
10200 if (!IN_ENCODING || UTF || re_reparse) {
10203 sv_catpvn(sv, s, termlen);
10206 if (has_utf8 || (IN_ENCODING && !re_reparse))
10209 PL_multi_end = CopLINE(PL_curcop);
10210 CopLINE_set(PL_curcop, PL_multi_start);
10211 PL_parser->herelines = herelines;
10213 /* if we allocated too much space, give some back */
10214 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10215 SvLEN_set(sv, SvCUR(sv) + 1);
10216 SvPV_renew(sv, SvLEN(sv));
10219 /* decide whether this is the first or second quoted string we've read
10224 PL_sublex_info.repl = sv;
10227 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10233 takes: pointer to position in buffer
10234 returns: pointer to new position in buffer
10235 side-effects: builds ops for the constant in pl_yylval.op
10237 Read a number in any of the formats that Perl accepts:
10239 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10240 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10241 0b[01](_?[01])* binary integers
10242 0[0-7](_?[0-7])* octal integers
10243 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10244 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10246 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10249 If it reads a number without a decimal point or an exponent, it will
10250 try converting the number to an integer and see if it can do so
10251 without loss of precision.
10255 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10257 const char *s = start; /* current position in buffer */
10258 char *d; /* destination in temp buffer */
10259 char *e; /* end of temp buffer */
10260 NV nv; /* number read, as a double */
10261 SV *sv = NULL; /* place to put the converted number */
10262 bool floatit; /* boolean: int or float? */
10263 const char *lastub = NULL; /* position of last underbar */
10264 static const char* const number_too_long = "Number too long";
10265 /* Hexadecimal floating point.
10267 * In many places (where we have quads and NV is IEEE 754 double)
10268 * we can fit the mantissa bits of a NV into an unsigned quad.
10269 * (Note that UVs might not be quads even when we have quads.)
10270 * This will not work everywhere, though (either no quads, or
10271 * using long doubles), in which case we have to resort to NV,
10272 * which will probably mean horrible loss of precision due to
10273 * multiple fp operations. */
10274 bool hexfp = FALSE;
10275 int total_bits = 0;
10276 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10277 # define HEXFP_UQUAD
10278 Uquad_t hexfp_uquad = 0;
10279 int hexfp_frac_bits = 0;
10284 NV hexfp_mult = 1.0;
10285 UV high_non_zero = 0; /* highest digit */
10287 PERL_ARGS_ASSERT_SCAN_NUM;
10289 /* We use the first character to decide what type of number this is */
10293 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10295 /* if it starts with a 0, it could be an octal number, a decimal in
10296 0.13 disguise, or a hexadecimal number, or a binary number. */
10300 u holds the "number so far"
10301 shift the power of 2 of the base
10302 (hex == 4, octal == 3, binary == 1)
10303 overflowed was the number more than we can hold?
10305 Shift is used when we add a digit. It also serves as an "are
10306 we in octal/hex/binary?" indicator to disallow hex characters
10307 when in octal mode.
10312 bool overflowed = FALSE;
10313 bool just_zero = TRUE; /* just plain 0 or binary number? */
10314 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10315 static const char* const bases[5] =
10316 { "", "binary", "", "octal", "hexadecimal" };
10317 static const char* const Bases[5] =
10318 { "", "Binary", "", "Octal", "Hexadecimal" };
10319 static const char* const maxima[5] =
10321 "0b11111111111111111111111111111111",
10325 const char *base, *Base, *max;
10327 /* check for hex */
10328 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10332 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10337 /* check for a decimal in disguise */
10338 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10340 /* so it must be octal */
10347 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10348 "Misplaced _ in number");
10352 base = bases[shift];
10353 Base = Bases[shift];
10354 max = maxima[shift];
10356 /* read the rest of the number */
10358 /* x is used in the overflow test,
10359 b is the digit we're adding on. */
10364 /* if we don't mention it, we're done */
10368 /* _ are ignored -- but warned about if consecutive */
10370 if (lastub && s == lastub + 1)
10371 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10372 "Misplaced _ in number");
10376 /* 8 and 9 are not octal */
10377 case '8': case '9':
10379 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10383 case '2': case '3': case '4':
10384 case '5': case '6': case '7':
10386 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10389 case '0': case '1':
10390 b = *s++ & 15; /* ASCII digit -> value of digit */
10394 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10395 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10396 /* make sure they said 0x */
10399 b = (*s++ & 7) + 9;
10401 /* Prepare to put the digit we have onto the end
10402 of the number so far. We check for overflows.
10408 x = u << shift; /* make room for the digit */
10410 total_bits += shift;
10412 if ((x >> shift) != u
10413 && !(PL_hints & HINT_NEW_BINARY)) {
10416 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10417 "Integer overflow in %s number",
10420 u = x | b; /* add the digit to the end */
10423 n *= nvshift[shift];
10424 /* If an NV has not enough bits in its
10425 * mantissa to represent an UV this summing of
10426 * small low-order numbers is a waste of time
10427 * (because the NV cannot preserve the
10428 * low-order bits anyway): we could just
10429 * remember when did we overflow and in the
10430 * end just multiply n by the right
10435 if (high_non_zero == 0 && b > 0)
10438 /* this could be hexfp, but peek ahead
10439 * to avoid matching ".." */
10440 if (UNLIKELY(HEXFP_PEEK(s))) {
10448 /* if we get here, we had success: make a scalar value from
10453 /* final misplaced underbar check */
10454 if (s[-1] == '_') {
10455 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10458 if (UNLIKELY(HEXFP_PEEK(s))) {
10459 /* Do sloppy (on the underbars) but quick detection
10460 * (and value construction) for hexfp, the decimal
10461 * detection will shortly be more thorough with the
10462 * underbar checks. */
10466 #else /* HEXFP_NV */
10471 NV mult = 1 / 16.0;
10473 for (h++; (isXDIGIT(*h) || *h == '_'); h++) {
10474 if (isXDIGIT(*h)) {
10475 U8 b = XDIGIT_VALUE(*h);
10476 total_bits += shift;
10477 if (total_bits < NV_MANT_DIG) {
10479 hexfp_uquad <<= shift;
10481 hexfp_frac_bits += shift;
10482 #else /* HEXFP_NV */
10483 hexfp_nv += b * mult;
10486 } else if (total_bits - shift < NV_MANT_DIG) {
10487 /* A hexdigit straddling the edge of
10488 * mantissa. We can try grabbing as
10489 * many as possible bits. */
10493 } else if (b & 2) {
10496 } else if (b & 4) {
10499 } else if (b & 8) {
10504 hexfp_uquad <<= shift2;
10506 hexfp_frac_bits += shift2;
10507 #else /* HEXFP_NV */
10508 PERL_UNUSED_VAR(shift2);
10509 hexfp_nv += b * mult;
10517 if (total_bits >= 4) {
10518 if (high_non_zero < 0x8)
10520 if (high_non_zero < 0x4)
10522 if (high_non_zero < 0x2)
10526 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10527 bool negexp = FALSE;
10531 else if (*h == '-') {
10537 while (isDIGIT(*h) || *h == '_') {
10540 hexfp_exp += *h - '0';
10543 && -hexfp_exp < NV_MIN_EXP - 1) {
10544 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10545 "Hexadecimal float: exponent underflow");
10551 && hexfp_exp > NV_MAX_EXP - 1) {
10552 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10553 "Hexadecimal float: exponent overflow");
10561 hexfp_exp = -hexfp_exp;
10563 hexfp_exp -= hexfp_frac_bits;
10565 hexfp_mult = pow(2.0, hexfp_exp);
10573 if (n > 4294967295.0)
10574 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10575 "%s number > %s non-portable",
10581 if (u > 0xffffffff)
10582 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10583 "%s number > %s non-portable",
10588 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10589 sv = new_constant(start, s - start, "integer",
10590 sv, NULL, NULL, 0);
10591 else if (PL_hints & HINT_NEW_BINARY)
10592 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10597 handle decimal numbers.
10598 we're also sent here when we read a 0 as the first digit
10600 case '1': case '2': case '3': case '4': case '5':
10601 case '6': case '7': case '8': case '9': case '.':
10604 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10613 /* read next group of digits and _ and copy into d */
10616 || UNLIKELY(hexfp && isXDIGIT(*s)))
10618 /* skip underscores, checking for misplaced ones
10622 if (lastub && s == lastub + 1)
10623 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10624 "Misplaced _ in number");
10628 /* check for end of fixed-length buffer */
10630 Perl_croak(aTHX_ "%s", number_too_long);
10631 /* if we're ok, copy the character */
10636 /* final misplaced underbar check */
10637 if (lastub && s == lastub + 1) {
10638 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10641 /* read a decimal portion if there is one. avoid
10642 3..5 being interpreted as the number 3. followed
10645 if (*s == '.' && s[1] != '.') {
10650 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10651 "Misplaced _ in number");
10655 /* copy, ignoring underbars, until we run out of digits.
10659 || UNLIKELY(hexfp && isXDIGIT(*s));
10662 /* fixed length buffer check */
10664 Perl_croak(aTHX_ "%s", number_too_long);
10666 if (lastub && s == lastub + 1)
10667 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10668 "Misplaced _ in number");
10674 /* fractional part ending in underbar? */
10675 if (s[-1] == '_') {
10676 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10677 "Misplaced _ in number");
10679 if (*s == '.' && isDIGIT(s[1])) {
10680 /* oops, it's really a v-string, but without the "v" */
10686 /* read exponent part, if present */
10687 if ((isALPHA_FOLD_EQ(*s, 'e')
10688 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10689 && strchr("+-0123456789_", s[1]))
10693 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10694 ditto for p (hexfloats) */
10695 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10696 /* At least some Mach atof()s don't grok 'E' */
10699 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10706 /* stray preinitial _ */
10708 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10709 "Misplaced _ in number");
10713 /* allow positive or negative exponent */
10714 if (*s == '+' || *s == '-')
10717 /* stray initial _ */
10719 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10720 "Misplaced _ in number");
10724 /* read digits of exponent */
10725 while (isDIGIT(*s) || *s == '_') {
10728 Perl_croak(aTHX_ "%s", number_too_long);
10732 if (((lastub && s == lastub + 1)
10733 || (!isDIGIT(s[1]) && s[1] != '_')))
10734 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10735 "Misplaced _ in number");
10743 We try to do an integer conversion first if no characters
10744 indicating "float" have been found.
10749 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10751 if (flags == IS_NUMBER_IN_UV) {
10753 sv = newSViv(uv); /* Prefer IVs over UVs. */
10756 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10757 if (uv <= (UV) IV_MIN)
10758 sv = newSViv(-(IV)uv);
10765 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
10766 /* terminate the string */
10768 if (UNLIKELY(hexfp)) {
10769 # ifdef NV_MANT_DIG
10770 if (total_bits > NV_MANT_DIG)
10771 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10772 "Hexadecimal float: mantissa overflow");
10775 nv = hexfp_uquad * hexfp_mult;
10776 #else /* HEXFP_NV */
10777 nv = hexfp_nv * hexfp_mult;
10780 nv = Atof(PL_tokenbuf);
10782 RESTORE_LC_NUMERIC_UNDERLYING();
10787 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10788 const char *const key = floatit ? "float" : "integer";
10789 const STRLEN keylen = floatit ? 5 : 7;
10790 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10791 key, keylen, sv, NULL, NULL, 0);
10795 /* if it starts with a v, it could be a v-string */
10798 sv = newSV(5); /* preallocate storage space */
10799 ENTER_with_name("scan_vstring");
10801 s = scan_vstring(s, PL_bufend, sv);
10802 SvREFCNT_inc_simple_void_NN(sv);
10803 LEAVE_with_name("scan_vstring");
10807 /* make the op for the constant and return */
10810 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10812 lvalp->opval = NULL;
10818 S_scan_formline(pTHX_ char *s)
10822 SV * const stuff = newSVpvs("");
10823 bool needargs = FALSE;
10824 bool eofmt = FALSE;
10826 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10828 while (!needargs) {
10831 #ifdef PERL_STRICT_CR
10832 while (SPACE_OR_TAB(*t))
10835 while (SPACE_OR_TAB(*t) || *t == '\r')
10838 if (*t == '\n' || t == PL_bufend) {
10843 eol = (char *) memchr(s,'\n',PL_bufend-s);
10847 for (t = s; t < eol; t++) {
10848 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10850 goto enough; /* ~~ must be first line in formline */
10852 if (*t == '@' || *t == '^')
10856 sv_catpvn(stuff, s, eol-s);
10857 #ifndef PERL_STRICT_CR
10858 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10859 char *end = SvPVX(stuff) + SvCUR(stuff);
10862 SvCUR_set(stuff, SvCUR(stuff) - 1);
10870 if ((PL_rsfp || PL_parser->filtered)
10871 && PL_parser->form_lex_state == LEX_NORMAL) {
10873 PL_bufptr = PL_bufend;
10874 COPLINE_INC_WITH_HERELINES;
10875 got_some = lex_next_chunk(0);
10876 CopLINE_dec(PL_curcop);
10884 if (!SvCUR(stuff) || needargs)
10885 PL_lex_state = PL_parser->form_lex_state;
10886 if (SvCUR(stuff)) {
10887 PL_expect = XSTATE;
10889 const char *s2 = s;
10890 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10894 PL_expect = XTERMBLOCK;
10895 NEXTVAL_NEXTTOKE.ival = 0;
10898 NEXTVAL_NEXTTOKE.ival = 0;
10899 force_next(FORMLBRACK);
10902 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10904 else if (IN_ENCODING)
10905 sv_recode_to_utf8(stuff, _get_encoding());
10907 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10911 SvREFCNT_dec(stuff);
10913 PL_lex_formbrack = 0;
10919 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10921 const I32 oldsavestack_ix = PL_savestack_ix;
10922 CV* const outsidecv = PL_compcv;
10924 SAVEI32(PL_subline);
10925 save_item(PL_subname);
10926 SAVESPTR(PL_compcv);
10928 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10929 CvFLAGS(PL_compcv) |= flags;
10931 PL_subline = CopLINE(PL_curcop);
10932 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10933 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10934 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10935 if (outsidecv && CvPADLIST(outsidecv))
10936 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10938 return oldsavestack_ix;
10942 S_yywarn(pTHX_ const char *const s, U32 flags)
10944 PERL_ARGS_ASSERT_YYWARN;
10946 PL_in_eval |= EVAL_WARNONLY;
10947 yyerror_pv(s, flags);
10952 Perl_yyerror(pTHX_ const char *const s)
10954 PERL_ARGS_ASSERT_YYERROR;
10955 return yyerror_pvn(s, strlen(s), 0);
10959 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10961 PERL_ARGS_ASSERT_YYERROR_PV;
10962 return yyerror_pvn(s, strlen(s), flags);
10966 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10968 const char *context = NULL;
10971 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10972 int yychar = PL_parser->yychar;
10974 PERL_ARGS_ASSERT_YYERROR_PVN;
10976 if (!yychar || (yychar == ';' && !PL_rsfp))
10977 sv_catpvs(where_sv, "at EOF");
10978 else if ( PL_oldoldbufptr
10979 && PL_bufptr > PL_oldoldbufptr
10980 && PL_bufptr - PL_oldoldbufptr < 200
10981 && PL_oldoldbufptr != PL_oldbufptr
10982 && PL_oldbufptr != PL_bufptr)
10986 The code below is removed for NetWare because it abends/crashes on NetWare
10987 when the script has error such as not having the closing quotes like:
10988 if ($var eq "value)
10989 Checking of white spaces is anyway done in NetWare code.
10992 while (isSPACE(*PL_oldoldbufptr))
10995 context = PL_oldoldbufptr;
10996 contlen = PL_bufptr - PL_oldoldbufptr;
10998 else if ( PL_oldbufptr
10999 && PL_bufptr > PL_oldbufptr
11000 && PL_bufptr - PL_oldbufptr < 200
11001 && PL_oldbufptr != PL_bufptr) {
11004 The code below is removed for NetWare because it abends/crashes on NetWare
11005 when the script has error such as not having the closing quotes like:
11006 if ($var eq "value)
11007 Checking of white spaces is anyway done in NetWare code.
11010 while (isSPACE(*PL_oldbufptr))
11013 context = PL_oldbufptr;
11014 contlen = PL_bufptr - PL_oldbufptr;
11016 else if (yychar > 255)
11017 sv_catpvs(where_sv, "next token ???");
11018 else if (yychar == YYEMPTY) {
11019 if ( PL_lex_state == LEX_NORMAL
11020 || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11021 sv_catpvs(where_sv, "at end of line");
11022 else if (PL_lex_inpat)
11023 sv_catpvs(where_sv, "within pattern");
11025 sv_catpvs(where_sv, "within string");
11028 sv_catpvs(where_sv, "next char ");
11030 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11031 else if (isPRINT_LC(yychar)) {
11032 const char string = yychar;
11033 sv_catpvn(where_sv, &string, 1);
11036 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11038 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11039 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11040 OutCopFILE(PL_curcop),
11041 (IV)(PL_parser->preambling == NOLINE
11042 ? CopLINE(PL_curcop)
11043 : PL_parser->preambling));
11045 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11046 UTF8fARG(UTF, contlen, context));
11048 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11049 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11050 Perl_sv_catpvf(aTHX_ msg,
11051 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11052 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11055 if (PL_in_eval & EVAL_WARNONLY) {
11056 PL_in_eval &= ~EVAL_WARNONLY;
11057 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11061 if (PL_error_count >= 10) {
11063 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11064 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11065 SVfARG(errsv), OutCopFILE(PL_curcop));
11067 Perl_croak(aTHX_ "%s has too many errors.\n",
11068 OutCopFILE(PL_curcop));
11071 PL_in_my_stash = NULL;
11076 S_swallow_bom(pTHX_ U8 *s)
11078 const STRLEN slen = SvCUR(PL_linestr);
11080 PERL_ARGS_ASSERT_SWALLOW_BOM;
11084 if (s[1] == 0xFE) {
11085 /* UTF-16 little-endian? (or UTF-32LE?) */
11086 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11087 /* diag_listed_as: Unsupported script encoding %s */
11088 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11089 #ifndef PERL_NO_UTF16_FILTER
11090 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11092 if (PL_bufend > (char*)s) {
11093 s = add_utf16_textfilter(s, TRUE);
11096 /* diag_listed_as: Unsupported script encoding %s */
11097 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11102 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11103 #ifndef PERL_NO_UTF16_FILTER
11104 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11106 if (PL_bufend > (char *)s) {
11107 s = add_utf16_textfilter(s, FALSE);
11110 /* diag_listed_as: Unsupported script encoding %s */
11111 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11115 case BOM_UTF8_FIRST_BYTE: {
11116 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
11117 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
11118 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11119 s += len + 1; /* UTF-8 */
11126 if (s[2] == 0xFE && s[3] == 0xFF) {
11127 /* UTF-32 big-endian */
11128 /* diag_listed_as: Unsupported script encoding %s */
11129 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11132 else if (s[2] == 0 && s[3] != 0) {
11135 * are a good indicator of UTF-16BE. */
11136 #ifndef PERL_NO_UTF16_FILTER
11137 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11138 s = add_utf16_textfilter(s, FALSE);
11140 /* diag_listed_as: Unsupported script encoding %s */
11141 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11148 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11151 * are a good indicator of UTF-16LE. */
11152 #ifndef PERL_NO_UTF16_FILTER
11153 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11154 s = add_utf16_textfilter(s, TRUE);
11156 /* diag_listed_as: Unsupported script encoding %s */
11157 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11165 #ifndef PERL_NO_UTF16_FILTER
11167 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11169 SV *const filter = FILTER_DATA(idx);
11170 /* We re-use this each time round, throwing the contents away before we
11172 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11173 SV *const utf8_buffer = filter;
11174 IV status = IoPAGE(filter);
11175 const bool reverse = cBOOL(IoLINES(filter));
11178 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11180 /* As we're automatically added, at the lowest level, and hence only called
11181 from this file, we can be sure that we're not called in block mode. Hence
11182 don't bother writing code to deal with block mode. */
11184 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11187 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11189 DEBUG_P(PerlIO_printf(Perl_debug_log,
11190 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11191 FPTR2DPTR(void *, S_utf16_textfilter),
11192 reverse ? 'l' : 'b', idx, maxlen, status,
11193 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11200 /* First, look in our buffer of existing UTF-8 data: */
11201 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11205 } else if (status == 0) {
11207 IoPAGE(filter) = 0;
11208 nl = SvEND(utf8_buffer);
11211 STRLEN got = nl - SvPVX(utf8_buffer);
11212 /* Did we have anything to append? */
11214 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11215 /* Everything else in this code works just fine if SVp_POK isn't
11216 set. This, however, needs it, and we need it to work, else
11217 we loop infinitely because the buffer is never consumed. */
11218 sv_chop(utf8_buffer, nl);
11222 /* OK, not a complete line there, so need to read some more UTF-16.
11223 Read an extra octect if the buffer currently has an odd number. */
11227 if (SvCUR(utf16_buffer) >= 2) {
11228 /* Location of the high octet of the last complete code point.
11229 Gosh, UTF-16 is a pain. All the benefits of variable length,
11230 *coupled* with all the benefits of partial reads and
11232 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11233 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11235 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11239 /* We have the first half of a surrogate. Read more. */
11240 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11243 status = FILTER_READ(idx + 1, utf16_buffer,
11244 160 + (SvCUR(utf16_buffer) & 1));
11245 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11246 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11249 IoPAGE(filter) = status;
11254 chars = SvCUR(utf16_buffer) >> 1;
11255 have = SvCUR(utf8_buffer);
11256 SvGROW(utf8_buffer, have + chars * 3 + 1);
11259 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11260 (U8*)SvPVX_const(utf8_buffer) + have,
11261 chars * 2, &newlen);
11263 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11264 (U8*)SvPVX_const(utf8_buffer) + have,
11265 chars * 2, &newlen);
11267 SvCUR_set(utf8_buffer, have + newlen);
11270 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11271 it's private to us, and utf16_to_utf8{,reversed} take a
11272 (pointer,length) pair, rather than a NUL-terminated string. */
11273 if(SvCUR(utf16_buffer) & 1) {
11274 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11275 SvCUR_set(utf16_buffer, 1);
11277 SvCUR_set(utf16_buffer, 0);
11280 DEBUG_P(PerlIO_printf(Perl_debug_log,
11281 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11283 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11284 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11289 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11291 SV *filter = filter_add(S_utf16_textfilter, NULL);
11293 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11295 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11296 sv_setpvs(filter, "");
11297 IoLINES(filter) = reversed;
11298 IoPAGE(filter) = 1; /* Not EOF */
11300 /* Sadly, we have to return a valid pointer, come what may, so we have to
11301 ignore any error return from this. */
11302 SvCUR_set(PL_linestr, 0);
11303 if (FILTER_READ(0, PL_linestr, 0)) {
11304 SvUTF8_on(PL_linestr);
11306 SvUTF8_on(PL_linestr);
11308 PL_bufend = SvEND(PL_linestr);
11309 return (U8*)SvPVX(PL_linestr);
11314 Returns a pointer to the next character after the parsed
11315 vstring, as well as updating the passed in sv.
11317 Function must be called like
11319 sv = sv_2mortal(newSV(5));
11320 s = scan_vstring(s,e,sv);
11322 where s and e are the start and end of the string.
11323 The sv should already be large enough to store the vstring
11324 passed in, for performance reasons.
11326 This function may croak if fatal warnings are enabled in the
11327 calling scope, hence the sv_2mortal in the example (to prevent
11328 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11334 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11336 const char *pos = s;
11337 const char *start = s;
11339 PERL_ARGS_ASSERT_SCAN_VSTRING;
11341 if (*pos == 'v') pos++; /* get past 'v' */
11342 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11344 if ( *pos != '.') {
11345 /* this may not be a v-string if followed by => */
11346 const char *next = pos;
11347 while (next < e && isSPACE(*next))
11349 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11350 /* return string not v-string */
11351 sv_setpvn(sv,(char *)s,pos-s);
11352 return (char *)pos;
11356 if (!isALPHA(*pos)) {
11357 U8 tmpbuf[UTF8_MAXBYTES+1];
11360 s++; /* get past 'v' */
11365 /* this is atoi() that tolerates underscores */
11368 const char *end = pos;
11370 while (--end >= s) {
11372 const UV orev = rev;
11373 rev += (*end - '0') * mult;
11376 /* diag_listed_as: Integer overflow in %s number */
11377 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11378 "Integer overflow in decimal number");
11382 if (rev > 0x7FFFFFFF)
11383 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11385 /* Append native character for the rev point */
11386 tmpend = uvchr_to_utf8(tmpbuf, rev);
11387 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11388 if (!UVCHR_IS_INVARIANT(rev))
11390 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11396 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11400 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11407 Perl_keyword_plugin_standard(pTHX_
11408 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11410 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11411 PERL_UNUSED_CONTEXT;
11412 PERL_UNUSED_ARG(keyword_ptr);
11413 PERL_UNUSED_ARG(keyword_len);
11414 PERL_UNUSED_ARG(op_ptr);
11415 return KEYWORD_PLUGIN_DECLINE;
11418 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11420 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11422 SAVEI32(PL_lex_brackets);
11423 if (PL_lex_brackets > 100)
11424 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11425 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11426 SAVEI32(PL_lex_allbrackets);
11427 PL_lex_allbrackets = 0;
11428 SAVEI8(PL_lex_fakeeof);
11429 PL_lex_fakeeof = (U8)fakeeof;
11430 if(yyparse(gramtype) && !PL_parser->error_count)
11431 qerror(Perl_mess(aTHX_ "Parse error"));
11434 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11436 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11440 SAVEVPTR(PL_eval_root);
11441 PL_eval_root = NULL;
11442 parse_recdescent(gramtype, fakeeof);
11448 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11450 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11453 if (flags & ~PARSE_OPTIONAL)
11454 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11455 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11456 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11457 if (!PL_parser->error_count)
11458 qerror(Perl_mess(aTHX_ "Parse error"));
11459 exprop = newOP(OP_NULL, 0);
11465 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11467 Parse a Perl arithmetic expression. This may contain operators of precedence
11468 down to the bit shift operators. The expression must be followed (and thus
11469 terminated) either by a comparison or lower-precedence operator or by
11470 something that would normally terminate an expression such as semicolon.
11471 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11472 otherwise it is mandatory. It is up to the caller to ensure that the
11473 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11474 the source of the code to be parsed and the lexical context for the
11477 The op tree representing the expression is returned. If an optional
11478 expression is absent, a null pointer is returned, otherwise the pointer
11481 If an error occurs in parsing or compilation, in most cases a valid op
11482 tree is returned anyway. The error is reflected in the parser state,
11483 normally resulting in a single exception at the top level of parsing
11484 which covers all the compilation errors that occurred. Some compilation
11485 errors, however, will throw an exception immediately.
11491 Perl_parse_arithexpr(pTHX_ U32 flags)
11493 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11497 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11499 Parse a Perl term expression. This may contain operators of precedence
11500 down to the assignment operators. The expression must be followed (and thus
11501 terminated) either by a comma or lower-precedence operator or by
11502 something that would normally terminate an expression such as semicolon.
11503 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11504 otherwise it is mandatory. It is up to the caller to ensure that the
11505 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11506 the source of the code to be parsed and the lexical context for the
11509 The op tree representing the expression is returned. If an optional
11510 expression is absent, a null pointer is returned, otherwise the pointer
11513 If an error occurs in parsing or compilation, in most cases a valid op
11514 tree is returned anyway. The error is reflected in the parser state,
11515 normally resulting in a single exception at the top level of parsing
11516 which covers all the compilation errors that occurred. Some compilation
11517 errors, however, will throw an exception immediately.
11523 Perl_parse_termexpr(pTHX_ U32 flags)
11525 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11529 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11531 Parse a Perl list expression. This may contain operators of precedence
11532 down to the comma operator. The expression must be followed (and thus
11533 terminated) either by a low-precedence logic operator such as C<or> or by
11534 something that would normally terminate an expression such as semicolon.
11535 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
11536 otherwise it is mandatory. It is up to the caller to ensure that the
11537 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11538 the source of the code to be parsed and the lexical context for the
11541 The op tree representing the expression is returned. If an optional
11542 expression is absent, a null pointer is returned, otherwise the pointer
11545 If an error occurs in parsing or compilation, in most cases a valid op
11546 tree is returned anyway. The error is reflected in the parser state,
11547 normally resulting in a single exception at the top level of parsing
11548 which covers all the compilation errors that occurred. Some compilation
11549 errors, however, will throw an exception immediately.
11555 Perl_parse_listexpr(pTHX_ U32 flags)
11557 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11561 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11563 Parse a single complete Perl expression. This allows the full
11564 expression grammar, including the lowest-precedence operators such
11565 as C<or>. The expression must be followed (and thus terminated) by a
11566 token that an expression would normally be terminated by: end-of-file,
11567 closing bracketing punctuation, semicolon, or one of the keywords that
11568 signals a postfix expression-statement modifier. If C<flags> has the
11569 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
11570 mandatory. It is up to the caller to ensure that the dynamic parser
11571 state (L</PL_parser> et al) is correctly set to reflect the source of
11572 the code to be parsed and the lexical context for the expression.
11574 The op tree representing the expression is returned. If an optional
11575 expression is absent, a null pointer is returned, otherwise the pointer
11578 If an error occurs in parsing or compilation, in most cases a valid op
11579 tree is returned anyway. The error is reflected in the parser state,
11580 normally resulting in a single exception at the top level of parsing
11581 which covers all the compilation errors that occurred. Some compilation
11582 errors, however, will throw an exception immediately.
11588 Perl_parse_fullexpr(pTHX_ U32 flags)
11590 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11594 =for apidoc Amx|OP *|parse_block|U32 flags
11596 Parse a single complete Perl code block. This consists of an opening
11597 brace, a sequence of statements, and a closing brace. The block
11598 constitutes a lexical scope, so C<my> variables and various compile-time
11599 effects can be contained within it. It is up to the caller to ensure
11600 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11601 reflect the source of the code to be parsed and the lexical context for
11604 The op tree representing the code block is returned. This is always a
11605 real op, never a null pointer. It will normally be a C<lineseq> list,
11606 including C<nextstate> or equivalent ops. No ops to construct any kind
11607 of runtime scope are included by virtue of it being a block.
11609 If an error occurs in parsing or compilation, in most cases a valid op
11610 tree (most likely null) is returned anyway. The error is reflected in
11611 the parser state, normally resulting in a single exception at the top
11612 level of parsing which covers all the compilation errors that occurred.
11613 Some compilation errors, however, will throw an exception immediately.
11615 The C<flags> parameter is reserved for future use, and must always
11622 Perl_parse_block(pTHX_ U32 flags)
11625 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11626 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11630 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11632 Parse a single unadorned Perl statement. This may be a normal imperative
11633 statement or a declaration that has compile-time effect. It does not
11634 include any label or other affixture. It is up to the caller to ensure
11635 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11636 reflect the source of the code to be parsed and the lexical context for
11639 The op tree representing the statement is returned. This may be a
11640 null pointer if the statement is null, for example if it was actually
11641 a subroutine definition (which has compile-time side effects). If not
11642 null, it will be ops directly implementing the statement, suitable to
11643 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11644 equivalent op (except for those embedded in a scope contained entirely
11645 within the statement).
11647 If an error occurs in parsing or compilation, in most cases a valid op
11648 tree (most likely null) is returned anyway. The error is reflected in
11649 the parser state, normally resulting in a single exception at the top
11650 level of parsing which covers all the compilation errors that occurred.
11651 Some compilation errors, however, will throw an exception immediately.
11653 The C<flags> parameter is reserved for future use, and must always
11660 Perl_parse_barestmt(pTHX_ U32 flags)
11663 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11664 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11668 =for apidoc Amx|SV *|parse_label|U32 flags
11670 Parse a single label, possibly optional, of the type that may prefix a
11671 Perl statement. It is up to the caller to ensure that the dynamic parser
11672 state (L</PL_parser> et al) is correctly set to reflect the source of
11673 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
11674 label is optional, otherwise it is mandatory.
11676 The name of the label is returned in the form of a fresh scalar. If an
11677 optional label is absent, a null pointer is returned.
11679 If an error occurs in parsing, which can only occur if the label is
11680 mandatory, a valid label is returned anyway. The error is reflected in
11681 the parser state, normally resulting in a single exception at the top
11682 level of parsing which covers all the compilation errors that occurred.
11688 Perl_parse_label(pTHX_ U32 flags)
11690 if (flags & ~PARSE_OPTIONAL)
11691 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11692 if (PL_lex_state == LEX_KNOWNEXT) {
11693 PL_parser->yychar = yylex();
11694 if (PL_parser->yychar == LABEL) {
11695 char * const lpv = pl_yylval.pval;
11696 STRLEN llen = strlen(lpv);
11697 PL_parser->yychar = YYEMPTY;
11698 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11705 STRLEN wlen, bufptr_pos;
11708 if (!isIDFIRST_lazy_if(s, UTF))
11710 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11711 if (word_takes_any_delimeter(s, wlen))
11713 bufptr_pos = s - SvPVX(PL_linestr);
11715 lex_read_space(LEX_KEEP_PREVIOUS);
11717 s = SvPVX(PL_linestr) + bufptr_pos;
11718 if (t[0] == ':' && t[1] != ':') {
11719 PL_oldoldbufptr = PL_oldbufptr;
11722 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11726 if (flags & PARSE_OPTIONAL) {
11729 qerror(Perl_mess(aTHX_ "Parse error"));
11730 return newSVpvs("x");
11737 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11739 Parse a single complete Perl statement. This may be a normal imperative
11740 statement or a declaration that has compile-time effect, and may include
11741 optional labels. It is up to the caller to ensure that the dynamic
11742 parser state (L</PL_parser> et al) is correctly set to reflect the source
11743 of the code to be parsed and the lexical context for the statement.
11745 The op tree representing the statement is returned. This may be a
11746 null pointer if the statement is null, for example if it was actually
11747 a subroutine definition (which has compile-time side effects). If not
11748 null, it will be the result of a L</newSTATEOP> call, normally including
11749 a C<nextstate> or equivalent op.
11751 If an error occurs in parsing or compilation, in most cases a valid op
11752 tree (most likely null) is returned anyway. The error is reflected in
11753 the parser state, normally resulting in a single exception at the top
11754 level of parsing which covers all the compilation errors that occurred.
11755 Some compilation errors, however, will throw an exception immediately.
11757 The C<flags> parameter is reserved for future use, and must always
11764 Perl_parse_fullstmt(pTHX_ U32 flags)
11767 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11768 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11772 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11774 Parse a sequence of zero or more Perl statements. These may be normal
11775 imperative statements, including optional labels, or declarations
11776 that have compile-time effect, or any mixture thereof. The statement
11777 sequence ends when a closing brace or end-of-file is encountered in a
11778 place where a new statement could have validly started. It is up to
11779 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11780 is correctly set to reflect the source of the code to be parsed and the
11781 lexical context for the statements.
11783 The op tree representing the statement sequence is returned. This may
11784 be a null pointer if the statements were all null, for example if there
11785 were no statements or if there were only subroutine definitions (which
11786 have compile-time side effects). If not null, it will be a C<lineseq>
11787 list, normally including C<nextstate> or equivalent ops.
11789 If an error occurs in parsing or compilation, in most cases a valid op
11790 tree is returned anyway. The error is reflected in the parser state,
11791 normally resulting in a single exception at the top level of parsing
11792 which covers all the compilation errors that occurred. Some compilation
11793 errors, however, will throw an exception immediately.
11795 The C<flags> parameter is reserved for future use, and must always
11802 Perl_parse_stmtseq(pTHX_ U32 flags)
11807 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11808 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11809 c = lex_peek_unichar(0);
11810 if (c != -1 && c != /*{*/'}')
11811 qerror(Perl_mess(aTHX_ "Parse error"));
11815 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11817 S_lex_token_boundary(pTHX)
11819 PL_oldoldbufptr = PL_oldbufptr;
11820 PL_oldbufptr = PL_bufptr;
11823 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11825 S_parse_opt_lexvar(pTHX)
11830 lex_token_boundary();
11831 sigil = lex_read_unichar(0);
11832 if (lex_peek_unichar(0) == '#') {
11833 qerror(Perl_mess(aTHX_ "Parse error"));
11837 c = lex_peek_unichar(0);
11838 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11841 d = PL_tokenbuf + 1;
11842 PL_tokenbuf[0] = (char)sigil;
11843 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11845 if (d == PL_tokenbuf+1)
11847 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11848 OPf_MOD | (OPpLVAL_INTRO<<8));
11849 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11854 Perl_parse_subsignature(pTHX)
11857 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11858 OP *initops = NULL;
11860 c = lex_peek_unichar(0);
11861 while (c != /*(*/')') {
11865 if (prev_type == 2)
11866 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11867 var = parse_opt_lexvar();
11869 newBINOP(OP_AELEM, 0,
11870 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11872 newSVOP(OP_CONST, 0, newSViv(pos))) :
11875 c = lex_peek_unichar(0);
11877 lex_token_boundary();
11878 lex_read_unichar(0);
11880 c = lex_peek_unichar(0);
11881 if (c == ',' || c == /*(*/')') {
11883 qerror(Perl_mess(aTHX_ "Optional parameter "
11884 "lacks default expression"));
11886 OP *defexpr = parse_termexpr(0);
11887 if (defexpr->op_type == OP_UNDEF
11888 && !(defexpr->op_flags & OPf_KIDS))
11894 scalar(newUNOP(OP_RV2AV, 0,
11895 newGVOP(OP_GV, 0, PL_defgv))),
11896 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11898 newCONDOP(0, ifop, expr, defexpr) :
11899 newLOGOP(OP_OR, 0, ifop, defexpr);
11904 if (prev_type == 1)
11905 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11906 "follows optional parameter"));
11908 min_arity = pos + 1;
11910 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11912 initops = op_append_list(OP_LINESEQ, initops,
11913 newSTATEOP(0, NULL, expr));
11919 if (prev_type == 2)
11920 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11921 var = parse_opt_lexvar();
11923 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11924 newBINOP(OP_BIT_AND, 0,
11925 scalar(newUNOP(OP_RV2AV, 0,
11926 newGVOP(OP_GV, 0, PL_defgv))),
11927 newSVOP(OP_CONST, 0, newSViv(1))),
11928 op_convert_list(OP_DIE, 0,
11929 op_convert_list(OP_SPRINTF, 0,
11930 op_append_list(OP_LIST,
11931 newSVOP(OP_CONST, 0,
11932 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11934 op_append_list(OP_LIST,
11935 newSVOP(OP_CONST, 0, newSViv(1)),
11936 newSVOP(OP_CONST, 0, newSViv(2))),
11937 newOP(OP_CALLER, 0))))));
11938 if (pos != min_arity)
11939 chkop = newLOGOP(OP_AND, 0,
11941 scalar(newUNOP(OP_RV2AV, 0,
11942 newGVOP(OP_GV, 0, PL_defgv))),
11943 newSVOP(OP_CONST, 0, newSViv(pos))),
11945 initops = op_append_list(OP_LINESEQ,
11946 newSTATEOP(0, NULL, chkop),
11951 op_prepend_elem(OP_ASLICE,
11952 newOP(OP_PUSHMARK, 0),
11953 newLISTOP(OP_ASLICE, 0,
11955 newSVOP(OP_CONST, 0, newSViv(pos)),
11956 newUNOP(OP_AV2ARYLEN, 0,
11957 ref(newUNOP(OP_RV2AV, 0,
11958 newGVOP(OP_GV, 0, PL_defgv)),
11960 ref(newUNOP(OP_RV2AV, 0,
11961 newGVOP(OP_GV, 0, PL_defgv)),
11963 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11964 initops = op_append_list(OP_LINESEQ, initops,
11965 newSTATEOP(0, NULL,
11966 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11973 qerror(Perl_mess(aTHX_ "Parse error"));
11977 c = lex_peek_unichar(0);
11979 case /*(*/')': break;
11982 lex_token_boundary();
11983 lex_read_unichar(0);
11985 c = lex_peek_unichar(0);
11986 } while (c == ',');
11992 if (min_arity != 0) {
11993 initops = op_append_list(OP_LINESEQ,
11994 newSTATEOP(0, NULL,
11997 scalar(newUNOP(OP_RV2AV, 0,
11998 newGVOP(OP_GV, 0, PL_defgv))),
11999 newSVOP(OP_CONST, 0, newSViv(min_arity))),
12000 op_convert_list(OP_DIE, 0,
12001 op_convert_list(OP_SPRINTF, 0,
12002 op_append_list(OP_LIST,
12003 newSVOP(OP_CONST, 0,
12004 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
12006 op_append_list(OP_LIST,
12007 newSVOP(OP_CONST, 0, newSViv(1)),
12008 newSVOP(OP_CONST, 0, newSViv(2))),
12009 newOP(OP_CALLER, 0))))))),
12012 if (max_arity != -1) {
12013 initops = op_append_list(OP_LINESEQ,
12014 newSTATEOP(0, NULL,
12017 scalar(newUNOP(OP_RV2AV, 0,
12018 newGVOP(OP_GV, 0, PL_defgv))),
12019 newSVOP(OP_CONST, 0, newSViv(max_arity))),
12020 op_convert_list(OP_DIE, 0,
12021 op_convert_list(OP_SPRINTF, 0,
12022 op_append_list(OP_LIST,
12023 newSVOP(OP_CONST, 0,
12024 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
12026 op_append_list(OP_LIST,
12027 newSVOP(OP_CONST, 0, newSViv(1)),
12028 newSVOP(OP_CONST, 0, newSViv(2))),
12029 newOP(OP_CALLER, 0))))))),
12036 * ex: set ts=8 sts=4 sw=4 et: