3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_static.c"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_sublex_info (PL_parser->sublex_info)
69 #define PL_linestr (PL_parser->linestr)
70 #define PL_expect (PL_parser->expect)
71 #define PL_copline (PL_parser->copline)
72 #define PL_bufptr (PL_parser->bufptr)
73 #define PL_oldbufptr (PL_parser->oldbufptr)
74 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
75 #define PL_linestart (PL_parser->linestart)
76 #define PL_bufend (PL_parser->bufend)
77 #define PL_last_uni (PL_parser->last_uni)
78 #define PL_last_lop (PL_parser->last_lop)
79 #define PL_last_lop_op (PL_parser->last_lop_op)
80 #define PL_lex_state (PL_parser->lex_state)
81 #define PL_rsfp (PL_parser->rsfp)
82 #define PL_rsfp_filters (PL_parser->rsfp_filters)
83 #define PL_in_my (PL_parser->in_my)
84 #define PL_in_my_stash (PL_parser->in_my_stash)
85 #define PL_tokenbuf (PL_parser->tokenbuf)
86 #define PL_multi_end (PL_parser->multi_end)
87 #define PL_error_count (PL_parser->error_count)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_nexttype (PL_parser->nexttype)
91 # define PL_nextval (PL_parser->nextval)
93 static const char* const ident_too_long = "Identifier too long";
95 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
97 #define XENUMMASK 0x3f
99 #define XFAKEBRACK 0x80
101 #ifdef USE_UTF8_SCRIPTS
102 # define UTF cBOOL(!IN_BYTES)
104 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
107 /* The maximum number of characters preceding the unrecognized one to display */
108 #define UNRECOGNIZED_PRECEDE_COUNT 10
110 /* In variables named $^X, these are the legal values for X.
111 * 1999-02-27 mjd-perl-patch@plover.com */
112 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
114 #define SPACE_OR_TAB(c) isBLANK_A(c)
116 #define HEXFP_PEEK(s) \
118 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
119 isALPHA_FOLD_EQ(s[0], 'p'))
121 /* LEX_* are values for PL_lex_state, the state of the lexer.
122 * They are arranged oddly so that the guard on the switch statement
123 * can get by with a single comparison (if the compiler is smart enough).
125 * These values refer to the various states within a sublex parse,
126 * i.e. within a double quotish string
129 /* #define LEX_NOTPARSING 11 is done in perl.h. */
131 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
132 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
133 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
134 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
135 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
137 /* at end of code, eg "$x" followed by: */
138 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
139 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
141 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
142 string or after \E, $foo, etc */
143 #define LEX_INTERPCONST 2 /* NOT USED */
144 #define LEX_FORMLINE 1 /* expecting a format line */
145 #define LEX_KNOWNEXT 0 /* next token known; just return it */
149 static const char* const lex_state_names[] = {
164 #include "keywords.h"
166 /* CLINE is a macro that ensures PL_copline has a sane value */
168 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 * Convenience functions to return different tokens and prime the
172 * lexer for the next token. They all take an argument.
174 * TOKEN : generic token (used for '(', DOLSHARP, etc)
175 * OPERATOR : generic operator
176 * AOPERATOR : assignment operator
177 * PREBLOCK : beginning the block after an if, while, foreach, ...
178 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
179 * PREREF : *EXPR where EXPR is not a simple identifier
180 * TERM : expression term
181 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
182 * LOOPX : loop exiting command (goto, last, dump, etc)
183 * FTST : file test operator
184 * FUN0 : zero-argument function
185 * FUN0OP : zero-argument function, with its op created in this file
186 * FUN1 : not used, except for not, which isn't a UNIOP
187 * BOop : bitwise or or xor
189 * SHop : shift operator
190 * PWop : power operator
191 * PMop : pattern-matching operator
192 * Aop : addition-level operator
193 * AopNOASSIGN : addition-level operator that is never part of .=
194 * Mop : multiplication-level operator
195 * Eop : equality-testing operator
196 * Rop : relational operator <= != gt
198 * Also see LOP and lop() below.
201 #ifdef DEBUGGING /* Serve -DT. */
202 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
204 # define REPORT(retval) (retval)
207 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
208 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
209 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
210 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
211 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
213 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
214 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
215 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
217 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
219 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
220 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
221 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
222 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
223 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
224 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
225 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
226 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
227 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
228 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
229 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
230 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
231 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
232 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
234 /* This bit of chicanery makes a unary function followed by
235 * a parenthesis into a function with one argument, highest precedence.
236 * The UNIDOR macro is for unary functions that can be followed by the //
237 * operator (such as C<shift // 0>).
239 #define UNI3(f,x,have_x) { \
240 pl_yylval.ival = f; \
241 if (have_x) PL_expect = x; \
243 PL_last_uni = PL_oldbufptr; \
244 PL_last_lop_op = f; \
246 return REPORT( (int)FUNC1 ); \
248 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
250 #define UNI(f) UNI3(f,XTERM,1)
251 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
252 #define UNIPROTO(f,optional) { \
253 if (optional) PL_last_uni = PL_oldbufptr; \
257 #define UNIBRACK(f) UNI3(f,0,0)
259 /* grandfather return to old style */
262 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
263 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
264 pl_yylval.ival = (f); \
270 #define COPLINE_INC_WITH_HERELINES \
272 CopLINE_inc(PL_curcop); \
273 if (PL_parser->herelines) \
274 CopLINE(PL_curcop) += PL_parser->herelines, \
275 PL_parser->herelines = 0; \
277 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
278 * is no sublex_push to follow. */
279 #define COPLINE_SET_FROM_MULTI_END \
281 CopLINE_set(PL_curcop, PL_multi_end); \
282 if (PL_multi_end != PL_multi_start) \
283 PL_parser->herelines = 0; \
289 /* how to interpret the pl_yylval associated with the token */
293 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
298 static struct debug_tokens {
300 enum token_type type;
302 } const debug_tokens[] =
304 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
305 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
306 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
307 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
308 { ARROW, TOKENTYPE_NONE, "ARROW" },
309 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
310 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
311 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
312 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
313 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
314 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
315 { DO, TOKENTYPE_NONE, "DO" },
316 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
317 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
318 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
319 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
320 { ELSE, TOKENTYPE_NONE, "ELSE" },
321 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
322 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
323 { FOR, TOKENTYPE_IVAL, "FOR" },
324 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
325 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
326 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
327 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
328 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
329 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
330 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
331 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
332 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
333 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
334 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
335 { IF, TOKENTYPE_IVAL, "IF" },
336 { LABEL, TOKENTYPE_PVAL, "LABEL" },
337 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
338 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
339 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
340 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
341 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
342 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
343 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
344 { MY, TOKENTYPE_IVAL, "MY" },
345 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
346 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
347 { OROP, TOKENTYPE_IVAL, "OROP" },
348 { OROR, TOKENTYPE_NONE, "OROR" },
349 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
350 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
351 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
352 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
353 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
354 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
355 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
356 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
357 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
358 { PREINC, TOKENTYPE_NONE, "PREINC" },
359 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
360 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
361 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
362 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
363 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
364 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
365 { SUB, TOKENTYPE_NONE, "SUB" },
366 { THING, TOKENTYPE_OPVAL, "THING" },
367 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
368 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
369 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
370 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
371 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
372 { USE, TOKENTYPE_IVAL, "USE" },
373 { WHEN, TOKENTYPE_IVAL, "WHEN" },
374 { WHILE, TOKENTYPE_IVAL, "WHILE" },
375 { WORD, TOKENTYPE_OPVAL, "WORD" },
376 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
377 { 0, TOKENTYPE_NONE, NULL }
380 /* dump the returned token in rv, plus any optional arg in pl_yylval */
383 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
385 PERL_ARGS_ASSERT_TOKEREPORT;
388 const char *name = NULL;
389 enum token_type type = TOKENTYPE_NONE;
390 const struct debug_tokens *p;
391 SV* const report = newSVpvs("<== ");
393 for (p = debug_tokens; p->token; p++) {
394 if (p->token == (int)rv) {
401 Perl_sv_catpv(aTHX_ report, name);
402 else if (isGRAPH(rv))
404 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
406 sv_catpvs(report, " (pending identifier)");
409 sv_catpvs(report, "EOF");
411 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
416 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
418 case TOKENTYPE_OPNUM:
419 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
420 PL_op_name[lvalp->ival]);
423 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
425 case TOKENTYPE_OPVAL:
427 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
428 PL_op_name[lvalp->opval->op_type]);
429 if (lvalp->opval->op_type == OP_CONST) {
430 Perl_sv_catpvf(aTHX_ report, " %s",
431 SvPEEK(cSVOPx_sv(lvalp->opval)));
436 sv_catpvs(report, "(opval=null)");
439 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
445 /* print the buffer with suitable escapes */
448 S_printbuf(pTHX_ const char *const fmt, const char *const s)
450 SV* const tmp = newSVpvs("");
452 PERL_ARGS_ASSERT_PRINTBUF;
454 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
455 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
463 S_deprecate_commaless_var_list(pTHX) {
465 deprecate("comma-less variable list");
466 return REPORT(','); /* grandfather non-comma-format format */
472 * This subroutine looks for an '=' next to the operator that has just been
473 * parsed and turns it into an ASSIGNOP if it finds one.
477 S_ao(pTHX_ int toketype)
479 if (*PL_bufptr == '=') {
481 if (toketype == ANDAND)
482 pl_yylval.ival = OP_ANDASSIGN;
483 else if (toketype == OROR)
484 pl_yylval.ival = OP_ORASSIGN;
485 else if (toketype == DORDOR)
486 pl_yylval.ival = OP_DORASSIGN;
489 return REPORT(toketype);
494 * When Perl expects an operator and finds something else, no_op
495 * prints the warning. It always prints "<something> found where
496 * operator expected. It prints "Missing semicolon on previous line?"
497 * if the surprise occurs at the start of the line. "do you need to
498 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
499 * where the compiler doesn't know if foo is a method call or a function.
500 * It prints "Missing operator before end of line" if there's nothing
501 * after the missing operator, or "... before <...>" if there is something
502 * after the missing operator.
506 S_no_op(pTHX_ const char *const what, char *s)
508 char * const oldbp = PL_bufptr;
509 const bool is_first = (PL_oldbufptr == PL_linestart);
511 PERL_ARGS_ASSERT_NO_OP;
517 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
518 if (ckWARN_d(WARN_SYNTAX)) {
520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
521 "\t(Missing semicolon on previous line?)\n");
522 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
524 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
525 t += UTF ? UTF8SKIP(t) : 1)
527 if (t < PL_bufptr && isSPACE(*t))
528 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
529 "\t(Do you need to predeclare %"UTF8f"?)\n",
530 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Missing operator before %"UTF8f"?)\n",
536 UTF8fARG(UTF, s - oldbp, oldbp));
544 * Complain about missing quote/regexp/heredoc terminator.
545 * If it's called with NULL then it cauterizes the line buffer.
546 * If we're in a delimited string and the delimiter is a control
547 * character, it's reformatted into a two-char sequence like ^C.
552 S_missingterm(pTHX_ char *s)
557 char * const nl = strrchr(s,'\n');
561 else if ((U8) PL_multi_close < 32) {
563 tmpbuf[1] = (char)toCTRL(PL_multi_close);
568 *tmpbuf = (char)PL_multi_close;
572 q = strchr(s,'"') ? '\'' : '"';
573 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
579 * Check whether the named feature is enabled.
582 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
584 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
586 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
588 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
590 if (namelen > MAX_FEATURE_LEN)
592 memcpy(&he_name[8], name, namelen);
594 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
595 REFCOUNTED_HE_EXISTS));
599 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
600 * utf16-to-utf8-reversed.
603 #ifdef PERL_CR_FILTER
607 const char *s = SvPVX_const(sv);
608 const char * const e = s + SvCUR(sv);
610 PERL_ARGS_ASSERT_STRIP_RETURN;
612 /* outer loop optimized to do nothing if there are no CR-LFs */
614 if (*s++ == '\r' && *s == '\n') {
615 /* hit a CR-LF, need to copy the rest */
619 if (*s == '\r' && s[1] == '\n')
630 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
632 const I32 count = FILTER_READ(idx+1, sv, maxlen);
633 if (count > 0 && !maxlen)
640 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
642 Creates and initialises a new lexer/parser state object, supplying
643 a context in which to lex and parse from a new source of Perl code.
644 A pointer to the new state object is placed in L</PL_parser>. An entry
645 is made on the save stack so that upon unwinding the new state object
646 will be destroyed and the former value of L</PL_parser> will be restored.
647 Nothing else need be done to clean up the parsing context.
649 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
650 non-null, provides a string (in SV form) containing code to be parsed.
651 A copy of the string is made, so subsequent modification of I<line>
652 does not affect parsing. I<rsfp>, if non-null, provides an input stream
653 from which code will be read to be parsed. If both are non-null, the
654 code in I<line> comes first and must consist of complete lines of input,
655 and I<rsfp> supplies the remainder of the source.
657 The I<flags> parameter is reserved for future use. Currently it is only
658 used by perl internally, so extensions should always pass zero.
663 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
664 can share filters with the current parser.
665 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
666 caller, hence isn't owned by the parser, so shouldn't be closed on parser
667 destruction. This is used to handle the case of defaulting to reading the
668 script from the standard input because no filename was given on the command
669 line (without getting confused by situation where STDIN has been closed, so
670 the script handle is opened on fd 0) */
673 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
675 const char *s = NULL;
676 yy_parser *parser, *oparser;
677 if (flags && flags & ~LEX_START_FLAGS)
678 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
680 /* create and initialise a parser */
682 Newxz(parser, 1, yy_parser);
683 parser->old_parser = oparser = PL_parser;
686 parser->stack = NULL;
688 parser->stack_size = 0;
690 /* on scope exit, free this parser and restore any outer one */
692 parser->saved_curcop = PL_curcop;
694 /* initialise lexer state */
696 parser->nexttoke = 0;
697 parser->error_count = oparser ? oparser->error_count : 0;
698 parser->copline = parser->preambling = NOLINE;
699 parser->lex_state = LEX_NORMAL;
700 parser->expect = XSTATE;
702 parser->rsfp_filters =
703 !(flags & LEX_START_SAME_FILTER) || !oparser
705 : MUTABLE_AV(SvREFCNT_inc(
706 oparser->rsfp_filters
707 ? oparser->rsfp_filters
708 : (oparser->rsfp_filters = newAV())
711 Newx(parser->lex_brackstack, 120, char);
712 Newx(parser->lex_casestack, 12, char);
713 *parser->lex_casestack = '\0';
714 Newxz(parser->lex_shared, 1, LEXSHARED);
718 s = SvPV_const(line, len);
719 parser->linestr = flags & LEX_START_COPIED
720 ? SvREFCNT_inc_simple_NN(line)
721 : newSVpvn_flags(s, len, SvUTF8(line));
722 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
724 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
726 parser->oldoldbufptr =
729 parser->linestart = SvPVX(parser->linestr);
730 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
731 parser->last_lop = parser->last_uni = NULL;
733 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
734 |LEX_DONT_CLOSE_RSFP));
735 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
736 |LEX_DONT_CLOSE_RSFP));
738 parser->in_pod = parser->filtered = 0;
742 /* delete a parser object */
745 Perl_parser_free(pTHX_ const yy_parser *parser)
747 PERL_ARGS_ASSERT_PARSER_FREE;
749 PL_curcop = parser->saved_curcop;
750 SvREFCNT_dec(parser->linestr);
752 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
753 PerlIO_clearerr(parser->rsfp);
754 else if (parser->rsfp && (!parser->old_parser ||
755 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
756 PerlIO_close(parser->rsfp);
757 SvREFCNT_dec(parser->rsfp_filters);
758 SvREFCNT_dec(parser->lex_stuff);
759 SvREFCNT_dec(parser->sublex_info.repl);
761 Safefree(parser->lex_brackstack);
762 Safefree(parser->lex_casestack);
763 Safefree(parser->lex_shared);
764 PL_parser = parser->old_parser;
769 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
771 I32 nexttoke = parser->nexttoke;
772 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
774 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
775 && parser->nextval[nexttoke].opval
776 && parser->nextval[nexttoke].opval->op_slabbed
777 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
778 op_free(parser->nextval[nexttoke].opval);
779 parser->nextval[nexttoke].opval = NULL;
786 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
788 Buffer scalar containing the chunk currently under consideration of the
789 text currently being lexed. This is always a plain string scalar (for
790 which C<SvPOK> is true). It is not intended to be used as a scalar by
791 normal scalar means; instead refer to the buffer directly by the pointer
792 variables described below.
794 The lexer maintains various C<char*> pointers to things in the
795 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
796 reallocated, all of these pointers must be updated. Don't attempt to
797 do this manually, but rather use L</lex_grow_linestr> if you need to
798 reallocate the buffer.
800 The content of the text chunk in the buffer is commonly exactly one
801 complete line of input, up to and including a newline terminator,
802 but there are situations where it is otherwise. The octets of the
803 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
804 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
805 flag on this scalar, which may disagree with it.
807 For direct examination of the buffer, the variable
808 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
809 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
810 of these pointers is usually preferable to examination of the scalar
811 through normal scalar means.
813 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
815 Direct pointer to the end of the chunk of text currently being lexed, the
816 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
817 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
818 always located at the end of the buffer, and does not count as part of
819 the buffer's contents.
821 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
823 Points to the current position of lexing inside the lexer buffer.
824 Characters around this point may be freely examined, within
825 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
826 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
827 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
829 Lexing code (whether in the Perl core or not) moves this pointer past
830 the characters that it consumes. It is also expected to perform some
831 bookkeeping whenever a newline character is consumed. This movement
832 can be more conveniently performed by the function L</lex_read_to>,
833 which handles newlines appropriately.
835 Interpretation of the buffer's octets can be abstracted out by
836 using the slightly higher-level functions L</lex_peek_unichar> and
837 L</lex_read_unichar>.
839 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
841 Points to the start of the current line inside the lexer buffer.
842 This is useful for indicating at which column an error occurred, and
843 not much else. This must be updated by any lexing code that consumes
844 a newline; the function L</lex_read_to> handles this detail.
850 =for apidoc Amx|bool|lex_bufutf8
852 Indicates whether the octets in the lexer buffer
853 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
854 of Unicode characters. If not, they should be interpreted as Latin-1
855 characters. This is analogous to the C<SvUTF8> flag for scalars.
857 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
858 contains valid UTF-8. Lexing code must be robust in the face of invalid
861 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
862 is significant, but not the whole story regarding the input character
863 encoding. Normally, when a file is being read, the scalar contains octets
864 and its C<SvUTF8> flag is off, but the octets should be interpreted as
865 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
866 however, the scalar may have the C<SvUTF8> flag on, and in this case its
867 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
868 is in effect. This logic may change in the future; use this function
869 instead of implementing the logic yourself.
875 Perl_lex_bufutf8(pTHX)
881 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
883 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
884 at least I<len> octets (including terminating C<NUL>). Returns a
885 pointer to the reallocated buffer. This is necessary before making
886 any direct modification of the buffer that would increase its length.
887 L</lex_stuff_pvn> provides a more convenient way to insert text into
890 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
891 this function updates all of the lexer's variables that point directly
898 Perl_lex_grow_linestr(pTHX_ STRLEN len)
902 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
903 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
904 linestr = PL_parser->linestr;
905 buf = SvPVX(linestr);
906 if (len <= SvLEN(linestr))
908 bufend_pos = PL_parser->bufend - buf;
909 bufptr_pos = PL_parser->bufptr - buf;
910 oldbufptr_pos = PL_parser->oldbufptr - buf;
911 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
912 linestart_pos = PL_parser->linestart - buf;
913 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
914 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
915 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
916 PL_parser->lex_shared->re_eval_start - buf : 0;
918 buf = sv_grow(linestr, len);
920 PL_parser->bufend = buf + bufend_pos;
921 PL_parser->bufptr = buf + bufptr_pos;
922 PL_parser->oldbufptr = buf + oldbufptr_pos;
923 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
924 PL_parser->linestart = buf + linestart_pos;
925 if (PL_parser->last_uni)
926 PL_parser->last_uni = buf + last_uni_pos;
927 if (PL_parser->last_lop)
928 PL_parser->last_lop = buf + last_lop_pos;
929 if (PL_parser->lex_shared->re_eval_start)
930 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
935 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
937 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
938 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
939 reallocating the buffer if necessary. This means that lexing code that
940 runs later will see the characters as if they had appeared in the input.
941 It is not recommended to do this as part of normal parsing, and most
942 uses of this facility run the risk of the inserted characters being
943 interpreted in an unintended manner.
945 The string to be inserted is represented by I<len> octets starting
946 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
947 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
948 The characters are recoded for the lexer buffer, according to how the
949 buffer is currently being interpreted (L</lex_bufutf8>). If a string
950 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
951 function is more convenient.
957 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
961 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
962 if (flags & ~(LEX_STUFF_UTF8))
963 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
965 if (flags & LEX_STUFF_UTF8) {
968 STRLEN highhalf = 0; /* Count of variants */
969 const char *p, *e = pv+len;
970 for (p = pv; p != e; p++) {
971 if (! UTF8_IS_INVARIANT(*p)) {
977 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
978 bufptr = PL_parser->bufptr;
979 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
980 SvCUR_set(PL_parser->linestr,
981 SvCUR(PL_parser->linestr) + len+highhalf);
982 PL_parser->bufend += len+highhalf;
983 for (p = pv; p != e; p++) {
985 if (! UTF8_IS_INVARIANT(c)) {
986 *bufptr++ = UTF8_TWO_BYTE_HI(c);
987 *bufptr++ = UTF8_TWO_BYTE_LO(c);
994 if (flags & LEX_STUFF_UTF8) {
996 const char *p, *e = pv+len;
997 for (p = pv; p != e; p++) {
999 if (UTF8_IS_ABOVE_LATIN1(c)) {
1000 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1001 "non-Latin-1 character into Latin-1 input");
1002 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1005 } else if (! UTF8_IS_INVARIANT(c)) {
1006 /* malformed UTF-8 */
1008 SAVESPTR(PL_warnhook);
1009 PL_warnhook = PERL_WARNHOOK_FATAL;
1010 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1016 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1017 bufptr = PL_parser->bufptr;
1018 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1019 SvCUR_set(PL_parser->linestr,
1020 SvCUR(PL_parser->linestr) + len-highhalf);
1021 PL_parser->bufend += len-highhalf;
1024 if (UTF8_IS_INVARIANT(*p)) {
1030 *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1036 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1037 bufptr = PL_parser->bufptr;
1038 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1039 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1040 PL_parser->bufend += len;
1041 Copy(pv, bufptr, len, char);
1047 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1049 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1050 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1051 reallocating the buffer if necessary. This means that lexing code that
1052 runs later will see the characters as if they had appeared in the input.
1053 It is not recommended to do this as part of normal parsing, and most
1054 uses of this facility run the risk of the inserted characters being
1055 interpreted in an unintended manner.
1057 The string to be inserted is represented by octets starting at I<pv>
1058 and continuing to the first nul. These octets are interpreted as either
1059 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1060 in I<flags>. The characters are recoded for the lexer buffer, according
1061 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1062 If it is not convenient to nul-terminate a string to be inserted, the
1063 L</lex_stuff_pvn> function is more appropriate.
1069 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1071 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1072 lex_stuff_pvn(pv, strlen(pv), flags);
1076 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1078 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1079 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1080 reallocating the buffer if necessary. This means that lexing code that
1081 runs later will see the characters as if they had appeared in the input.
1082 It is not recommended to do this as part of normal parsing, and most
1083 uses of this facility run the risk of the inserted characters being
1084 interpreted in an unintended manner.
1086 The string to be inserted is the string value of I<sv>. The characters
1087 are recoded for the lexer buffer, according to how the buffer is currently
1088 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1089 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1090 need to construct a scalar.
1096 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1100 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1102 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1104 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1108 =for apidoc Amx|void|lex_unstuff|char *ptr
1110 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1111 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1112 This hides the discarded text from any lexing code that runs later,
1113 as if the text had never appeared.
1115 This is not the normal way to consume lexed text. For that, use
1122 Perl_lex_unstuff(pTHX_ char *ptr)
1126 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1127 buf = PL_parser->bufptr;
1129 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1132 bufend = PL_parser->bufend;
1134 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1135 unstuff_len = ptr - buf;
1136 Move(ptr, buf, bufend+1-ptr, char);
1137 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1138 PL_parser->bufend = bufend - unstuff_len;
1142 =for apidoc Amx|void|lex_read_to|char *ptr
1144 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1145 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1146 performing the correct bookkeeping whenever a newline character is passed.
1147 This is the normal way to consume lexed text.
1149 Interpretation of the buffer's octets can be abstracted out by
1150 using the slightly higher-level functions L</lex_peek_unichar> and
1151 L</lex_read_unichar>.
1157 Perl_lex_read_to(pTHX_ char *ptr)
1160 PERL_ARGS_ASSERT_LEX_READ_TO;
1161 s = PL_parser->bufptr;
1162 if (ptr < s || ptr > PL_parser->bufend)
1163 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1164 for (; s != ptr; s++)
1166 COPLINE_INC_WITH_HERELINES;
1167 PL_parser->linestart = s+1;
1169 PL_parser->bufptr = ptr;
1173 =for apidoc Amx|void|lex_discard_to|char *ptr
1175 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1176 up to I<ptr>. The remaining content of the buffer will be moved, and
1177 all pointers into the buffer updated appropriately. I<ptr> must not
1178 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1179 it is not permitted to discard text that has yet to be lexed.
1181 Normally it is not necessarily to do this directly, because it suffices to
1182 use the implicit discarding behaviour of L</lex_next_chunk> and things
1183 based on it. However, if a token stretches across multiple lines,
1184 and the lexing code has kept multiple lines of text in the buffer for
1185 that purpose, then after completion of the token it would be wise to
1186 explicitly discard the now-unneeded earlier lines, to avoid future
1187 multi-line tokens growing the buffer without bound.
1193 Perl_lex_discard_to(pTHX_ char *ptr)
1197 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1198 buf = SvPVX(PL_parser->linestr);
1200 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1203 if (ptr > PL_parser->bufptr)
1204 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1205 discard_len = ptr - buf;
1206 if (PL_parser->oldbufptr < ptr)
1207 PL_parser->oldbufptr = ptr;
1208 if (PL_parser->oldoldbufptr < ptr)
1209 PL_parser->oldoldbufptr = ptr;
1210 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1211 PL_parser->last_uni = NULL;
1212 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1213 PL_parser->last_lop = NULL;
1214 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1215 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1216 PL_parser->bufend -= discard_len;
1217 PL_parser->bufptr -= discard_len;
1218 PL_parser->oldbufptr -= discard_len;
1219 PL_parser->oldoldbufptr -= discard_len;
1220 if (PL_parser->last_uni)
1221 PL_parser->last_uni -= discard_len;
1222 if (PL_parser->last_lop)
1223 PL_parser->last_lop -= discard_len;
1227 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1229 Reads in the next chunk of text to be lexed, appending it to
1230 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1231 looked to the end of the current chunk and wants to know more. It is
1232 usual, but not necessary, for lexing to have consumed the entirety of
1233 the current chunk at this time.
1235 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1236 chunk (i.e., the current chunk has been entirely consumed), normally the
1237 current chunk will be discarded at the same time that the new chunk is
1238 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1239 will not be discarded. If the current chunk has not been entirely
1240 consumed, then it will not be discarded regardless of the flag.
1242 Returns true if some new text was added to the buffer, or false if the
1243 buffer has reached the end of the input text.
1248 #define LEX_FAKE_EOF 0x80000000
1249 #define LEX_NO_TERM 0x40000000
1252 Perl_lex_next_chunk(pTHX_ U32 flags)
1256 STRLEN old_bufend_pos, new_bufend_pos;
1257 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1258 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1259 bool got_some_for_debugger = 0;
1261 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1262 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1263 linestr = PL_parser->linestr;
1264 buf = SvPVX(linestr);
1265 if (!(flags & LEX_KEEP_PREVIOUS) &&
1266 PL_parser->bufptr == PL_parser->bufend) {
1267 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1269 if (PL_parser->last_uni != PL_parser->bufend)
1270 PL_parser->last_uni = NULL;
1271 if (PL_parser->last_lop != PL_parser->bufend)
1272 PL_parser->last_lop = NULL;
1273 last_uni_pos = last_lop_pos = 0;
1277 old_bufend_pos = PL_parser->bufend - buf;
1278 bufptr_pos = PL_parser->bufptr - buf;
1279 oldbufptr_pos = PL_parser->oldbufptr - buf;
1280 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1281 linestart_pos = PL_parser->linestart - buf;
1282 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1283 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1285 if (flags & LEX_FAKE_EOF) {
1287 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1289 } else if (filter_gets(linestr, old_bufend_pos)) {
1291 got_some_for_debugger = 1;
1292 } else if (flags & LEX_NO_TERM) {
1295 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1296 sv_setpvs(linestr, "");
1298 /* End of real input. Close filehandle (unless it was STDIN),
1299 * then add implicit termination.
1301 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1302 PerlIO_clearerr(PL_parser->rsfp);
1303 else if (PL_parser->rsfp)
1304 (void)PerlIO_close(PL_parser->rsfp);
1305 PL_parser->rsfp = NULL;
1306 PL_parser->in_pod = PL_parser->filtered = 0;
1307 if (!PL_in_eval && PL_minus_p) {
1309 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1310 PL_minus_n = PL_minus_p = 0;
1311 } else if (!PL_in_eval && PL_minus_n) {
1312 sv_catpvs(linestr, /*{*/";}");
1315 sv_catpvs(linestr, ";");
1318 buf = SvPVX(linestr);
1319 new_bufend_pos = SvCUR(linestr);
1320 PL_parser->bufend = buf + new_bufend_pos;
1321 PL_parser->bufptr = buf + bufptr_pos;
1322 PL_parser->oldbufptr = buf + oldbufptr_pos;
1323 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1324 PL_parser->linestart = buf + linestart_pos;
1325 if (PL_parser->last_uni)
1326 PL_parser->last_uni = buf + last_uni_pos;
1327 if (PL_parser->last_lop)
1328 PL_parser->last_lop = buf + last_lop_pos;
1329 if (PL_parser->preambling != NOLINE) {
1330 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1331 PL_parser->preambling = NOLINE;
1333 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1334 PL_curstash != PL_debstash) {
1335 /* debugger active and we're not compiling the debugger code,
1336 * so store the line into the debugger's array of lines
1338 update_debugger_info(NULL, buf+old_bufend_pos,
1339 new_bufend_pos-old_bufend_pos);
1345 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1347 Looks ahead one (Unicode) character in the text currently being lexed.
1348 Returns the codepoint (unsigned integer value) of the next character,
1349 or -1 if lexing has reached the end of the input text. To consume the
1350 peeked character, use L</lex_read_unichar>.
1352 If the next character is in (or extends into) the next chunk of input
1353 text, the next chunk will be read in. Normally the current chunk will be
1354 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1355 then the current chunk will not be discarded.
1357 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1358 is encountered, an exception is generated.
1364 Perl_lex_peek_unichar(pTHX_ U32 flags)
1368 if (flags & ~(LEX_KEEP_PREVIOUS))
1369 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1370 s = PL_parser->bufptr;
1371 bufend = PL_parser->bufend;
1377 if (!lex_next_chunk(flags))
1379 s = PL_parser->bufptr;
1380 bufend = PL_parser->bufend;
1383 if (UTF8_IS_INVARIANT(head))
1385 if (UTF8_IS_START(head)) {
1386 len = UTF8SKIP(&head);
1387 while ((STRLEN)(bufend-s) < len) {
1388 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1390 s = PL_parser->bufptr;
1391 bufend = PL_parser->bufend;
1394 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1395 if (retlen == (STRLEN)-1) {
1396 /* malformed UTF-8 */
1398 SAVESPTR(PL_warnhook);
1399 PL_warnhook = PERL_WARNHOOK_FATAL;
1400 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1406 if (!lex_next_chunk(flags))
1408 s = PL_parser->bufptr;
1415 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1417 Reads the next (Unicode) character in the text currently being lexed.
1418 Returns the codepoint (unsigned integer value) of the character read,
1419 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1420 if lexing has reached the end of the input text. To non-destructively
1421 examine the next character, use L</lex_peek_unichar> instead.
1423 If the next character is in (or extends into) the next chunk of input
1424 text, the next chunk will be read in. Normally the current chunk will be
1425 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1426 then the current chunk will not be discarded.
1428 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1429 is encountered, an exception is generated.
1435 Perl_lex_read_unichar(pTHX_ U32 flags)
1438 if (flags & ~(LEX_KEEP_PREVIOUS))
1439 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1440 c = lex_peek_unichar(flags);
1443 COPLINE_INC_WITH_HERELINES;
1445 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1447 ++(PL_parser->bufptr);
1453 =for apidoc Amx|void|lex_read_space|U32 flags
1455 Reads optional spaces, in Perl style, in the text currently being
1456 lexed. The spaces may include ordinary whitespace characters and
1457 Perl-style comments. C<#line> directives are processed if encountered.
1458 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1459 at a non-space character (or the end of the input text).
1461 If spaces extend into the next chunk of input text, the next chunk will
1462 be read in. Normally the current chunk will be discarded at the same
1463 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1464 chunk will not be discarded.
1469 #define LEX_NO_INCLINE 0x40000000
1470 #define LEX_NO_NEXT_CHUNK 0x80000000
1473 Perl_lex_read_space(pTHX_ U32 flags)
1476 const bool can_incline = !(flags & LEX_NO_INCLINE);
1477 bool need_incline = 0;
1478 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1479 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1480 s = PL_parser->bufptr;
1481 bufend = PL_parser->bufend;
1487 } while (!(c == '\n' || (c == 0 && s == bufend)));
1488 } else if (c == '\n') {
1491 PL_parser->linestart = s;
1497 } else if (isSPACE(c)) {
1499 } else if (c == 0 && s == bufend) {
1502 if (flags & LEX_NO_NEXT_CHUNK)
1504 PL_parser->bufptr = s;
1505 l = CopLINE(PL_curcop);
1506 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1507 got_more = lex_next_chunk(flags);
1508 CopLINE_set(PL_curcop, l);
1509 s = PL_parser->bufptr;
1510 bufend = PL_parser->bufend;
1513 if (can_incline && need_incline && PL_parser->rsfp) {
1521 PL_parser->bufptr = s;
1526 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1528 This function performs syntax checking on a prototype, C<proto>.
1529 If C<warn> is true, any illegal characters or mismatched brackets
1530 will trigger illegalproto warnings, declaring that they were
1531 detected in the prototype for C<name>.
1533 The return value is C<true> if this is a valid prototype, and
1534 C<false> if it is not, regardless of whether C<warn> was C<true> or
1537 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1544 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1546 STRLEN len, origlen;
1547 char *p = proto ? SvPV(proto, len) : NULL;
1548 bool bad_proto = FALSE;
1549 bool in_brackets = FALSE;
1550 bool after_slash = FALSE;
1551 char greedy_proto = ' ';
1552 bool proto_after_greedy_proto = FALSE;
1553 bool must_be_last = FALSE;
1554 bool underscore = FALSE;
1555 bool bad_proto_after_underscore = FALSE;
1557 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1563 for (; len--; p++) {
1566 proto_after_greedy_proto = TRUE;
1568 if (!strchr(";@%", *p))
1569 bad_proto_after_underscore = TRUE;
1572 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1579 in_brackets = FALSE;
1580 else if ((*p == '@' || *p == '%') &&
1583 must_be_last = TRUE;
1592 after_slash = FALSE;
1597 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1600 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1601 origlen, UNI_DISPLAY_ISPRINT)
1602 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1604 if (proto_after_greedy_proto)
1605 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1606 "Prototype after '%c' for %"SVf" : %s",
1607 greedy_proto, SVfARG(name), p);
1609 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1610 "Missing ']' in prototype for %"SVf" : %s",
1613 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1614 "Illegal character in prototype for %"SVf" : %s",
1616 if (bad_proto_after_underscore)
1617 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1618 "Illegal character after '_' in prototype for %"SVf" : %s",
1622 return (! (proto_after_greedy_proto || bad_proto) );
1627 * This subroutine has nothing to do with tilting, whether at windmills
1628 * or pinball tables. Its name is short for "increment line". It
1629 * increments the current line number in CopLINE(PL_curcop) and checks
1630 * to see whether the line starts with a comment of the form
1631 * # line 500 "foo.pm"
1632 * If so, it sets the current line number and file to the values in the comment.
1636 S_incline(pTHX_ const char *s)
1643 PERL_ARGS_ASSERT_INCLINE;
1645 COPLINE_INC_WITH_HERELINES;
1646 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1647 && s+1 == PL_bufend && *s == ';') {
1648 /* fake newline in string eval */
1649 CopLINE_dec(PL_curcop);
1654 while (SPACE_OR_TAB(*s))
1656 if (strnEQ(s, "line", 4))
1660 if (SPACE_OR_TAB(*s))
1664 while (SPACE_OR_TAB(*s))
1672 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1674 while (SPACE_OR_TAB(*s))
1676 if (*s == '"' && (t = strchr(s+1, '"'))) {
1682 while (!isSPACE(*t))
1686 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1688 if (*e != '\n' && *e != '\0')
1689 return; /* false alarm */
1691 line_num = grok_atou(n, &e) - 1;
1694 const STRLEN len = t - s;
1696 if (!PL_rsfp && !PL_parser->filtered) {
1697 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1698 * to *{"::_<newfilename"} */
1699 /* However, the long form of evals is only turned on by the
1700 debugger - usually they're "(eval %lu)" */
1701 GV * const cfgv = CopFILEGV(PL_curcop);
1704 STRLEN tmplen2 = len;
1708 if (tmplen2 + 2 <= sizeof smallbuf)
1711 Newx(tmpbuf2, tmplen2 + 2, char);
1716 memcpy(tmpbuf2 + 2, s, tmplen2);
1719 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1721 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1722 /* adjust ${"::_<newfilename"} to store the new file name */
1723 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1724 /* The line number may differ. If that is the case,
1725 alias the saved lines that are in the array.
1726 Otherwise alias the whole array. */
1727 if (CopLINE(PL_curcop) == line_num) {
1728 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1729 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1731 else if (GvAV(cfgv)) {
1732 AV * const av = GvAV(cfgv);
1733 const I32 start = CopLINE(PL_curcop)+1;
1734 I32 items = AvFILLp(av) - start;
1736 AV * const av2 = GvAVn(gv2);
1737 SV **svp = AvARRAY(av) + start;
1738 I32 l = (I32)line_num+1;
1740 av_store(av2, l++, SvREFCNT_inc(*svp++));
1745 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1748 CopFILE_free(PL_curcop);
1749 CopFILE_setn(PL_curcop, s, len);
1751 CopLINE_set(PL_curcop, line_num);
1754 #define skipspace(s) skipspace_flags(s, 0)
1758 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1760 AV *av = CopFILEAVx(PL_curcop);
1763 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1765 sv = *av_fetch(av, 0, 1);
1766 SvUPGRADE(sv, SVt_PVMG);
1768 if (!SvPOK(sv)) sv_setpvs(sv,"");
1770 sv_catsv(sv, orig_sv);
1772 sv_catpvn(sv, buf, len);
1777 if (PL_parser->preambling == NOLINE)
1778 av_store(av, CopLINE(PL_curcop), sv);
1784 * Called to gobble the appropriate amount and type of whitespace.
1785 * Skips comments as well.
1789 S_skipspace_flags(pTHX_ char *s, U32 flags)
1791 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1792 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1793 while (s < PL_bufend && SPACE_OR_TAB(*s))
1796 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1798 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1799 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1800 LEX_NO_NEXT_CHUNK : 0));
1802 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1803 if (PL_linestart > PL_bufptr)
1804 PL_bufptr = PL_linestart;
1812 * Check the unary operators to ensure there's no ambiguity in how they're
1813 * used. An ambiguous piece of code would be:
1815 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1816 * the +5 is its argument.
1825 if (PL_oldoldbufptr != PL_last_uni)
1827 while (isSPACE(*PL_last_uni))
1830 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1832 if ((t = strchr(s, '(')) && t < PL_bufptr)
1835 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1836 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1837 (int)(s - PL_last_uni), PL_last_uni);
1841 * LOP : macro to build a list operator. Its behaviour has been replaced
1842 * with a subroutine, S_lop() for which LOP is just another name.
1845 #define LOP(f,x) return lop(f,x,s)
1849 * Build a list operator (or something that might be one). The rules:
1850 * - if we have a next token, then it's a list operator (no parens) for
1851 * which the next token has already been parsed; e.g.,
1854 * - if the next thing is an opening paren, then it's a function
1855 * - else it's a list operator
1859 S_lop(pTHX_ I32 f, int x, char *s)
1861 PERL_ARGS_ASSERT_LOP;
1866 PL_last_lop = PL_oldbufptr;
1867 PL_last_lop_op = (OPCODE)f;
1872 return REPORT(FUNC);
1875 return REPORT(FUNC);
1878 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1879 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1880 return REPORT(LSTOP);
1886 * When the lexer realizes it knows the next token (for instance,
1887 * it is reordering tokens for the parser) then it can call S_force_next
1888 * to know what token to return the next time the lexer is called. Caller
1889 * will need to set PL_nextval[] and possibly PL_expect to ensure
1890 * the lexer handles the token correctly.
1894 S_force_next(pTHX_ I32 type)
1898 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1899 tokereport(type, &NEXTVAL_NEXTTOKE);
1902 PL_nexttype[PL_nexttoke] = type;
1904 if (PL_lex_state != LEX_KNOWNEXT) {
1905 PL_lex_defer = PL_lex_state;
1906 PL_lex_state = LEX_KNOWNEXT;
1913 * This subroutine handles postfix deref syntax after the arrow has already
1914 * been emitted. @* $* etc. are emitted as two separate token right here.
1915 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1916 * only the first, leaving yylex to find the next.
1920 S_postderef(pTHX_ int const funny, char const next)
1922 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1923 assert(strchr("*[{", next));
1925 PL_expect = XOPERATOR;
1926 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1927 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1928 PL_lex_state = LEX_INTERPEND;
1929 force_next(POSTJOIN);
1935 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1936 && !PL_lex_brackets)
1938 PL_expect = XOPERATOR;
1947 int yyc = PL_parser->yychar;
1948 if (yyc != YYEMPTY) {
1950 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1951 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1952 PL_lex_allbrackets--;
1954 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1955 } else if (yyc == '('/*)*/) {
1956 PL_lex_allbrackets--;
1961 PL_parser->yychar = YYEMPTY;
1966 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1968 SV * const sv = newSVpvn_utf8(start, len,
1971 && !is_invariant_string((const U8*)start, len)
1972 && is_utf8_string((const U8*)start, len));
1978 * When the lexer knows the next thing is a word (for instance, it has
1979 * just seen -> and it knows that the next char is a word char, then
1980 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1984 * char *start : buffer position (must be within PL_linestr)
1985 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1986 * int check_keyword : if true, Perl checks to make sure the word isn't
1987 * a keyword (do this if the word is a label, e.g. goto FOO)
1988 * int allow_pack : if true, : characters will also be allowed (require,
1989 * use, etc. do this)
1993 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
1998 PERL_ARGS_ASSERT_FORCE_WORD;
2000 start = skipspace(start);
2002 if (isIDFIRST_lazy_if(s,UTF) ||
2003 (allow_pack && *s == ':') )
2005 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2006 if (check_keyword) {
2007 char *s2 = PL_tokenbuf;
2008 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2010 if (keyword(s2, len, 0))
2013 if (token == METHOD) {
2018 PL_expect = XOPERATOR;
2021 NEXTVAL_NEXTTOKE.opval
2022 = (OP*)newSVOP(OP_CONST,0,
2023 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2024 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2032 * Called when the lexer wants $foo *foo &foo etc, but the program
2033 * text only contains the "foo" portion. The first argument is a pointer
2034 * to the "foo", and the second argument is the type symbol to prefix.
2035 * Forces the next token to be a "WORD".
2036 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2040 S_force_ident(pTHX_ const char *s, int kind)
2042 PERL_ARGS_ASSERT_FORCE_IDENT;
2045 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2046 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2047 UTF ? SVf_UTF8 : 0));
2048 NEXTVAL_NEXTTOKE.opval = o;
2051 o->op_private = OPpCONST_ENTERED;
2052 /* XXX see note in pp_entereval() for why we forgo typo
2053 warnings if the symbol must be introduced in an eval.
2055 gv_fetchpvn_flags(s, len,
2056 (PL_in_eval ? GV_ADDMULTI
2057 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2058 kind == '$' ? SVt_PV :
2059 kind == '@' ? SVt_PVAV :
2060 kind == '%' ? SVt_PVHV :
2068 S_force_ident_maybe_lex(pTHX_ char pit)
2070 NEXTVAL_NEXTTOKE.ival = pit;
2075 Perl_str_to_version(pTHX_ SV *sv)
2080 const char *start = SvPV_const(sv,len);
2081 const char * const end = start + len;
2082 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2084 PERL_ARGS_ASSERT_STR_TO_VERSION;
2086 while (start < end) {
2090 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2095 retval += ((NV)n)/nshift;
2104 * Forces the next token to be a version number.
2105 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2106 * and if "guessing" is TRUE, then no new token is created (and the caller
2107 * must use an alternative parsing method).
2111 S_force_version(pTHX_ char *s, int guessing)
2116 PERL_ARGS_ASSERT_FORCE_VERSION;
2124 while (isDIGIT(*d) || *d == '_' || *d == '.')
2126 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2128 s = scan_num(s, &pl_yylval);
2129 version = pl_yylval.opval;
2130 ver = cSVOPx(version)->op_sv;
2131 if (SvPOK(ver) && !SvNIOK(ver)) {
2132 SvUPGRADE(ver, SVt_PVNV);
2133 SvNV_set(ver, str_to_version(ver));
2134 SvNOK_on(ver); /* hint that it is a version */
2137 else if (guessing) {
2142 /* NOTE: The parser sees the package name and the VERSION swapped */
2143 NEXTVAL_NEXTTOKE.opval = version;
2150 * S_force_strict_version
2151 * Forces the next token to be a version number using strict syntax rules.
2155 S_force_strict_version(pTHX_ char *s)
2158 const char *errstr = NULL;
2160 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2162 while (isSPACE(*s)) /* leading whitespace */
2165 if (is_STRICT_VERSION(s,&errstr)) {
2167 s = (char *)scan_version(s, ver, 0);
2168 version = newSVOP(OP_CONST, 0, ver);
2170 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2171 (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2175 yyerror(errstr); /* version required */
2179 /* NOTE: The parser sees the package name and the VERSION swapped */
2180 NEXTVAL_NEXTTOKE.opval = version;
2188 * Tokenize a quoted string passed in as an SV. It finds the next
2189 * chunk, up to end of string or a backslash. It may make a new
2190 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2195 S_tokeq(pTHX_ SV *sv)
2202 PERL_ARGS_ASSERT_TOKEQ;
2206 assert (!SvIsCOW(sv));
2207 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2211 /* This is relying on the SV being "well formed" with a trailing '\0' */
2212 while (s < send && !(*s == '\\' && s[1] == '\\'))
2217 if ( PL_hints & HINT_NEW_STRING ) {
2218 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2219 SVs_TEMP | SvUTF8(sv));
2223 if (s + 1 < send && (s[1] == '\\'))
2224 s++; /* all that, just for this */
2229 SvCUR_set(sv, d - SvPVX_const(sv));
2231 if ( PL_hints & HINT_NEW_STRING )
2232 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2237 * Now come three functions related to double-quote context,
2238 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2239 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2240 * interact with PL_lex_state, and create fake ( ... ) argument lists
2241 * to handle functions and concatenation.
2245 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2250 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2252 * Pattern matching will set PL_lex_op to the pattern-matching op to
2253 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2255 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2257 * Everything else becomes a FUNC.
2259 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2260 * had an OP_CONST or OP_READLINE). This just sets us up for a
2261 * call to S_sublex_push().
2265 S_sublex_start(pTHX)
2267 const I32 op_type = pl_yylval.ival;
2269 if (op_type == OP_NULL) {
2270 pl_yylval.opval = PL_lex_op;
2274 if (op_type == OP_CONST) {
2275 SV *sv = tokeq(PL_lex_stuff);
2277 if (SvTYPE(sv) == SVt_PVIV) {
2278 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2280 const char * const p = SvPV_const(sv, len);
2281 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2285 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2286 PL_lex_stuff = NULL;
2290 PL_sublex_info.super_state = PL_lex_state;
2291 PL_sublex_info.sub_inwhat = (U16)op_type;
2292 PL_sublex_info.sub_op = PL_lex_op;
2293 PL_lex_state = LEX_INTERPPUSH;
2297 pl_yylval.opval = PL_lex_op;
2307 * Create a new scope to save the lexing state. The scope will be
2308 * ended in S_sublex_done. Returns a '(', starting the function arguments
2309 * to the uc, lc, etc. found before.
2310 * Sets PL_lex_state to LEX_INTERPCONCAT.
2317 const bool is_heredoc = PL_multi_close == '<';
2320 PL_lex_state = PL_sublex_info.super_state;
2321 SAVEI8(PL_lex_dojoin);
2322 SAVEI32(PL_lex_brackets);
2323 SAVEI32(PL_lex_allbrackets);
2324 SAVEI32(PL_lex_formbrack);
2325 SAVEI8(PL_lex_fakeeof);
2326 SAVEI32(PL_lex_casemods);
2327 SAVEI32(PL_lex_starts);
2328 SAVEI8(PL_lex_state);
2329 SAVESPTR(PL_lex_repl);
2330 SAVEVPTR(PL_lex_inpat);
2331 SAVEI16(PL_lex_inwhat);
2334 SAVECOPLINE(PL_curcop);
2335 SAVEI32(PL_multi_end);
2336 SAVEI32(PL_parser->herelines);
2337 PL_parser->herelines = 0;
2339 SAVEI8(PL_multi_close);
2340 SAVEPPTR(PL_bufptr);
2341 SAVEPPTR(PL_bufend);
2342 SAVEPPTR(PL_oldbufptr);
2343 SAVEPPTR(PL_oldoldbufptr);
2344 SAVEPPTR(PL_last_lop);
2345 SAVEPPTR(PL_last_uni);
2346 SAVEPPTR(PL_linestart);
2347 SAVESPTR(PL_linestr);
2348 SAVEGENERICPV(PL_lex_brackstack);
2349 SAVEGENERICPV(PL_lex_casestack);
2350 SAVEGENERICPV(PL_parser->lex_shared);
2351 SAVEBOOL(PL_parser->lex_re_reparsing);
2352 SAVEI32(PL_copline);
2354 /* The here-doc parser needs to be able to peek into outer lexing
2355 scopes to find the body of the here-doc. So we put PL_linestr and
2356 PL_bufptr into lex_shared, to ‘share’ those values.
2358 PL_parser->lex_shared->ls_linestr = PL_linestr;
2359 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2361 PL_linestr = PL_lex_stuff;
2362 PL_lex_repl = PL_sublex_info.repl;
2363 PL_lex_stuff = NULL;
2364 PL_sublex_info.repl = NULL;
2366 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2367 = SvPVX(PL_linestr);
2368 PL_bufend += SvCUR(PL_linestr);
2369 PL_last_lop = PL_last_uni = NULL;
2370 SAVEFREESV(PL_linestr);
2371 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2373 PL_lex_dojoin = FALSE;
2374 PL_lex_brackets = PL_lex_formbrack = 0;
2375 PL_lex_allbrackets = 0;
2376 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2377 Newx(PL_lex_brackstack, 120, char);
2378 Newx(PL_lex_casestack, 12, char);
2379 PL_lex_casemods = 0;
2380 *PL_lex_casestack = '\0';
2382 PL_lex_state = LEX_INTERPCONCAT;
2384 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2385 PL_copline = NOLINE;
2387 Newxz(shared, 1, LEXSHARED);
2388 shared->ls_prev = PL_parser->lex_shared;
2389 PL_parser->lex_shared = shared;
2391 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2392 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2393 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2394 PL_lex_inpat = PL_sublex_info.sub_op;
2396 PL_lex_inpat = NULL;
2398 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2399 PL_in_eval &= ~EVAL_RE_REPARSING;
2406 * Restores lexer state after a S_sublex_push.
2412 if (!PL_lex_starts++) {
2413 SV * const sv = newSVpvs("");
2414 if (SvUTF8(PL_linestr))
2416 PL_expect = XOPERATOR;
2417 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2421 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2422 PL_lex_state = LEX_INTERPCASEMOD;
2426 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2427 assert(PL_lex_inwhat != OP_TRANSR);
2429 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2430 PL_linestr = PL_lex_repl;
2432 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2433 PL_bufend += SvCUR(PL_linestr);
2434 PL_last_lop = PL_last_uni = NULL;
2435 PL_lex_dojoin = FALSE;
2436 PL_lex_brackets = 0;
2437 PL_lex_allbrackets = 0;
2438 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2439 PL_lex_casemods = 0;
2440 *PL_lex_casestack = '\0';
2442 if (SvEVALED(PL_lex_repl)) {
2443 PL_lex_state = LEX_INTERPNORMAL;
2445 /* we don't clear PL_lex_repl here, so that we can check later
2446 whether this is an evalled subst; that means we rely on the
2447 logic to ensure sublex_done() is called again only via the
2448 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2451 PL_lex_state = LEX_INTERPCONCAT;
2454 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2455 CopLINE(PL_curcop) +=
2456 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2457 + PL_parser->herelines;
2458 PL_parser->herelines = 0;
2463 const line_t l = CopLINE(PL_curcop);
2465 if (PL_multi_close == '<')
2466 PL_parser->herelines += l - PL_multi_end;
2467 PL_bufend = SvPVX(PL_linestr);
2468 PL_bufend += SvCUR(PL_linestr);
2469 PL_expect = XOPERATOR;
2470 PL_sublex_info.sub_inwhat = 0;
2475 PERL_STATIC_INLINE SV*
2476 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2478 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2479 * interior, hence to the "}". Finds what the name resolves to, returning
2480 * an SV* containing it; NULL if no valid one found */
2482 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2489 const U8* first_bad_char_loc;
2490 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2492 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2494 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2496 &first_bad_char_loc))
2498 /* If warnings are on, this will print a more detailed analysis of what
2499 * is wrong than the error message below */
2500 utf8n_to_uvchr(first_bad_char_loc,
2501 e - ((char *) first_bad_char_loc),
2504 /* We deliberately don't try to print the malformed character, which
2505 * might not print very well; it also may be just the first of many
2506 * malformations, so don't print what comes after it */
2507 yyerror(Perl_form(aTHX_
2508 "Malformed UTF-8 character immediately after '%.*s'",
2509 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2513 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2514 /* include the <}> */
2515 e - backslash_ptr + 1);
2517 SvREFCNT_dec_NN(res);
2521 /* See if the charnames handler is the Perl core's, and if so, we can skip
2522 * the validation needed for a user-supplied one, as Perl's does its own
2524 table = GvHV(PL_hintgv); /* ^H */
2525 cvp = hv_fetchs(table, "charnames", FALSE);
2526 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2527 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2529 const char * const name = HvNAME(stash);
2530 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2531 && strEQ(name, "_charnames")) {
2536 /* Here, it isn't Perl's charname handler. We can't rely on a
2537 * user-supplied handler to validate the input name. For non-ut8 input,
2538 * look to see that the first character is legal. Then loop through the
2539 * rest checking that each is a continuation */
2541 /* This code makes the reasonable assumption that the only Latin1-range
2542 * characters that begin a character name alias are alphabetic, otherwise
2543 * would have to create a isCHARNAME_BEGIN macro */
2546 if (! isALPHAU(*s)) {
2551 if (! isCHARNAME_CONT(*s)) {
2554 if (*s == ' ' && *(s-1) == ' ') {
2557 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2558 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2559 "NO-BREAK SPACE in a charnames "
2560 "alias definition is deprecated");
2566 /* Similarly for utf8. For invariants can check directly; for other
2567 * Latin1, can calculate their code point and check; otherwise use a
2569 if (UTF8_IS_INVARIANT(*s)) {
2570 if (! isALPHAU(*s)) {
2574 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2575 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2581 if (! PL_utf8_charname_begin) {
2582 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2583 PL_utf8_charname_begin = _core_swash_init("utf8",
2584 "_Perl_Charname_Begin",
2586 1, 0, NULL, &flags);
2588 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2595 if (UTF8_IS_INVARIANT(*s)) {
2596 if (! isCHARNAME_CONT(*s)) {
2599 if (*s == ' ' && *(s-1) == ' ') {
2604 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2605 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2609 if (*s == *NBSP_UTF8
2610 && *(s+1) == *(NBSP_UTF8+1)
2611 && ckWARN_d(WARN_DEPRECATED))
2613 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2614 "NO-BREAK SPACE in a charnames "
2615 "alias definition is deprecated");
2620 if (! PL_utf8_charname_continue) {
2621 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2622 PL_utf8_charname_continue = _core_swash_init("utf8",
2623 "_Perl_Charname_Continue",
2625 1, 0, NULL, &flags);
2627 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2634 if (*(s-1) == ' ') {
2637 "charnames alias definitions may not contain trailing "
2638 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2639 (int)(s - backslash_ptr + 1), backslash_ptr,
2640 (int)(e - s + 1), s + 1
2642 UTF ? SVf_UTF8 : 0);
2646 if (SvUTF8(res)) { /* Don't accept malformed input */
2647 const U8* first_bad_char_loc;
2649 const char* const str = SvPV_const(res, len);
2650 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2651 /* If warnings are on, this will print a more detailed analysis of
2652 * what is wrong than the error message below */
2653 utf8n_to_uvchr(first_bad_char_loc,
2654 (char *) first_bad_char_loc - str,
2657 /* We deliberately don't try to print the malformed character,
2658 * which might not print very well; it also may be just the first
2659 * of many malformations, so don't print what comes after it */
2662 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2663 (int) (e - backslash_ptr + 1), backslash_ptr,
2664 (int) ((char *) first_bad_char_loc - str), str
2675 /* The final %.*s makes sure that should the trailing NUL be missing
2676 * that this print won't run off the end of the string */
2679 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2680 (int)(s - backslash_ptr + 1), backslash_ptr,
2681 (int)(e - s + 1), s + 1
2683 UTF ? SVf_UTF8 : 0);
2690 "charnames alias definitions may not contain a sequence of "
2691 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2692 (int)(s - backslash_ptr + 1), backslash_ptr,
2693 (int)(e - s + 1), s + 1
2695 UTF ? SVf_UTF8 : 0);
2702 Extracts the next constant part of a pattern, double-quoted string,
2703 or transliteration. This is terrifying code.
2705 For example, in parsing the double-quoted string "ab\x63$d", it would
2706 stop at the '$' and return an OP_CONST containing 'abc'.
2708 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2709 processing a pattern (PL_lex_inpat is true), a transliteration
2710 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2712 Returns a pointer to the character scanned up to. If this is
2713 advanced from the start pointer supplied (i.e. if anything was
2714 successfully parsed), will leave an OP_CONST for the substring scanned
2715 in pl_yylval. Caller must intuit reason for not parsing further
2716 by looking at the next characters herself.
2720 \N{FOO} => \N{U+hex_for_character_FOO}
2721 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2724 all other \-char, including \N and \N{ apart from \N{ABC}
2727 @ and $ where it appears to be a var, but not for $ as tail anchor
2732 In transliterations:
2733 characters are VERY literal, except for - not at the start or end
2734 of the string, which indicates a range. If the range is in bytes,
2735 scan_const expands the range to the full set of intermediate
2736 characters. If the range is in utf8, the hyphen is replaced with
2737 a certain range mark which will be handled by pmtrans() in op.c.
2739 In double-quoted strings:
2741 double-quoted style: \r and \n
2742 constants: \x31, etc.
2743 deprecated backrefs: \1 (in substitution replacements)
2744 case and quoting: \U \Q \E
2747 scan_const does *not* construct ops to handle interpolated strings.
2748 It stops processing as soon as it finds an embedded $ or @ variable
2749 and leaves it to the caller to work out what's going on.
2751 embedded arrays (whether in pattern or not) could be:
2752 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2754 $ in double-quoted strings must be the symbol of an embedded scalar.
2756 $ in pattern could be $foo or could be tail anchor. Assumption:
2757 it's a tail anchor if $ is the last thing in the string, or if it's
2758 followed by one of "()| \r\n\t"
2760 \1 (backreferences) are turned into $1 in substitutions
2762 The structure of the code is
2763 while (there's a character to process) {
2764 handle transliteration ranges
2765 skip regexp comments /(?#comment)/ and codes /(?{code})/
2766 skip #-initiated comments in //x patterns
2767 check for embedded arrays
2768 check for embedded scalars
2770 deprecate \1 in substitution replacements
2771 handle string-changing backslashes \l \U \Q \E, etc.
2772 switch (what was escaped) {
2773 handle \- in a transliteration (becomes a literal -)
2774 if a pattern and not \N{, go treat as regular character
2775 handle \132 (octal characters)
2776 handle \x15 and \x{1234} (hex characters)
2777 handle \N{name} (named characters, also \N{3,5} in a pattern)
2778 handle \cV (control characters)
2779 handle printf-style backslashes (\f, \r, \n, etc)
2782 } (end if backslash)
2783 handle regular character
2784 } (end while character to read)
2789 S_scan_const(pTHX_ char *start)
2791 char *send = PL_bufend; /* end of the constant */
2792 SV *sv = newSV(send - start); /* sv for the constant. See note below
2794 char *s = start; /* start of the constant */
2795 char *d = SvPVX(sv); /* destination for copies */
2796 bool dorange = FALSE; /* are we in a translit range? */
2797 bool didrange = FALSE; /* did we just finish a range? */
2798 bool in_charclass = FALSE; /* within /[...]/ */
2799 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2800 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2801 UTF8? But, this can show as true
2802 when the source isn't utf8, as for
2803 example when it is entirely composed
2805 SV *res; /* result from charnames */
2807 /* Note on sizing: The scanned constant is placed into sv, which is
2808 * initialized by newSV() assuming one byte of output for every byte of
2809 * input. This routine expects newSV() to allocate an extra byte for a
2810 * trailing NUL, which this routine will append if it gets to the end of
2811 * the input. There may be more bytes of input than output (eg., \N{LATIN
2812 * CAPITAL LETTER A}), or more output than input if the constant ends up
2813 * recoded to utf8, but each time a construct is found that might increase
2814 * the needed size, SvGROW() is called. Its size parameter each time is
2815 * based on the best guess estimate at the time, namely the length used so
2816 * far, plus the length the current construct will occupy, plus room for
2817 * the trailing NUL, plus one byte for every input byte still unscanned */
2819 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2822 UV literal_endpoint = 0;
2823 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2826 PERL_ARGS_ASSERT_SCAN_CONST;
2828 assert(PL_lex_inwhat != OP_TRANSR);
2829 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2830 /* If we are doing a trans and we know we want UTF8 set expectation */
2831 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2832 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2835 /* Protect sv from errors and fatal warnings. */
2836 ENTER_with_name("scan_const");
2839 while (s < send || dorange) {
2841 /* get transliterations out of the way (they're most literal) */
2842 if (PL_lex_inwhat == OP_TRANS) {
2843 /* expand a range A-Z to the full set of characters. AIE! */
2845 I32 i; /* current expanded character */
2846 I32 min; /* first character in range */
2847 I32 max; /* last character in range */
2858 char * const c = (char*)utf8_hop((U8*)d, -1);
2862 *c = (char) ILLEGAL_UTF8_BYTE;
2863 /* mark the range as done, and continue */
2869 i = d - SvPVX_const(sv); /* remember current offset */
2872 SvLEN(sv) + ((has_utf8)
2873 ? (512 - UTF_CONTINUATION_MARK
2876 /* How many two-byte within 0..255: 128 in UTF-8,
2877 * 96 in UTF-8-mod. */
2879 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2881 d = SvPVX(sv) + i; /* refresh d after realloc */
2885 for (j = 0; j <= 1; j++) {
2886 char * const c = (char*)utf8_hop((U8*)d, -1);
2887 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2893 max = (U8)0xff; /* only to \xff */
2894 uvmax = uv; /* \x{100} to uvmax */
2896 d = c; /* eat endpoint chars */
2901 d -= 2; /* eat the first char and the - */
2902 min = (U8)*d; /* first char in range */
2903 max = (U8)d[1]; /* last char in range */
2910 "Invalid range \"%c-%c\" in transliteration operator",
2911 (char)min, (char)max);
2915 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2916 * any subsets of these ranges into individual characters */
2917 if (literal_endpoint == 2 &&
2918 ((isLOWER_A(min) && isLOWER_A(max)) ||
2919 (isUPPER_A(min) && isUPPER_A(max))))
2921 for (i = min; i <= max; i++) {
2928 for (i = min; i <= max; i++)
2931 append_utf8_from_native_byte(i, &d);
2939 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2941 *d++ = (char) ILLEGAL_UTF8_BYTE;
2943 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2947 /* mark the range as done, and continue */
2951 literal_endpoint = 0;
2956 /* range begins (ignore - as first or last char) */
2957 else if (*s == '-' && s+1 < send && s != start) {
2959 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2966 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2976 literal_endpoint = 0;
2977 native_range = TRUE;
2982 /* if we get here, we're not doing a transliteration */
2984 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2987 while (s1 >= start && *s1-- == '\\')
2990 in_charclass = TRUE;
2993 else if (*s == ']' && PL_lex_inpat && in_charclass) {
2996 while (s1 >= start && *s1-- == '\\')
2999 in_charclass = FALSE;
3002 /* skip for regexp comments /(?#comment)/, except for the last
3003 * char, which will be done separately.
3004 * Stop on (?{..}) and friends */
3006 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3008 while (s+1 < send && *s != ')')
3011 else if (!PL_lex_casemods &&
3012 ( s[2] == '{' /* This should match regcomp.c */
3013 || (s[2] == '?' && s[3] == '{')))
3019 /* likewise skip #-initiated comments in //x patterns */
3020 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3021 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3022 while (s+1 < send && *s != '\n')
3026 /* no further processing of single-quoted regex */
3027 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3028 goto default_action;
3030 /* check for embedded arrays
3031 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3033 else if (*s == '@' && s[1]) {
3034 if (isWORDCHAR_lazy_if(s+1,UTF))
3036 if (strchr(":'{$", s[1]))
3038 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3039 break; /* in regexp, neither @+ nor @- are interpolated */
3042 /* check for embedded scalars. only stop if we're sure it's a
3045 else if (*s == '$') {
3046 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3048 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3050 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3051 "Possible unintended interpolation of $\\ in regex");
3053 break; /* in regexp, $ might be tail anchor */
3057 /* End of else if chain - OP_TRANS rejoin rest */
3060 if (*s == '\\' && s+1 < send) {
3061 char* e; /* Can be used for ending '}', etc. */
3065 /* warn on \1 - \9 in substitution replacements, but note that \11
3066 * is an octal; and \19 is \1 followed by '9' */
3067 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3068 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3070 /* diag_listed_as: \%d better written as $%d */
3071 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3076 /* string-change backslash escapes */
3077 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3081 /* In a pattern, process \N, but skip any other backslash escapes.
3082 * This is because we don't want to translate an escape sequence
3083 * into a meta symbol and have the regex compiler use the meta
3084 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3085 * in spite of this, we do have to process \N here while the proper
3086 * charnames handler is in scope. See bugs #56444 and #62056.
3088 * There is a complication because \N in a pattern may also stand
3089 * for 'match a non-nl', and not mean a charname, in which case its
3090 * processing should be deferred to the regex compiler. To be a
3091 * charname it must be followed immediately by a '{', and not look
3092 * like \N followed by a curly quantifier, i.e., not something like
3093 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3095 else if (PL_lex_inpat
3098 || regcurly(s + 1)))
3101 goto default_action;
3106 /* quoted - in transliterations */
3108 if (PL_lex_inwhat == OP_TRANS) {
3115 if ((isALPHANUMERIC(*s)))
3116 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3117 "Unrecognized escape \\%c passed through",
3119 /* default action is to copy the quoted character */
3120 goto default_action;
3123 /* eg. \132 indicates the octal constant 0132 */
3124 case '0': case '1': case '2': case '3':
3125 case '4': case '5': case '6': case '7':
3127 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3129 uv = grok_oct(s, &len, &flags, NULL);
3131 if (len < 3 && s < send && isDIGIT(*s)
3132 && ckWARN(WARN_MISC))
3134 Perl_warner(aTHX_ packWARN(WARN_MISC),
3135 "%s", form_short_octal_warning(s, len));
3138 goto NUM_ESCAPE_INSERT;
3140 /* eg. \o{24} indicates the octal constant \024 */
3145 bool valid = grok_bslash_o(&s, &uv, &error,
3146 TRUE, /* Output warning */
3147 FALSE, /* Not strict */
3148 TRUE, /* Output warnings for
3155 goto NUM_ESCAPE_INSERT;
3158 /* eg. \x24 indicates the hex constant 0x24 */
3163 bool valid = grok_bslash_x(&s, &uv, &error,
3164 TRUE, /* Output warning */
3165 FALSE, /* Not strict */
3166 TRUE, /* Output warnings for
3176 /* Insert oct or hex escaped character. There will always be
3177 * enough room in sv since such escapes will be longer than any
3178 * UTF-8 sequence they can end up as, except if they force us
3179 * to recode the rest of the string into utf8 */
3181 /* Here uv is the ordinal of the next character being added */
3182 if (!UVCHR_IS_INVARIANT(uv)) {
3183 if (!has_utf8 && uv > 255) {
3184 /* Might need to recode whatever we have accumulated so
3185 * far if it contains any chars variant in utf8 or
3188 SvCUR_set(sv, d - SvPVX_const(sv));
3191 /* See Note on sizing above. */
3192 sv_utf8_upgrade_flags_grow(
3194 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3195 /* Above-latin1 in string
3196 * implies no encoding */
3197 |SV_UTF8_NO_ENCODING,
3198 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3199 d = SvPVX(sv) + SvCUR(sv);
3204 d = (char*)uvchr_to_utf8((U8*)d, uv);
3205 if (PL_lex_inwhat == OP_TRANS &&
3206 PL_sublex_info.sub_op) {
3207 PL_sublex_info.sub_op->op_private |=
3208 (PL_lex_repl ? OPpTRANS_FROM_UTF
3212 if (uv > 255 && !dorange)
3213 native_range = FALSE;
3226 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3227 * named character, like \N{LATIN SMALL LETTER A}, or a named
3228 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3229 * GRAVE}. For convenience all three forms are referred to as
3230 * "named characters" below.
3232 * For patterns, \N also can mean to match a non-newline. Code
3233 * before this 'switch' statement should already have handled
3234 * this situation, and hence this code only has to deal with
3235 * the named character cases.
3237 * For non-patterns, the named characters are converted to
3238 * their string equivalents. In patterns, named characters are
3239 * not converted to their ultimate forms for the same reasons
3240 * that other escapes aren't. Instead, they are converted to
3241 * the \N{U+...} form to get the value from the charnames that
3242 * is in effect right now, while preserving the fact that it
3243 * was a named character, so that the regex compiler knows
3246 * The structure of this section of code (besides checking for
3247 * errors and upgrading to utf8) is:
3248 * If the named character is of the form \N{U+...}, pass it
3249 * through if a pattern; otherwise convert the code point
3251 * Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3252 * if a pattern; otherwise convert to utf8
3254 * If the regex compiler should ever need to differentiate
3255 * between the \N{U+...} and \N{name} forms, that could easily
3256 * be done here by stripping any leading zeros from the
3257 * \N{U+...} case, and adding them to the other one. */
3259 /* Here, 's' points to the 'N'; the test below is guaranteed to
3260 * succeed if we are being called on a pattern, as we already
3261 * know from a test above that the next character is a '{'. A
3262 * non-pattern \N must mean 'named character', which requires
3266 yyerror("Missing braces on \\N{}");
3271 /* If there is no matching '}', it is an error. */
3272 if (! (e = strchr(s, '}'))) {
3273 if (! PL_lex_inpat) {
3274 yyerror("Missing right brace on \\N{}");
3276 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3281 /* Here it looks like a named character */
3283 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3284 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3285 | PERL_SCAN_DISALLOW_PREFIX;
3288 s += 2; /* Skip to next char after the 'U+' */
3290 uv = grok_hex(s, &len, &flags, NULL);
3291 if (len == 0 || len != (STRLEN)(e - s)) {
3292 yyerror("Invalid hexadecimal number in \\N{U+...}");
3298 s -= 5; /* Include the '\N{U+' */
3300 /* On EBCDIC platforms, in \N{U+...}, the '...' is a
3301 * Unicode value, so convert to native so downstream
3302 * code can continue to assume it's native */
3303 d += my_snprintf(d, e - s + 1 + 1, /* includes the '}'
3306 (unsigned int) UNI_TO_NATIVE(uv));
3308 /* On non-EBCDIC platforms, pass it through unchanged.
3309 * The reason we evaluated the number above is to make
3310 * sure there wasn't a syntax error. */
3311 Copy(s, d, e - s + 1, char); /* +1 is for the '}' */
3315 else { /* Not a pattern: convert the hex to string */
3317 /* If the destination is not in utf8, unconditionally
3318 * recode it to be so. This is because \N{} implies
3319 * Unicode semantics, and scalars have to be in utf8
3320 * to guarantee those semantics */
3322 SvCUR_set(sv, d - SvPVX_const(sv));
3325 /* See Note on sizing above. */
3326 sv_utf8_upgrade_flags_grow(
3328 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3329 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3330 d = SvPVX(sv) + SvCUR(sv);
3334 /* Add the (Unicode) code point to the output. */
3335 if (UNI_IS_INVARIANT(uv)) {
3336 *d++ = (char) LATIN1_TO_NATIVE(uv);
3339 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3343 else /* Here is \N{NAME} but not \N{U+...}. */
3344 if ((res = get_and_check_backslash_N_name(s, e)))
3347 const char *str = SvPV_const(res, len);
3350 if (! len) { /* The name resolved to an empty string */
3351 Copy("\\N{}", d, 4, char);
3355 /* In order to not lose information for the regex
3356 * compiler, pass the result in the specially made
3357 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3358 * the code points in hex of each character
3359 * returned by charnames */
3361 const char *str_end = str + len;
3362 const STRLEN off = d - SvPVX_const(sv);
3364 if (! SvUTF8(res)) {
3365 /* For the non-UTF-8 case, we can determine the
3366 * exact length needed without having to parse
3367 * through the string. Each character takes up
3368 * 2 hex digits plus either a trailing dot or
3370 const char initial_text[] = "\\N{U+";
3371 const STRLEN initial_len = sizeof(initial_text)
3373 d = off + SvGROW(sv, off
3376 /* +1 for trailing NUL */
3379 + (STRLEN)(send - e));
3380 Copy(initial_text, d, initial_len, char);
3382 while (str < str_end) {
3385 my_snprintf(hex_string,
3387 "%02X.", (U8) *str);
3388 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3389 Copy(hex_string, d, 3, char);
3393 d--; /* Below, we will overwrite the final
3394 dot with a right brace */
3397 STRLEN char_length; /* cur char's byte length */
3399 /* and the number of bytes after this is
3400 * translated into hex digits */
3401 STRLEN output_length;
3403 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3404 * for max('U+', '.'); and 1 for NUL */
3405 char hex_string[2 * UTF8_MAXBYTES + 5];
3407 /* Get the first character of the result. */
3408 U32 uv = utf8n_to_uvchr((U8 *) str,
3412 /* Convert first code point to hex, including
3413 * the boiler plate before it. */
3415 my_snprintf(hex_string, sizeof(hex_string),
3419 /* Make sure there is enough space to hold it */
3420 d = off + SvGROW(sv, off
3422 + (STRLEN)(send - e)
3423 + 2); /* '}' + NUL */
3425 Copy(hex_string, d, output_length, char);
3428 /* For each subsequent character, append dot and
3429 * its ordinal in hex */
3430 while ((str += char_length) < str_end) {
3431 const STRLEN off = d - SvPVX_const(sv);
3432 U32 uv = utf8n_to_uvchr((U8 *) str,
3437 my_snprintf(hex_string,
3442 d = off + SvGROW(sv, off
3444 + (STRLEN)(send - e)
3445 + 2); /* '}' + NUL */
3446 Copy(hex_string, d, output_length, char);
3451 *d++ = '}'; /* Done. Add the trailing brace */
3454 else { /* Here, not in a pattern. Convert the name to a
3457 /* If destination is not in utf8, unconditionally
3458 * recode it to be so. This is because \N{} implies
3459 * Unicode semantics, and scalars have to be in utf8
3460 * to guarantee those semantics */
3462 SvCUR_set(sv, d - SvPVX_const(sv));
3465 /* See Note on sizing above. */
3466 sv_utf8_upgrade_flags_grow(sv,
3467 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3468 len + (STRLEN)(send - s) + 1);
3469 d = SvPVX(sv) + SvCUR(sv);
3471 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3473 /* See Note on sizing above. (NOTE: SvCUR() is not
3474 * set correctly here). */
3475 const STRLEN off = d - SvPVX_const(sv);
3476 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3478 if (! SvUTF8(res)) { /* Make sure \N{} return is UTF-8 */
3479 sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3480 str = SvPV_const(res, len);
3482 Copy(str, d, len, char);
3488 } /* End \N{NAME} */
3491 native_range = FALSE; /* \N{} is defined to be Unicode */
3493 s = e + 1; /* Point to just after the '}' */
3496 /* \c is a control character */
3500 *d++ = grok_bslash_c(*s++, 1);
3503 yyerror("Missing control char name in \\c");
3507 /* printf-style backslashes, formfeeds, newlines, etc */
3533 } /* end if (backslash) */
3540 /* If we started with encoded form, or already know we want it,
3541 then encode the next character */
3542 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3546 /* One might think that it is wasted effort in the case of the
3547 * source being utf8 (this_utf8 == TRUE) to take the next character
3548 * in the source, convert it to an unsigned value, and then convert
3549 * it back again. But the source has not been validated here. The
3550 * routine that does the conversion checks for errors like
3553 const UV nextuv = (this_utf8)
3554 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3556 const STRLEN need = UNISKIP(nextuv);
3558 SvCUR_set(sv, d - SvPVX_const(sv));
3561 /* See Note on sizing above. */
3562 sv_utf8_upgrade_flags_grow(sv,
3563 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3564 need + (STRLEN)(send - s) + 1);
3565 d = SvPVX(sv) + SvCUR(sv);
3567 } else if (need > len) {
3568 /* encoded value larger than old, may need extra space (NOTE:
3569 * SvCUR() is not set correctly here). See Note on sizing
3571 const STRLEN off = d - SvPVX_const(sv);
3572 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3576 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3578 if (uv > 255 && !dorange)
3579 native_range = FALSE;
3585 } /* while loop to process each character */
3587 /* terminate the string and set up the sv */
3589 SvCUR_set(sv, d - SvPVX_const(sv));
3590 if (SvCUR(sv) >= SvLEN(sv))
3591 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3592 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3595 if (IN_ENCODING && !has_utf8) {
3596 sv_recode_to_utf8(sv, _get_encoding());
3602 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3603 PL_sublex_info.sub_op->op_private |=
3604 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3608 /* shrink the sv if we allocated more than we used */
3609 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3610 SvPV_shrink_to_cur(sv);
3613 /* return the substring (via pl_yylval) only if we parsed anything */
3616 for (; s2 < s; s2++) {
3618 COPLINE_INC_WITH_HERELINES;
3620 SvREFCNT_inc_simple_void_NN(sv);
3621 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3622 && ! PL_parser->lex_re_reparsing)
3624 const char *const key = PL_lex_inpat ? "qr" : "q";
3625 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3629 if (PL_lex_inwhat == OP_TRANS) {
3632 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3635 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3643 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3646 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3648 LEAVE_with_name("scan_const");
3653 * Returns TRUE if there's more to the expression (e.g., a subscript),
3656 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3658 * ->[ and ->{ return TRUE
3659 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3660 * { and [ outside a pattern are always subscripts, so return TRUE
3661 * if we're outside a pattern and it's not { or [, then return FALSE
3662 * if we're in a pattern and the first char is a {
3663 * {4,5} (any digits around the comma) returns FALSE
3664 * if we're in a pattern and the first char is a [
3666 * [SOMETHING] has a funky algorithm to decide whether it's a
3667 * character class or not. It has to deal with things like
3668 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3669 * anything else returns TRUE
3672 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3675 S_intuit_more(pTHX_ char *s)
3677 PERL_ARGS_ASSERT_INTUIT_MORE;
3679 if (PL_lex_brackets)
3681 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3683 if (*s == '-' && s[1] == '>'
3684 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3685 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3686 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3688 if (*s != '{' && *s != '[')
3693 /* In a pattern, so maybe we have {n,m}. */
3701 /* On the other hand, maybe we have a character class */
3704 if (*s == ']' || *s == '^')
3707 /* this is terrifying, and it works */
3710 const char * const send = strchr(s,']');
3711 unsigned char un_char, last_un_char;
3712 char tmpbuf[sizeof PL_tokenbuf * 4];
3714 if (!send) /* has to be an expression */
3716 weight = 2; /* let's weigh the evidence */
3720 else if (isDIGIT(*s)) {
3722 if (isDIGIT(s[1]) && s[2] == ']')
3728 Zero(seen,256,char);
3730 for (; s < send; s++) {
3731 last_un_char = un_char;
3732 un_char = (unsigned char)*s;
3737 weight -= seen[un_char] * 10;
3738 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3740 char *tmp = PL_bufend;
3741 PL_bufend = (char*)send;
3742 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3744 len = (int)strlen(tmpbuf);
3745 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3746 UTF ? SVf_UTF8 : 0, SVt_PV))
3751 else if (*s == '$' && s[1] &&
3752 strchr("[#!%*<>()-=",s[1])) {
3753 if (/*{*/ strchr("])} =",s[2]))
3762 if (strchr("wds]",s[1]))
3764 else if (seen[(U8)'\''] || seen[(U8)'"'])
3766 else if (strchr("rnftbxcav",s[1]))
3768 else if (isDIGIT(s[1])) {
3770 while (s[1] && isDIGIT(s[1]))
3780 if (strchr("aA01! ",last_un_char))
3782 if (strchr("zZ79~",s[1]))
3784 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3785 weight -= 5; /* cope with negative subscript */
3788 if (!isWORDCHAR(last_un_char)
3789 && !(last_un_char == '$' || last_un_char == '@'
3790 || last_un_char == '&')
3791 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3796 if (keyword(tmpbuf, d - tmpbuf, 0))
3799 if (un_char == last_un_char + 1)
3801 weight -= seen[un_char];
3806 if (weight >= 0) /* probably a character class */
3816 * Does all the checking to disambiguate
3818 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3819 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3821 * First argument is the stuff after the first token, e.g. "bar".
3823 * Not a method if foo is a filehandle.
3824 * Not a method if foo is a subroutine prototyped to take a filehandle.
3825 * Not a method if it's really "Foo $bar"
3826 * Method if it's "foo $bar"
3827 * Not a method if it's really "print foo $bar"
3828 * Method if it's really "foo package::" (interpreted as package->foo)
3829 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3830 * Not a method if bar is a filehandle or package, but is quoted with
3835 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3837 char *s = start + (*start == '$');
3838 char tmpbuf[sizeof PL_tokenbuf];
3841 /* Mustn't actually add anything to a symbol table.
3842 But also don't want to "initialise" any placeholder
3843 constants that might already be there into full
3844 blown PVGVs with attached PVCV. */
3846 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3848 PERL_ARGS_ASSERT_INTUIT_METHOD;
3850 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3852 if (cv && SvPOK(cv)) {
3853 const char *proto = CvPROTO(cv);
3855 while (*proto && (isSPACE(*proto) || *proto == ';'))
3862 if (*start == '$') {
3863 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3864 isUPPER(*PL_tokenbuf))
3869 return *s == '(' ? FUNCMETH : METHOD;
3872 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3873 /* start is the beginning of the possible filehandle/object,
3874 * and s is the end of it
3875 * tmpbuf is a copy of it (but with single quotes as double colons)
3878 if (!keyword(tmpbuf, len, 0)) {
3879 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3884 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3885 if (indirgv && GvCVu(indirgv))
3887 /* filehandle or package name makes it a method */
3888 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3890 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3891 return 0; /* no assumptions -- "=>" quotes bareword */
3893 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3894 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3895 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3899 return *s == '(' ? FUNCMETH : METHOD;
3905 /* Encoded script support. filter_add() effectively inserts a
3906 * 'pre-processing' function into the current source input stream.
3907 * Note that the filter function only applies to the current source file
3908 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3910 * The datasv parameter (which may be NULL) can be used to pass
3911 * private data to this instance of the filter. The filter function
3912 * can recover the SV using the FILTER_DATA macro and use it to
3913 * store private buffers and state information.
3915 * The supplied datasv parameter is upgraded to a PVIO type
3916 * and the IoDIRP/IoANY field is used to store the function pointer,
3917 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3918 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3919 * private use must be set using malloc'd pointers.
3923 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3931 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3932 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3934 if (!PL_rsfp_filters)
3935 PL_rsfp_filters = newAV();
3938 SvUPGRADE(datasv, SVt_PVIO);
3939 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3940 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3941 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3942 FPTR2DPTR(void *, IoANY(datasv)),
3943 SvPV_nolen(datasv)));
3944 av_unshift(PL_rsfp_filters, 1);
3945 av_store(PL_rsfp_filters, 0, datasv) ;
3947 !PL_parser->filtered
3948 && PL_parser->lex_flags & LEX_EVALBYTES
3949 && PL_bufptr < PL_bufend
3951 const char *s = PL_bufptr;
3952 while (s < PL_bufend) {
3954 SV *linestr = PL_parser->linestr;
3955 char *buf = SvPVX(linestr);
3956 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3957 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3958 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3959 STRLEN const linestart_pos = PL_parser->linestart - buf;
3960 STRLEN const last_uni_pos =
3961 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3962 STRLEN const last_lop_pos =
3963 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3964 av_push(PL_rsfp_filters, linestr);
3965 PL_parser->linestr =
3966 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3967 buf = SvPVX(PL_parser->linestr);
3968 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3969 PL_parser->bufptr = buf + bufptr_pos;
3970 PL_parser->oldbufptr = buf + oldbufptr_pos;
3971 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3972 PL_parser->linestart = buf + linestart_pos;
3973 if (PL_parser->last_uni)
3974 PL_parser->last_uni = buf + last_uni_pos;
3975 if (PL_parser->last_lop)
3976 PL_parser->last_lop = buf + last_lop_pos;
3977 SvLEN(linestr) = SvCUR(linestr);
3978 SvCUR(linestr) = s-SvPVX(linestr);
3979 PL_parser->filtered = 1;
3989 /* Delete most recently added instance of this filter function. */
3991 Perl_filter_del(pTHX_ filter_t funcp)
3995 PERL_ARGS_ASSERT_FILTER_DEL;
3998 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3999 FPTR2DPTR(void*, funcp)));
4001 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4003 /* if filter is on top of stack (usual case) just pop it off */
4004 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4005 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4006 sv_free(av_pop(PL_rsfp_filters));
4010 /* we need to search for the correct entry and clear it */
4011 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4015 /* Invoke the idxth filter function for the current rsfp. */
4016 /* maxlen 0 = read one text line */
4018 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4022 /* This API is bad. It should have been using unsigned int for maxlen.
4023 Not sure if we want to change the API, but if not we should sanity
4024 check the value here. */
4025 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4027 PERL_ARGS_ASSERT_FILTER_READ;
4029 if (!PL_parser || !PL_rsfp_filters)
4031 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4032 /* Provide a default input filter to make life easy. */
4033 /* Note that we append to the line. This is handy. */
4034 DEBUG_P(PerlIO_printf(Perl_debug_log,
4035 "filter_read %d: from rsfp\n", idx));
4036 if (correct_length) {
4039 const int old_len = SvCUR(buf_sv);
4041 /* ensure buf_sv is large enough */
4042 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4043 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4044 correct_length)) <= 0) {
4045 if (PerlIO_error(PL_rsfp))
4046 return -1; /* error */
4048 return 0 ; /* end of file */
4050 SvCUR_set(buf_sv, old_len + len) ;
4051 SvPVX(buf_sv)[old_len + len] = '\0';
4054 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4055 if (PerlIO_error(PL_rsfp))
4056 return -1; /* error */
4058 return 0 ; /* end of file */
4061 return SvCUR(buf_sv);
4063 /* Skip this filter slot if filter has been deleted */
4064 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4065 DEBUG_P(PerlIO_printf(Perl_debug_log,
4066 "filter_read %d: skipped (filter deleted)\n",
4068 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4070 if (SvTYPE(datasv) != SVt_PVIO) {
4071 if (correct_length) {
4073 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4074 if (!remainder) return 0; /* eof */
4075 if (correct_length > remainder) correct_length = remainder;
4076 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4077 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4080 const char *s = SvEND(datasv);
4081 const char *send = SvPVX(datasv) + SvLEN(datasv);
4089 if (s == send) return 0; /* eof */
4090 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4091 SvCUR_set(datasv, s-SvPVX(datasv));
4093 return SvCUR(buf_sv);
4095 /* Get function pointer hidden within datasv */
4096 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4097 DEBUG_P(PerlIO_printf(Perl_debug_log,
4098 "filter_read %d: via function %p (%s)\n",
4099 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4100 /* Call function. The function is expected to */
4101 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4102 /* Return: <0:error, =0:eof, >0:not eof */
4103 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4107 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4109 PERL_ARGS_ASSERT_FILTER_GETS;
4111 #ifdef PERL_CR_FILTER
4112 if (!PL_rsfp_filters) {
4113 filter_add(S_cr_textfilter,NULL);
4116 if (PL_rsfp_filters) {
4118 SvCUR_set(sv, 0); /* start with empty line */
4119 if (FILTER_READ(0, sv, 0) > 0)
4120 return ( SvPVX(sv) ) ;
4125 return (sv_gets(sv, PL_rsfp, append));
4129 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4133 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4135 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4139 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4140 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4142 return GvHV(gv); /* Foo:: */
4145 /* use constant CLASS => 'MyClass' */
4146 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4147 if (gv && GvCV(gv)) {
4148 SV * const sv = cv_const_sv(GvCV(gv));
4150 return gv_stashsv(sv, 0);
4153 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4158 S_tokenize_use(pTHX_ int is_use, char *s) {
4159 PERL_ARGS_ASSERT_TOKENIZE_USE;
4161 if (PL_expect != XSTATE)
4162 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4163 is_use ? "use" : "no"));
4166 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4167 s = force_version(s, TRUE);
4168 if (*s == ';' || *s == '}'
4169 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4170 NEXTVAL_NEXTTOKE.opval = NULL;
4173 else if (*s == 'v') {
4174 s = force_word(s,WORD,FALSE,TRUE);
4175 s = force_version(s, FALSE);
4179 s = force_word(s,WORD,FALSE,TRUE);
4180 s = force_version(s, FALSE);
4182 pl_yylval.ival = is_use;
4186 static const char* const exp_name[] =
4187 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4188 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4193 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4195 S_word_takes_any_delimeter(char *p, STRLEN len)
4197 return (len == 1 && strchr("msyq", p[0])) ||
4199 (p[0] == 't' && p[1] == 'r') ||
4200 (p[0] == 'q' && strchr("qwxr", p[1]))));
4204 S_check_scalar_slice(pTHX_ char *s)
4207 while (*s == ' ' || *s == '\t') s++;
4208 if (*s == 'q' && s[1] == 'w'
4209 && !isWORDCHAR_lazy_if(s+2,UTF))
4211 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4212 s += UTF ? UTF8SKIP(s) : 1;
4213 if (*s == '}' || *s == ']')
4214 pl_yylval.ival = OPpSLICEWARNING;
4220 Works out what to call the token just pulled out of the input
4221 stream. The yacc parser takes care of taking the ops we return and
4222 stitching them into a tree.
4225 The type of the next token
4228 Switch based on the current state:
4229 - if we already built the token before, use it
4230 - if we have a case modifier in a string, deal with that
4231 - handle other cases of interpolation inside a string
4232 - scan the next line if we are inside a format
4233 In the normal state switch on the next character:
4235 if alphabetic, go to key lookup
4236 unrecoginized character - croak
4237 - 0/4/26: handle end-of-line or EOF
4238 - cases for whitespace
4239 - \n and #: handle comments and line numbers
4240 - various operators, brackets and sigils
4243 - 'v': vstrings (or go to key lookup)
4244 - 'x' repetition operator (or go to key lookup)
4245 - other ASCII alphanumerics (key lookup begins here):
4248 scan built-in keyword (but do nothing with it yet)
4249 check for statement label
4250 check for lexical subs
4251 goto just_a_word if there is one
4252 see whether built-in keyword is overridden
4253 switch on keyword number:
4254 - default: just_a_word:
4255 not a built-in keyword; handle bareword lookup
4256 disambiguate between method and sub call
4257 fall back to bareword
4258 - cases for built-in keywords
4266 char *s = PL_bufptr;
4270 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4274 /* orig_keyword, gvp, and gv are initialized here because
4275 * jump to the label just_a_word_zero can bypass their
4276 * initialization later. */
4277 I32 orig_keyword = 0;
4282 SV* tmp = newSVpvs("");
4283 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4284 (IV)CopLINE(PL_curcop),
4285 lex_state_names[PL_lex_state],
4286 exp_name[PL_expect],
4287 pv_display(tmp, s, strlen(s), 0, 60));
4291 switch (PL_lex_state) {
4293 case LEX_INTERPNORMAL:
4296 /* when we've already built the next token, just pull it out of the queue */
4299 pl_yylval = PL_nextval[PL_nexttoke];
4301 PL_lex_state = PL_lex_defer;
4302 PL_lex_defer = LEX_NORMAL;
4306 next_type = PL_nexttype[PL_nexttoke];
4307 if (next_type & (7<<24)) {
4308 if (next_type & (1<<24)) {
4309 if (PL_lex_brackets > 100)
4310 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4311 PL_lex_brackstack[PL_lex_brackets++] =
4312 (char) ((next_type >> 16) & 0xff);
4314 if (next_type & (2<<24))
4315 PL_lex_allbrackets++;
4316 if (next_type & (4<<24))
4317 PL_lex_allbrackets--;
4318 next_type &= 0xffff;
4320 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4323 /* interpolated case modifiers like \L \U, including \Q and \E.
4324 when we get here, PL_bufptr is at the \
4326 case LEX_INTERPCASEMOD:
4328 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4330 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4331 PL_bufptr, PL_bufend, *PL_bufptr);
4333 /* handle \E or end of string */
4334 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4336 if (PL_lex_casemods) {
4337 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4338 PL_lex_casestack[PL_lex_casemods] = '\0';
4340 if (PL_bufptr != PL_bufend
4341 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4342 || oldmod == 'F')) {
4344 PL_lex_state = LEX_INTERPCONCAT;
4346 PL_lex_allbrackets--;
4349 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4350 /* Got an unpaired \E */
4351 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4352 "Useless use of \\E");
4354 if (PL_bufptr != PL_bufend)
4356 PL_lex_state = LEX_INTERPCONCAT;
4360 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4361 "### Saw case modifier\n"); });
4363 if (s[1] == '\\' && s[2] == 'E') {
4365 PL_lex_state = LEX_INTERPCONCAT;
4370 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4371 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4372 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4373 (strchr(PL_lex_casestack, 'L')
4374 || strchr(PL_lex_casestack, 'U')
4375 || strchr(PL_lex_casestack, 'F'))) {
4376 PL_lex_casestack[--PL_lex_casemods] = '\0';
4377 PL_lex_allbrackets--;
4380 if (PL_lex_casemods > 10)
4381 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4382 PL_lex_casestack[PL_lex_casemods++] = *s;
4383 PL_lex_casestack[PL_lex_casemods] = '\0';
4384 PL_lex_state = LEX_INTERPCONCAT;
4385 NEXTVAL_NEXTTOKE.ival = 0;
4386 force_next((2<<24)|'(');
4388 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4390 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4392 NEXTVAL_NEXTTOKE.ival = OP_LC;
4394 NEXTVAL_NEXTTOKE.ival = OP_UC;
4396 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4398 NEXTVAL_NEXTTOKE.ival = OP_FC;
4400 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4404 if (PL_lex_starts) {
4407 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4408 if (PL_lex_casemods == 1 && PL_lex_inpat)
4411 AopNOASSIGN(OP_CONCAT);
4417 case LEX_INTERPPUSH:
4418 return REPORT(sublex_push());
4420 case LEX_INTERPSTART:
4421 if (PL_bufptr == PL_bufend)
4422 return REPORT(sublex_done());
4423 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4424 "### Interpolated variable\n"); });
4426 /* for /@a/, we leave the joining for the regex engine to do
4427 * (unless we're within \Q etc) */
4428 PL_lex_dojoin = (*PL_bufptr == '@'
4429 && (!PL_lex_inpat || PL_lex_casemods));
4430 PL_lex_state = LEX_INTERPNORMAL;
4431 if (PL_lex_dojoin) {
4432 NEXTVAL_NEXTTOKE.ival = 0;
4434 force_ident("\"", '$');
4435 NEXTVAL_NEXTTOKE.ival = 0;
4437 NEXTVAL_NEXTTOKE.ival = 0;
4438 force_next((2<<24)|'(');
4439 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4442 /* Convert (?{...}) and friends to 'do {...}' */
4443 if (PL_lex_inpat && *PL_bufptr == '(') {
4444 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4446 if (*PL_bufptr != '{')
4448 PL_expect = XTERMBLOCK;
4452 if (PL_lex_starts++) {
4454 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4455 if (!PL_lex_casemods && PL_lex_inpat)
4458 AopNOASSIGN(OP_CONCAT);
4462 case LEX_INTERPENDMAYBE:
4463 if (intuit_more(PL_bufptr)) {
4464 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4470 if (PL_lex_dojoin) {
4471 const U8 dojoin_was = PL_lex_dojoin;
4472 PL_lex_dojoin = FALSE;
4473 PL_lex_state = LEX_INTERPCONCAT;
4474 PL_lex_allbrackets--;
4475 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4477 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4478 && SvEVALED(PL_lex_repl))
4480 if (PL_bufptr != PL_bufend)
4481 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4484 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4485 re_eval_str. If the here-doc body’s length equals the previous
4486 value of re_eval_start, re_eval_start will now be null. So
4487 check re_eval_str as well. */
4488 if (PL_parser->lex_shared->re_eval_start
4489 || PL_parser->lex_shared->re_eval_str) {
4491 if (*PL_bufptr != ')')
4492 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4494 /* having compiled a (?{..}) expression, return the original
4495 * text too, as a const */
4496 if (PL_parser->lex_shared->re_eval_str) {
4497 sv = PL_parser->lex_shared->re_eval_str;
4498 PL_parser->lex_shared->re_eval_str = NULL;
4500 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4501 SvPV_shrink_to_cur(sv);
4503 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4504 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4505 NEXTVAL_NEXTTOKE.opval =
4506 (OP*)newSVOP(OP_CONST, 0,
4509 PL_parser->lex_shared->re_eval_start = NULL;
4515 case LEX_INTERPCONCAT:
4517 if (PL_lex_brackets)
4518 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4519 (long) PL_lex_brackets);
4521 if (PL_bufptr == PL_bufend)
4522 return REPORT(sublex_done());
4524 /* m'foo' still needs to be parsed for possible (?{...}) */
4525 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4526 SV *sv = newSVsv(PL_linestr);
4528 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4532 s = scan_const(PL_bufptr);
4534 PL_lex_state = LEX_INTERPCASEMOD;
4536 PL_lex_state = LEX_INTERPSTART;
4539 if (s != PL_bufptr) {
4540 NEXTVAL_NEXTTOKE = pl_yylval;
4543 if (PL_lex_starts++) {
4544 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4545 if (!PL_lex_casemods && PL_lex_inpat)
4548 AopNOASSIGN(OP_CONCAT);
4558 s = scan_formline(PL_bufptr);
4559 if (!PL_lex_formbrack)
4568 /* We really do *not* want PL_linestr ever becoming a COW. */
4569 assert (!SvIsCOW(PL_linestr));
4571 PL_oldoldbufptr = PL_oldbufptr;
4573 PL_parser->saw_infix_sigil = 0;
4578 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4581 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4582 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4584 SVs_TEMP | SVf_UTF8),
4585 10, UNI_DISPLAY_ISPRINT)
4586 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4587 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4588 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4589 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4593 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4594 UTF8fARG(UTF, (s - d), d),
4599 goto fake_eof; /* emulate EOF on ^D or ^Z */
4601 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4604 if (PL_lex_brackets &&
4605 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4606 yyerror((const char *)
4608 ? "Format not terminated"
4609 : "Missing right curly or square bracket"));
4611 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4612 "### Tokener got EOF\n");
4616 if (s++ < PL_bufend)
4617 goto retry; /* ignore stray nulls */
4620 if (!PL_in_eval && !PL_preambled) {
4621 PL_preambled = TRUE;
4623 /* Generate a string of Perl code to load the debugger.
4624 * If PERL5DB is set, it will return the contents of that,
4625 * otherwise a compile-time require of perl5db.pl. */
4627 const char * const pdb = PerlEnv_getenv("PERL5DB");
4630 sv_setpv(PL_linestr, pdb);
4631 sv_catpvs(PL_linestr,";");
4633 SETERRNO(0,SS_NORMAL);
4634 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4636 PL_parser->preambling = CopLINE(PL_curcop);
4638 sv_setpvs(PL_linestr,"");
4639 if (PL_preambleav) {
4640 SV **svp = AvARRAY(PL_preambleav);
4641 SV **const end = svp + AvFILLp(PL_preambleav);
4643 sv_catsv(PL_linestr, *svp);
4645 sv_catpvs(PL_linestr, ";");
4647 sv_free(MUTABLE_SV(PL_preambleav));
4648 PL_preambleav = NULL;
4651 sv_catpvs(PL_linestr,
4652 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4653 if (PL_minus_n || PL_minus_p) {
4654 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4656 sv_catpvs(PL_linestr,"chomp;");
4659 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4660 || *PL_splitstr == '"')
4661 && strchr(PL_splitstr + 1, *PL_splitstr))
4662 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4664 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4665 bytes can be used as quoting characters. :-) */
4666 const char *splits = PL_splitstr;
4667 sv_catpvs(PL_linestr, "our @F=split(q\0");
4670 if (*splits == '\\')
4671 sv_catpvn(PL_linestr, splits, 1);
4672 sv_catpvn(PL_linestr, splits, 1);
4673 } while (*splits++);
4674 /* This loop will embed the trailing NUL of
4675 PL_linestr as the last thing it does before
4677 sv_catpvs(PL_linestr, ");");
4681 sv_catpvs(PL_linestr,"our @F=split(' ');");
4684 sv_catpvs(PL_linestr, "\n");
4685 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4686 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4687 PL_last_lop = PL_last_uni = NULL;
4688 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4689 update_debugger_info(PL_linestr, NULL, 0);
4694 bof = PL_rsfp ? TRUE : FALSE;
4697 fake_eof = LEX_FAKE_EOF;
4699 PL_bufptr = PL_bufend;
4700 COPLINE_INC_WITH_HERELINES;
4701 if (!lex_next_chunk(fake_eof)) {
4702 CopLINE_dec(PL_curcop);
4704 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4706 CopLINE_dec(PL_curcop);
4708 /* If it looks like the start of a BOM or raw UTF-16,
4709 * check if it in fact is. */
4710 if (bof && PL_rsfp &&
4712 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4715 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4716 bof = (offset == (Off_t)SvCUR(PL_linestr));
4717 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4718 /* offset may include swallowed CR */
4720 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4723 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4724 s = swallow_bom((U8*)s);
4727 if (PL_parser->in_pod) {
4728 /* Incest with pod. */
4729 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4730 sv_setpvs(PL_linestr, "");
4731 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4732 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4733 PL_last_lop = PL_last_uni = NULL;
4734 PL_parser->in_pod = 0;
4737 if (PL_rsfp || PL_parser->filtered)
4739 } while (PL_parser->in_pod);
4740 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4741 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4742 PL_last_lop = PL_last_uni = NULL;
4743 if (CopLINE(PL_curcop) == 1) {
4744 while (s < PL_bufend && isSPACE(*s))
4746 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4750 if (*s == '#' && *(s+1) == '!')
4752 #ifdef ALTERNATE_SHEBANG
4754 static char const as[] = ALTERNATE_SHEBANG;
4755 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4756 d = s + (sizeof(as) - 1);
4758 #endif /* ALTERNATE_SHEBANG */
4767 while (*d && !isSPACE(*d))
4771 #ifdef ARG_ZERO_IS_SCRIPT
4772 if (ipathend > ipath) {
4774 * HP-UX (at least) sets argv[0] to the script name,
4775 * which makes $^X incorrect. And Digital UNIX and Linux,
4776 * at least, set argv[0] to the basename of the Perl
4777 * interpreter. So, having found "#!", we'll set it right.
4779 SV* copfilesv = CopFILESV(PL_curcop);
4782 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4784 assert(SvPOK(x) || SvGMAGICAL(x));
4785 if (sv_eq(x, copfilesv)) {
4786 sv_setpvn(x, ipath, ipathend - ipath);
4792 const char *bstart = SvPV_const(copfilesv, blen);
4793 const char * const lstart = SvPV_const(x, llen);
4795 bstart += blen - llen;
4796 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4797 sv_setpvn(x, ipath, ipathend - ipath);
4804 /* Anything to do if no copfilesv? */
4806 TAINT_NOT; /* $^X is always tainted, but that's OK */
4808 #endif /* ARG_ZERO_IS_SCRIPT */
4813 d = instr(s,"perl -");
4815 d = instr(s,"perl");
4817 /* avoid getting into infinite loops when shebang
4818 * line contains "Perl" rather than "perl" */
4820 for (d = ipathend-4; d >= ipath; --d) {
4821 if (isALPHA_FOLD_EQ(*d, 'p')
4822 && !ibcmp(d, "perl", 4))
4832 #ifdef ALTERNATE_SHEBANG
4834 * If the ALTERNATE_SHEBANG on this system starts with a
4835 * character that can be part of a Perl expression, then if
4836 * we see it but not "perl", we're probably looking at the
4837 * start of Perl code, not a request to hand off to some
4838 * other interpreter. Similarly, if "perl" is there, but
4839 * not in the first 'word' of the line, we assume the line
4840 * contains the start of the Perl program.
4842 if (d && *s != '#') {
4843 const char *c = ipath;
4844 while (*c && !strchr("; \t\r\n\f\v#", *c))
4847 d = NULL; /* "perl" not in first word; ignore */
4849 *s = '#'; /* Don't try to parse shebang line */
4851 #endif /* ALTERNATE_SHEBANG */
4856 !instr(s,"indir") &&
4857 instr(PL_origargv[0],"perl"))
4864 while (s < PL_bufend && isSPACE(*s))
4866 if (s < PL_bufend) {
4867 Newx(newargv,PL_origargc+3,char*);
4869 while (s < PL_bufend && !isSPACE(*s))
4872 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4875 newargv = PL_origargv;
4878 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4880 Perl_croak(aTHX_ "Can't exec %s", ipath);
4883 while (*d && !isSPACE(*d))
4885 while (SPACE_OR_TAB(*d))
4889 const bool switches_done = PL_doswitches;
4890 const U32 oldpdb = PL_perldb;
4891 const bool oldn = PL_minus_n;
4892 const bool oldp = PL_minus_p;
4896 bool baduni = FALSE;
4898 const char *d2 = d1 + 1;
4899 if (parse_unicode_opts((const char **)&d2)
4903 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4904 const char * const m = d1;
4905 while (*d1 && !isSPACE(*d1))
4907 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4910 d1 = moreswitches(d1);
4912 if (PL_doswitches && !switches_done) {
4913 int argc = PL_origargc;
4914 char **argv = PL_origargv;
4917 } while (argc && argv[0][0] == '-' && argv[0][1]);
4918 init_argv_symbols(argc,argv);
4920 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4921 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4922 /* if we have already added "LINE: while (<>) {",
4923 we must not do it again */
4925 sv_setpvs(PL_linestr, "");
4926 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4927 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4928 PL_last_lop = PL_last_uni = NULL;
4929 PL_preambled = FALSE;
4930 if (PERLDB_LINE || PERLDB_SAVESRC)
4931 (void)gv_fetchfile(PL_origfilename);
4938 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4939 PL_lex_state = LEX_FORMLINE;
4940 NEXTVAL_NEXTTOKE.ival = 0;
4941 force_next(FORMRBRACK);
4946 #ifdef PERL_STRICT_CR
4947 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4949 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4951 case ' ': case '\t': case '\f': case 013:
4956 if (PL_lex_state != LEX_NORMAL ||
4957 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
4958 const bool in_comment = *s == '#';
4959 if (*s == '#' && s == PL_linestart && PL_in_eval
4960 && !PL_rsfp && !PL_parser->filtered) {
4961 /* handle eval qq[#line 1 "foo"\n ...] */
4962 CopLINE_dec(PL_curcop);
4966 while (d < PL_bufend && *d != '\n')
4970 else if (d > PL_bufend)
4971 /* Found by Ilya: feed random input to Perl. */
4972 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
4975 if (in_comment && d == PL_bufend
4976 && PL_lex_state == LEX_INTERPNORMAL
4977 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
4978 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
4981 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4982 PL_lex_state = LEX_FORMLINE;
4983 NEXTVAL_NEXTTOKE.ival = 0;
4984 force_next(FORMRBRACK);
4989 while (s < PL_bufend && *s != '\n')
4997 else if (s > PL_bufend)
4998 /* Found by Ilya: feed random input to Perl. */
4999 Perl_croak(aTHX_ "panic: input overflow");
5003 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5011 while (s < PL_bufend && SPACE_OR_TAB(*s))
5014 if (strnEQ(s,"=>",2)) {
5015 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5016 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5017 OPERATOR('-'); /* unary minus */
5020 case 'r': ftst = OP_FTEREAD; break;
5021 case 'w': ftst = OP_FTEWRITE; break;
5022 case 'x': ftst = OP_FTEEXEC; break;
5023 case 'o': ftst = OP_FTEOWNED; break;
5024 case 'R': ftst = OP_FTRREAD; break;
5025 case 'W': ftst = OP_FTRWRITE; break;
5026 case 'X': ftst = OP_FTREXEC; break;
5027 case 'O': ftst = OP_FTROWNED; break;
5028 case 'e': ftst = OP_FTIS; break;
5029 case 'z': ftst = OP_FTZERO; break;
5030 case 's': ftst = OP_FTSIZE; break;
5031 case 'f': ftst = OP_FTFILE; break;
5032 case 'd': ftst = OP_FTDIR; break;
5033 case 'l': ftst = OP_FTLINK; break;
5034 case 'p': ftst = OP_FTPIPE; break;
5035 case 'S': ftst = OP_FTSOCK; break;
5036 case 'u': ftst = OP_FTSUID; break;
5037 case 'g': ftst = OP_FTSGID; break;
5038 case 'k': ftst = OP_FTSVTX; break;
5039 case 'b': ftst = OP_FTBLK; break;
5040 case 'c': ftst = OP_FTCHR; break;
5041 case 't': ftst = OP_FTTTY; break;
5042 case 'T': ftst = OP_FTTEXT; break;
5043 case 'B': ftst = OP_FTBINARY; break;
5044 case 'M': case 'A': case 'C':
5045 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5047 case 'M': ftst = OP_FTMTIME; break;
5048 case 'A': ftst = OP_FTATIME; break;
5049 case 'C': ftst = OP_FTCTIME; break;
5057 PL_last_uni = PL_oldbufptr;
5058 PL_last_lop_op = (OPCODE)ftst;
5059 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5060 "### Saw file test %c\n", (int)tmp);
5065 /* Assume it was a minus followed by a one-letter named
5066 * subroutine call (or a -bareword), then. */
5067 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5068 "### '-%c' looked like a file test but was not\n",
5075 const char tmp = *s++;
5078 if (PL_expect == XOPERATOR)
5083 else if (*s == '>') {
5086 if (FEATURE_POSTDEREF_IS_ENABLED && (
5087 ((*s == '$' || *s == '&') && s[1] == '*')
5088 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5089 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5090 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5093 Perl_ck_warner_d(aTHX_
5094 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5095 "Postfix dereference is experimental"
5097 PL_expect = XPOSTDEREF;
5100 if (isIDFIRST_lazy_if(s,UTF)) {
5101 s = force_word(s,METHOD,FALSE,TRUE);
5109 if (PL_expect == XOPERATOR) {
5110 if (*s == '=' && !PL_lex_allbrackets &&
5111 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5118 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5120 OPERATOR('-'); /* unary minus */
5126 const char tmp = *s++;
5129 if (PL_expect == XOPERATOR)
5134 if (PL_expect == XOPERATOR) {
5135 if (*s == '=' && !PL_lex_allbrackets &&
5136 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5143 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5150 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5151 if (PL_expect != XOPERATOR) {
5152 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5153 PL_expect = XOPERATOR;
5154 force_ident(PL_tokenbuf, '*');
5162 if (*s == '=' && !PL_lex_allbrackets &&
5163 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5169 if (*s == '=' && !PL_lex_allbrackets &&
5170 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5174 PL_parser->saw_infix_sigil = 1;
5179 if (PL_expect == XOPERATOR) {
5180 if (s[1] == '=' && !PL_lex_allbrackets &&
5181 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5184 PL_parser->saw_infix_sigil = 1;
5187 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5188 PL_tokenbuf[0] = '%';
5189 s = scan_ident(s, PL_tokenbuf + 1,
5190 sizeof PL_tokenbuf - 1, FALSE);
5192 if (!PL_tokenbuf[1]) {
5195 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5197 PL_tokenbuf[0] = '@';
5199 PL_expect = XOPERATOR;
5200 force_ident_maybe_lex('%');
5204 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5205 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5210 if (PL_lex_brackets > 100)
5211 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5212 PL_lex_brackstack[PL_lex_brackets++] = 0;
5213 PL_lex_allbrackets++;
5215 const char tmp = *s++;
5220 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5222 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5225 Perl_ck_warner_d(aTHX_
5226 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5227 "Smartmatch is experimental");
5233 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5240 goto just_a_word_zero_gv;
5246 switch (PL_expect) {
5248 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5250 PL_bufptr = s; /* update in case we back off */
5253 "Use of := for an empty attribute list is not allowed");
5260 PL_expect = XTERMBLOCK;
5264 while (isIDFIRST_lazy_if(s,UTF)) {
5267 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5268 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5269 if (tmp < 0) tmp = -tmp;
5284 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5286 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5287 COPLINE_SET_FROM_MULTI_END;
5289 /* MUST advance bufptr here to avoid bogus
5290 "at end of line" context messages from yyerror().
5292 PL_bufptr = s + len;
5293 yyerror("Unterminated attribute parameter in attribute list");
5297 return REPORT(0); /* EOF indicator */
5301 sv_catsv(sv, PL_lex_stuff);
5302 attrs = op_append_elem(OP_LIST, attrs,
5303 newSVOP(OP_CONST, 0, sv));
5304 SvREFCNT_dec(PL_lex_stuff);
5305 PL_lex_stuff = NULL;
5308 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5310 if (PL_in_my == KEY_our) {
5311 deprecate(":unique");
5314 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5317 /* NOTE: any CV attrs applied here need to be part of
5318 the CVf_BUILTIN_ATTRS define in cv.h! */
5319 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5321 CvLVALUE_on(PL_compcv);
5323 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5325 deprecate(":locked");
5327 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5329 CvMETHOD_on(PL_compcv);
5331 /* After we've set the flags, it could be argued that
5332 we don't need to do the attributes.pm-based setting
5333 process, and shouldn't bother appending recognized
5334 flags. To experiment with that, uncomment the
5335 following "else". (Note that's already been
5336 uncommented. That keeps the above-applied built-in
5337 attributes from being intercepted (and possibly
5338 rejected) by a package's attribute routines, but is
5339 justified by the performance win for the common case
5340 of applying only built-in attributes.) */
5342 attrs = op_append_elem(OP_LIST, attrs,
5343 newSVOP(OP_CONST, 0,
5347 if (*s == ':' && s[1] != ':')
5350 break; /* require real whitespace or :'s */
5351 /* XXX losing whitespace on sequential attributes here */
5354 if (*s != ';' && *s != '}' &&
5355 !(PL_expect == XOPERATOR
5356 ? (*s == '=' || *s == ')')
5357 : (*s == '{' || *s == '('))) {
5358 const char q = ((*s == '\'') ? '"' : '\'');
5359 /* If here for an expression, and parsed no attrs, back
5361 if (PL_expect == XOPERATOR && !attrs) {
5365 /* MUST advance bufptr here to avoid bogus "at end of line"
5366 context messages from yyerror().
5369 yyerror( (const char *)
5371 ? Perl_form(aTHX_ "Invalid separator character "
5372 "%c%c%c in attribute list", q, *s, q)
5373 : "Unterminated attribute list" ) );
5381 NEXTVAL_NEXTTOKE.opval = attrs;
5387 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5391 PL_lex_allbrackets--;
5395 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5396 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5400 PL_lex_allbrackets++;
5403 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5410 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5413 PL_lex_allbrackets--;
5419 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5422 if (PL_lex_brackets <= 0)
5423 /* diag_listed_as: Unmatched right %s bracket */
5424 yyerror("Unmatched right square bracket");
5427 PL_lex_allbrackets--;
5428 if (PL_lex_state == LEX_INTERPNORMAL) {
5429 if (PL_lex_brackets == 0) {
5430 if (*s == '-' && s[1] == '>')
5431 PL_lex_state = LEX_INTERPENDMAYBE;
5432 else if (*s != '[' && *s != '{')
5433 PL_lex_state = LEX_INTERPEND;
5440 if (PL_lex_brackets > 100) {
5441 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5443 switch (PL_expect) {
5445 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5446 PL_lex_allbrackets++;
5447 OPERATOR(HASHBRACK);
5449 while (s < PL_bufend && SPACE_OR_TAB(*s))
5452 PL_tokenbuf[0] = '\0';
5453 if (d < PL_bufend && *d == '-') {
5454 PL_tokenbuf[0] = '-';
5456 while (d < PL_bufend && SPACE_OR_TAB(*d))
5459 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5460 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5462 while (d < PL_bufend && SPACE_OR_TAB(*d))
5465 const char minus = (PL_tokenbuf[0] == '-');
5466 s = force_word(s + minus, WORD, FALSE, TRUE);
5474 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5475 PL_lex_allbrackets++;
5480 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5481 PL_lex_allbrackets++;
5485 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5486 PL_lex_allbrackets++;
5491 if (PL_oldoldbufptr == PL_last_lop)
5492 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5494 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5495 PL_lex_allbrackets++;
5498 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5500 /* This hack is to get the ${} in the message. */
5502 yyerror("syntax error");
5505 OPERATOR(HASHBRACK);
5507 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5508 /* ${...} or @{...} etc., but not print {...}
5509 * Skip the disambiguation and treat this as a block.
5511 goto block_expectation;
5513 /* This hack serves to disambiguate a pair of curlies
5514 * as being a block or an anon hash. Normally, expectation
5515 * determines that, but in cases where we're not in a
5516 * position to expect anything in particular (like inside
5517 * eval"") we have to resolve the ambiguity. This code
5518 * covers the case where the first term in the curlies is a
5519 * quoted string. Most other cases need to be explicitly
5520 * disambiguated by prepending a "+" before the opening
5521 * curly in order to force resolution as an anon hash.
5523 * XXX should probably propagate the outer expectation
5524 * into eval"" to rely less on this hack, but that could
5525 * potentially break current behavior of eval"".
5529 if (*s == '\'' || *s == '"' || *s == '`') {
5530 /* common case: get past first string, handling escapes */
5531 for (t++; t < PL_bufend && *t != *s;)
5536 else if (*s == 'q') {
5539 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5540 && !isWORDCHAR(*t))))
5542 /* skip q//-like construct */
5544 char open, close, term;
5547 while (t < PL_bufend && isSPACE(*t))
5549 /* check for q => */
5550 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5551 OPERATOR(HASHBRACK);
5555 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5559 for (t++; t < PL_bufend; t++) {
5560 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5562 else if (*t == open)
5566 for (t++; t < PL_bufend; t++) {
5567 if (*t == '\\' && t+1 < PL_bufend)
5569 else if (*t == close && --brackets <= 0)
5571 else if (*t == open)
5578 /* skip plain q word */
5579 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5582 else if (isWORDCHAR_lazy_if(t,UTF)) {
5584 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5587 while (t < PL_bufend && isSPACE(*t))
5589 /* if comma follows first term, call it an anon hash */
5590 /* XXX it could be a comma expression with loop modifiers */
5591 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5592 || (*t == '=' && t[1] == '>')))
5593 OPERATOR(HASHBRACK);
5594 if (PL_expect == XREF)
5597 /* If there is an opening brace or 'sub:', treat it
5598 as a term to make ${{...}}{k} and &{sub:attr...}
5599 dwim. Otherwise, treat it as a statement, so
5600 map {no strict; ...} works.
5607 if (strnEQ(s, "sub", 3)) {
5618 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5624 pl_yylval.ival = CopLINE(PL_curcop);
5625 PL_copline = NOLINE; /* invalidate current command line number */
5626 TOKEN(formbrack ? '=' : '{');
5628 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5632 if (PL_lex_brackets <= 0)
5633 /* diag_listed_as: Unmatched right %s bracket */
5634 yyerror("Unmatched right curly bracket");
5636 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5637 PL_lex_allbrackets--;
5638 if (PL_lex_state == LEX_INTERPNORMAL) {
5639 if (PL_lex_brackets == 0) {
5640 if (PL_expect & XFAKEBRACK) {
5641 PL_expect &= XENUMMASK;
5642 PL_lex_state = LEX_INTERPEND;
5644 return yylex(); /* ignore fake brackets */
5646 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5647 && SvEVALED(PL_lex_repl))
5648 PL_lex_state = LEX_INTERPEND;
5649 else if (*s == '-' && s[1] == '>')
5650 PL_lex_state = LEX_INTERPENDMAYBE;
5651 else if (*s != '[' && *s != '{')
5652 PL_lex_state = LEX_INTERPEND;
5655 if (PL_expect & XFAKEBRACK) {
5656 PL_expect &= XENUMMASK;
5658 return yylex(); /* ignore fake brackets */
5660 force_next(formbrack ? '.' : '}');
5661 if (formbrack) LEAVE;
5662 if (formbrack == 2) { /* means . where arguments were expected */
5668 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5671 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5672 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5679 if (PL_expect == XOPERATOR) {
5680 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5681 && isIDFIRST_lazy_if(s,UTF))
5683 CopLINE_dec(PL_curcop);
5684 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5685 CopLINE_inc(PL_curcop);
5687 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5688 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5692 PL_parser->saw_infix_sigil = 1;
5696 PL_tokenbuf[0] = '&';
5697 s = scan_ident(s - 1, PL_tokenbuf + 1,
5698 sizeof PL_tokenbuf - 1, TRUE);
5699 if (PL_tokenbuf[1]) {
5700 PL_expect = XOPERATOR;
5701 force_ident_maybe_lex('&');
5705 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5711 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5712 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5719 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5720 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5728 const char tmp = *s++;
5730 if (!PL_lex_allbrackets &&
5731 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5738 if (!PL_lex_allbrackets &&
5739 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5747 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5748 && strchr("+-*/%.^&|<",tmp))
5749 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5750 "Reversed %c= operator",(int)tmp);
5752 if (PL_expect == XSTATE && isALPHA(tmp) &&
5753 (s == PL_linestart+1 || s[-2] == '\n') )
5755 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5756 || PL_lex_state != LEX_NORMAL) {
5761 if (strnEQ(s,"=cut",4)) {
5775 PL_parser->in_pod = 1;
5779 if (PL_expect == XBLOCK) {
5781 #ifdef PERL_STRICT_CR
5782 while (SPACE_OR_TAB(*t))
5784 while (SPACE_OR_TAB(*t) || *t == '\r')
5787 if (*t == '\n' || *t == '#') {
5790 SAVEI8(PL_parser->form_lex_state);
5791 SAVEI32(PL_lex_formbrack);
5792 PL_parser->form_lex_state = PL_lex_state;
5793 PL_lex_formbrack = PL_lex_brackets + 1;
5797 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5806 const char tmp = *s++;
5808 /* was this !=~ where !~ was meant?
5809 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5811 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5812 const char *t = s+1;
5814 while (t < PL_bufend && isSPACE(*t))
5817 if (*t == '/' || *t == '?' ||
5818 ((*t == 'm' || *t == 's' || *t == 'y')
5819 && !isWORDCHAR(t[1])) ||
5820 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5821 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5822 "!=~ should be !~");
5824 if (!PL_lex_allbrackets &&
5825 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5837 if (PL_expect != XOPERATOR) {
5838 if (s[1] != '<' && !strchr(s,'>'))
5840 if (s[1] == '<' && s[2] != '>')
5841 s = scan_heredoc(s);
5843 s = scan_inputsymbol(s);
5844 PL_expect = XOPERATOR;
5845 TOKEN(sublex_start());
5851 if (*s == '=' && !PL_lex_allbrackets &&
5852 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5856 SHop(OP_LEFT_SHIFT);
5861 if (!PL_lex_allbrackets &&
5862 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5869 if (!PL_lex_allbrackets &&
5870 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5878 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5886 const char tmp = *s++;
5888 if (*s == '=' && !PL_lex_allbrackets &&
5889 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5893 SHop(OP_RIGHT_SHIFT);
5895 else if (tmp == '=') {
5896 if (!PL_lex_allbrackets &&
5897 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5905 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5914 if (PL_expect == XOPERATOR) {
5915 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5916 return deprecate_commaless_var_list();
5919 else if (PL_expect == XPOSTDEREF) {
5922 POSTDEREF(DOLSHARP);
5927 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
5928 PL_tokenbuf[0] = '@';
5929 s = scan_ident(s + 1, PL_tokenbuf + 1,
5930 sizeof PL_tokenbuf - 1, FALSE);
5931 if (PL_expect == XOPERATOR)
5932 no_op("Array length", s);
5933 if (!PL_tokenbuf[1])
5935 PL_expect = XOPERATOR;
5936 force_ident_maybe_lex('#');
5940 PL_tokenbuf[0] = '$';
5941 s = scan_ident(s, PL_tokenbuf + 1,
5942 sizeof PL_tokenbuf - 1, FALSE);
5943 if (PL_expect == XOPERATOR)
5945 if (!PL_tokenbuf[1]) {
5947 yyerror("Final $ should be \\$ or $name");
5953 const char tmp = *s;
5954 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5957 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5958 && intuit_more(s)) {
5960 PL_tokenbuf[0] = '@';
5961 if (ckWARN(WARN_SYNTAX)) {
5964 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
5967 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
5968 while (t < PL_bufend && *t != ']')
5970 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5971 "Multidimensional syntax %.*s not supported",
5972 (int)((t - PL_bufptr) + 1), PL_bufptr);
5976 else if (*s == '{') {
5978 PL_tokenbuf[0] = '%';
5979 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
5980 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
5982 char tmpbuf[sizeof PL_tokenbuf];
5985 } while (isSPACE(*t));
5986 if (isIDFIRST_lazy_if(t,UTF)) {
5988 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5993 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
5994 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5995 "You need to quote \"%"UTF8f"\"",
5996 UTF8fARG(UTF, len, tmpbuf));
6002 PL_expect = XOPERATOR;
6003 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6004 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6005 if (!islop || PL_last_lop_op == OP_GREPSTART)
6006 PL_expect = XOPERATOR;
6007 else if (strchr("$@\"'`q", *s))
6008 PL_expect = XTERM; /* e.g. print $fh "foo" */
6009 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6010 PL_expect = XTERM; /* e.g. print $fh &sub */
6011 else if (isIDFIRST_lazy_if(s,UTF)) {
6012 char tmpbuf[sizeof PL_tokenbuf];
6014 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6015 if ((t2 = keyword(tmpbuf, len, 0))) {
6016 /* binary operators exclude handle interpretations */
6028 PL_expect = XTERM; /* e.g. print $fh length() */
6033 PL_expect = XTERM; /* e.g. print $fh subr() */
6036 else if (isDIGIT(*s))
6037 PL_expect = XTERM; /* e.g. print $fh 3 */
6038 else if (*s == '.' && isDIGIT(s[1]))
6039 PL_expect = XTERM; /* e.g. print $fh .3 */
6040 else if ((*s == '?' || *s == '-' || *s == '+')
6041 && !isSPACE(s[1]) && s[1] != '=')
6042 PL_expect = XTERM; /* e.g. print $fh -1 */
6043 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6045 PL_expect = XTERM; /* e.g. print $fh /.../
6046 XXX except DORDOR operator
6048 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6050 PL_expect = XTERM; /* print $fh <<"EOF" */
6053 force_ident_maybe_lex('$');
6057 if (PL_expect == XOPERATOR)
6059 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6060 PL_tokenbuf[0] = '@';
6061 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6063 if (!PL_tokenbuf[1]) {
6066 if (PL_lex_state == LEX_NORMAL)
6068 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6070 PL_tokenbuf[0] = '%';
6072 /* Warn about @ where they meant $. */
6073 if (*s == '[' || *s == '{') {
6074 if (ckWARN(WARN_SYNTAX)) {
6075 S_check_scalar_slice(aTHX_ s);
6079 PL_expect = XOPERATOR;
6080 force_ident_maybe_lex('@');
6083 case '/': /* may be division, defined-or, or pattern */
6084 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6085 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6086 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6091 else if (PL_expect == XOPERATOR) {
6093 if (*s == '=' && !PL_lex_allbrackets &&
6094 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6101 /* Disable warning on "study /blah/" */
6102 if (PL_oldoldbufptr == PL_last_uni
6103 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6104 || memNE(PL_last_uni, "study", 5)
6105 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6108 s = scan_pat(s,OP_MATCH);
6109 TERM(sublex_start());
6112 case '?': /* conditional */
6114 if (!PL_lex_allbrackets &&
6115 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6119 PL_lex_allbrackets++;
6123 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6124 #ifdef PERL_STRICT_CR
6127 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6129 && (s == PL_linestart || s[-1] == '\n') )
6132 formbrack = 2; /* dot seen where arguments expected */
6135 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6139 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6142 if (!PL_lex_allbrackets &&
6143 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6150 pl_yylval.ival = OPf_SPECIAL;
6156 if (*s == '=' && !PL_lex_allbrackets &&
6157 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6164 case '0': case '1': case '2': case '3': case '4':
6165 case '5': case '6': case '7': case '8': case '9':
6166 s = scan_num(s, &pl_yylval);
6167 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6168 if (PL_expect == XOPERATOR)
6173 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6176 COPLINE_SET_FROM_MULTI_END;
6177 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6178 if (PL_expect == XOPERATOR) {
6179 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6180 return deprecate_commaless_var_list();
6185 pl_yylval.ival = OP_CONST;
6186 TERM(sublex_start());
6189 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6192 printbuf("### Saw string before %s\n", s);
6194 PerlIO_printf(Perl_debug_log,
6195 "### Saw unterminated string\n");
6197 if (PL_expect == XOPERATOR) {
6198 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6199 return deprecate_commaless_var_list();
6206 pl_yylval.ival = OP_CONST;
6207 /* FIXME. I think that this can be const if char *d is replaced by
6208 more localised variables. */
6209 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6210 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6211 pl_yylval.ival = OP_STRINGIFY;
6215 if (pl_yylval.ival == OP_CONST)
6216 COPLINE_SET_FROM_MULTI_END;
6217 TERM(sublex_start());
6220 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6221 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6222 if (PL_expect == XOPERATOR)
6223 no_op("Backticks",s);
6226 pl_yylval.ival = OP_BACKTICK;
6227 TERM(sublex_start());
6231 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6233 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6235 if (PL_expect == XOPERATOR)
6236 no_op("Backslash",s);
6240 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6241 char *start = s + 2;
6242 while (isDIGIT(*start) || *start == '_')
6244 if (*start == '.' && isDIGIT(start[1])) {
6245 s = scan_num(s, &pl_yylval);
6248 else if ((*start == ':' && start[1] == ':')
6249 || (PL_expect == XSTATE && *start == ':'))
6251 else if (PL_expect == XSTATE) {
6253 while (d < PL_bufend && isSPACE(*d)) d++;
6254 if (*d == ':') goto keylookup;
6256 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6257 if (!isALPHA(*start) && (PL_expect == XTERM
6258 || PL_expect == XREF || PL_expect == XSTATE
6259 || PL_expect == XTERMORDORDOR)) {
6260 GV *const gv = gv_fetchpvn_flags(s, start - s,
6261 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6263 s = scan_num(s, &pl_yylval);
6270 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6323 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6325 /* Some keywords can be followed by any delimiter, including ':' */
6326 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6328 /* x::* is just a word, unless x is "CORE" */
6329 if (!anydelim && *s == ':' && s[1] == ':') {
6330 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6335 while (d < PL_bufend && isSPACE(*d))
6336 d++; /* no comments skipped here, or s### is misparsed */
6338 /* Is this a word before a => operator? */
6339 if (*d == '=' && d[1] == '>') {
6343 = (OP*)newSVOP(OP_CONST, 0,
6344 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6345 pl_yylval.opval->op_private = OPpCONST_BARE;
6349 /* Check for plugged-in keyword */
6353 char *saved_bufptr = PL_bufptr;
6355 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6357 if (result == KEYWORD_PLUGIN_DECLINE) {
6358 /* not a plugged-in keyword */
6359 PL_bufptr = saved_bufptr;
6360 } else if (result == KEYWORD_PLUGIN_STMT) {
6361 pl_yylval.opval = o;
6363 if (!PL_nexttoke) PL_expect = XSTATE;
6364 return REPORT(PLUGSTMT);
6365 } else if (result == KEYWORD_PLUGIN_EXPR) {
6366 pl_yylval.opval = o;
6368 if (!PL_nexttoke) PL_expect = XOPERATOR;
6369 return REPORT(PLUGEXPR);
6371 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6376 /* Check for built-in keyword */
6377 tmp = keyword(PL_tokenbuf, len, 0);
6379 /* Is this a label? */
6380 if (!anydelim && PL_expect == XSTATE
6381 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6383 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6384 pl_yylval.pval[len] = '\0';
6385 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6390 /* Check for lexical sub */
6391 if (PL_expect != XOPERATOR) {
6392 char tmpbuf[sizeof PL_tokenbuf + 1];
6394 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6395 off = pad_findmy_pvn(tmpbuf, len+1, 0);
6396 if (off != NOT_IN_PAD) {
6397 assert(off); /* we assume this is boolean-true below */
6398 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6399 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6400 HEK * const stashname = HvNAME_HEK(stash);
6401 sv = newSVhek(stashname);
6402 sv_catpvs(sv, "::");
6403 sv_catpvn_flags(sv, PL_tokenbuf, len,
6404 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6405 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6415 rv2cv_op = newOP(OP_PADANY, 0);
6416 rv2cv_op->op_targ = off;
6417 cv = find_lexical_cv(off);
6425 if (tmp < 0) { /* second-class keyword? */
6426 GV *ogv = NULL; /* override (winner) */
6427 GV *hgv = NULL; /* hidden (loser) */
6428 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6430 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6431 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6435 if (GvIMPORTED_CV(gv))
6437 else if (! CvMETHOD(cv))
6441 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6445 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6446 : SvPCS_IMPORTED(gv)
6447 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6456 tmp = 0; /* overridden by import or by GLOBAL */
6459 && -tmp==KEY_lock /* XXX generalizable kludge */
6462 tmp = 0; /* any sub overrides "weak" keyword */
6464 else { /* no override */
6466 if (tmp == KEY_dump) {
6467 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6468 "dump() better written as CORE::dump()");
6472 if (hgv && tmp != KEY_x) /* never ambiguous */
6473 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6474 "Ambiguous call resolved as CORE::%s(), "
6475 "qualify as such or use &",
6480 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6481 && (!anydelim || *s != '#')) {
6482 /* no override, and not s### either; skipspace is safe here
6483 * check for => on following line */
6485 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6486 STRLEN soff = s - SvPVX(PL_linestr);
6487 s = skipspace_flags(s, LEX_NO_INCLINE);
6488 arrow = *s == '=' && s[1] == '>';
6489 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6490 s = SvPVX(PL_linestr) + soff;
6498 default: /* not a keyword */
6499 /* Trade off - by using this evil construction we can pull the
6500 variable gv into the block labelled keylookup. If not, then
6501 we have to give it function scope so that the goto from the
6502 earlier ':' case doesn't bypass the initialisation. */
6504 just_a_word_zero_gv:
6516 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6520 /* Get the rest if it looks like a package qualifier */
6522 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6524 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6527 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6528 UTF8fARG(UTF, len, PL_tokenbuf),
6529 *s == '\'' ? "'" : "::");
6534 if (PL_expect == XOPERATOR) {
6535 if (PL_bufptr == PL_linestart) {
6536 CopLINE_dec(PL_curcop);
6537 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6538 CopLINE_inc(PL_curcop);
6541 no_op("Bareword",s);
6544 /* See if the name is "Foo::",
6545 in which case Foo is a bareword
6546 (and a package name). */
6549 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6551 if (ckWARN(WARN_BAREWORD)
6552 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6553 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6554 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6555 UTF8fARG(UTF, len, PL_tokenbuf));
6557 PL_tokenbuf[len] = '\0';
6566 /* if we saw a global override before, get the right name */
6569 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6572 SV * const tmp_sv = sv;
6573 sv = newSVpvs("CORE::GLOBAL::");
6574 sv_catsv(sv, tmp_sv);
6575 SvREFCNT_dec(tmp_sv);
6579 /* Presume this is going to be a bareword of some sort. */
6581 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6582 pl_yylval.opval->op_private = OPpCONST_BARE;
6584 /* And if "Foo::", then that's what it certainly is. */
6590 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6591 const_op->op_private = OPpCONST_BARE;
6593 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6597 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6600 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6603 /* Use this var to track whether intuit_method has been
6604 called. intuit_method returns 0 or > 255. */
6607 /* See if it's the indirect object for a list operator. */
6609 if (PL_oldoldbufptr &&
6610 PL_oldoldbufptr < PL_bufptr &&
6611 (PL_oldoldbufptr == PL_last_lop
6612 || PL_oldoldbufptr == PL_last_uni) &&
6613 /* NO SKIPSPACE BEFORE HERE! */
6614 (PL_expect == XREF ||
6615 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6617 bool immediate_paren = *s == '(';
6619 /* (Now we can afford to cross potential line boundary.) */
6622 /* Two barewords in a row may indicate method call. */
6624 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6625 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6629 /* If not a declared subroutine, it's an indirect object. */
6630 /* (But it's an indir obj regardless for sort.) */
6631 /* Also, if "_" follows a filetest operator, it's a bareword */
6634 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6636 (PL_last_lop_op != OP_MAPSTART &&
6637 PL_last_lop_op != OP_GREPSTART))))
6638 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6639 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6642 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6647 PL_expect = XOPERATOR;
6650 /* Is this a word before a => operator? */
6651 if (*s == '=' && s[1] == '>' && !pkgname) {
6654 if (gvp || (lex && !off)) {
6655 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6656 /* This is our own scalar, created a few lines
6657 above, so this is safe. */
6659 sv_setpv(sv, PL_tokenbuf);
6660 if (UTF && !IN_BYTES
6661 && is_utf8_string((U8*)PL_tokenbuf, len))
6668 /* If followed by a paren, it's certainly a subroutine. */
6673 while (SPACE_OR_TAB(*d))
6675 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6680 NEXTVAL_NEXTTOKE.opval =
6681 off ? rv2cv_op : pl_yylval.opval;
6683 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6684 else op_free(rv2cv_op), force_next(WORD);
6689 /* If followed by var or block, call it a method (unless sub) */
6691 if ((*s == '$' || *s == '{') && !cv) {
6693 PL_last_lop = PL_oldbufptr;
6694 PL_last_lop_op = OP_METHOD;
6695 if (!PL_lex_allbrackets &&
6696 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6697 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6698 PL_expect = XBLOCKTERM;
6700 return REPORT(METHOD);
6703 /* If followed by a bareword, see if it looks like indir obj. */
6705 if (tmp == 1 && !orig_keyword
6706 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6707 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6710 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6712 sv_setpvn(sv, PL_tokenbuf, len);
6713 if (UTF && !IN_BYTES
6714 && is_utf8_string((U8*)PL_tokenbuf, len))
6716 else SvUTF8_off(sv);
6719 if (tmp == METHOD && !PL_lex_allbrackets &&
6720 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6721 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6725 /* Not a method, so call it a subroutine (if defined) */
6728 /* Check for a constant sub */
6729 if ((sv = cv_const_sv_or_av(cv))) {
6732 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6733 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6734 if (SvTYPE(sv) == SVt_PVAV)
6735 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6738 pl_yylval.opval->op_private = 0;
6739 pl_yylval.opval->op_folded = 1;
6740 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6745 op_free(pl_yylval.opval);
6747 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6748 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6749 PL_last_lop = PL_oldbufptr;
6750 PL_last_lop_op = OP_ENTERSUB;
6751 /* Is there a prototype? */
6755 STRLEN protolen = CvPROTOLEN(cv);
6756 const char *proto = CvPROTO(cv);
6758 proto = S_strip_spaces(aTHX_ proto, &protolen);
6761 if ((optional = *proto == ';'))
6764 while (*proto == ';');
6768 *proto == '$' || *proto == '_'
6769 || *proto == '*' || *proto == '+'
6774 *proto == '\\' && proto[1] && proto[2] == '\0'
6777 UNIPROTO(UNIOPSUB,optional);
6778 if (*proto == '\\' && proto[1] == '[') {
6779 const char *p = proto + 2;
6780 while(*p && *p != ']')
6782 if(*p == ']' && !p[1])
6783 UNIPROTO(UNIOPSUB,optional);
6785 if (*proto == '&' && *s == '{') {
6787 sv_setpvs(PL_subname, "__ANON__");
6789 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6790 if (!PL_lex_allbrackets &&
6791 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6792 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6796 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6798 force_next(off ? PRIVATEREF : WORD);
6799 if (!PL_lex_allbrackets &&
6800 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6801 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6805 /* Call it a bare word */
6807 if (PL_hints & HINT_STRICT_SUBS)
6808 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6811 /* after "print" and similar functions (corresponding to
6812 * "F? L" in opcode.pl), whatever wasn't already parsed as
6813 * a filehandle should be subject to "strict subs".
6814 * Likewise for the optional indirect-object argument to system
6815 * or exec, which can't be a bareword */
6816 if ((PL_last_lop_op == OP_PRINT
6817 || PL_last_lop_op == OP_PRTF
6818 || PL_last_lop_op == OP_SAY
6819 || PL_last_lop_op == OP_SYSTEM
6820 || PL_last_lop_op == OP_EXEC)
6821 && (PL_hints & HINT_STRICT_SUBS))
6822 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6823 if (lastchar != '-') {
6824 if (ckWARN(WARN_RESERVED)) {
6828 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6830 /* PL_warn_reserved is constant */
6831 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6832 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6842 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6843 && saw_infix_sigil) {
6844 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6845 "Operator or semicolon missing before %c%"UTF8f,
6847 UTF8fARG(UTF, strlen(PL_tokenbuf),
6849 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6850 "Ambiguous use of %c resolved as operator %c",
6851 lastchar, lastchar);
6858 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6863 (OP*)newSVOP(OP_CONST, 0,
6864 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6867 case KEY___PACKAGE__:
6869 (OP*)newSVOP(OP_CONST, 0,
6871 ? newSVhek(HvNAME_HEK(PL_curstash))
6878 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6879 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6882 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6884 gv_init(gv,stash,"DATA",4,0);
6887 GvIOp(gv) = newIO();
6888 IoIFP(GvIOp(gv)) = PL_rsfp;
6889 #if defined(HAS_FCNTL) && defined(F_SETFD)
6891 const int fd = PerlIO_fileno(PL_rsfp);
6892 fcntl(fd,F_SETFD,fd >= 3);
6895 /* Mark this internal pseudo-handle as clean */
6896 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6897 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6898 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6900 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6901 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6902 /* if the script was opened in binmode, we need to revert
6903 * it to text mode for compatibility; but only iff it has CRs
6904 * XXX this is a questionable hack at best. */
6905 if (PL_bufend-PL_bufptr > 2
6906 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6909 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6910 loc = PerlIO_tell(PL_rsfp);
6911 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6914 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6916 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6917 #endif /* NETWARE */
6919 PerlIO_seek(PL_rsfp, loc, 0);
6923 #ifdef PERLIO_LAYERS
6926 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6927 else if (IN_ENCODING) {
6933 XPUSHs(_get_encoding());
6935 call_method("name", G_SCALAR);
6939 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
6940 Perl_form(aTHX_ ":encoding(%"SVf")",
6953 FUN0OP(CvCLONE(PL_compcv)
6954 ? newOP(OP_RUNCV, 0)
6955 : newPVOP(OP_RUNCV,0,NULL));
6964 if (PL_expect == XSTATE) {
6975 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6976 if ((*s == ':' && s[1] == ':')
6977 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
6981 Copy(PL_bufptr, PL_tokenbuf, olen, char);
6985 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
6986 UTF8fARG(UTF, len, PL_tokenbuf));
6989 else if (tmp == KEY_require || tmp == KEY_do
6991 /* that's a way to remember we saw "CORE::" */
7003 LOP(OP_ACCEPT,XTERM);
7006 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7011 LOP(OP_ATAN2,XTERM);
7017 LOP(OP_BINMODE,XTERM);
7020 LOP(OP_BLESS,XTERM);
7029 /* We have to disambiguate the two senses of
7030 "continue". If the next token is a '{' then
7031 treat it as the start of a continue block;
7032 otherwise treat it as a control operator.
7042 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7052 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7061 if (!PL_cryptseen) {
7062 PL_cryptseen = TRUE;
7066 LOP(OP_CRYPT,XTERM);
7069 LOP(OP_CHMOD,XTERM);
7072 LOP(OP_CHOWN,XTERM);
7075 LOP(OP_CONNECT,XTERM);
7095 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7097 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7098 && !keyword(PL_tokenbuf + 1, len, 0)) {
7101 force_ident_maybe_lex('&');
7106 if (orig_keyword == KEY_do) {
7115 PL_hints |= HINT_BLOCK_SCOPE;
7125 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7126 STR_WITH_LEN("NDBM_File::"),
7127 STR_WITH_LEN("DB_File::"),
7128 STR_WITH_LEN("GDBM_File::"),
7129 STR_WITH_LEN("SDBM_File::"),
7130 STR_WITH_LEN("ODBM_File::"),
7132 LOP(OP_DBMOPEN,XTERM);
7144 pl_yylval.ival = CopLINE(PL_curcop);
7148 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7160 if (*s == '{') { /* block eval */
7161 PL_expect = XTERMBLOCK;
7162 UNIBRACK(OP_ENTERTRY);
7164 else { /* string eval */
7166 UNIBRACK(OP_ENTEREVAL);
7171 UNIBRACK(-OP_ENTEREVAL);
7185 case KEY_endhostent:
7191 case KEY_endservent:
7194 case KEY_endprotoent:
7205 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7207 pl_yylval.ival = CopLINE(PL_curcop);
7209 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7212 if ((PL_bufend - p) >= 3 &&
7213 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7215 else if ((PL_bufend - p) >= 4 &&
7216 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7219 /* skip optional package name, as in "for my abc $x (..)" */
7220 if (isIDFIRST_lazy_if(p,UTF)) {
7221 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7225 Perl_croak(aTHX_ "Missing $ on loop variable");
7230 LOP(OP_FORMLINE,XTERM);
7239 LOP(OP_FCNTL,XTERM);
7245 LOP(OP_FLOCK,XTERM);
7248 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7253 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7258 LOP(OP_GREPSTART, XREF);
7275 case KEY_getpriority:
7276 LOP(OP_GETPRIORITY,XTERM);
7278 case KEY_getprotobyname:
7281 case KEY_getprotobynumber:
7282 LOP(OP_GPBYNUMBER,XTERM);
7284 case KEY_getprotoent:
7296 case KEY_getpeername:
7297 UNI(OP_GETPEERNAME);
7299 case KEY_gethostbyname:
7302 case KEY_gethostbyaddr:
7303 LOP(OP_GHBYADDR,XTERM);
7305 case KEY_gethostent:
7308 case KEY_getnetbyname:
7311 case KEY_getnetbyaddr:
7312 LOP(OP_GNBYADDR,XTERM);
7317 case KEY_getservbyname:
7318 LOP(OP_GSBYNAME,XTERM);
7320 case KEY_getservbyport:
7321 LOP(OP_GSBYPORT,XTERM);
7323 case KEY_getservent:
7326 case KEY_getsockname:
7327 UNI(OP_GETSOCKNAME);
7329 case KEY_getsockopt:
7330 LOP(OP_GSOCKOPT,XTERM);
7345 pl_yylval.ival = CopLINE(PL_curcop);
7346 Perl_ck_warner_d(aTHX_
7347 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7348 "given is experimental");
7353 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7361 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7363 pl_yylval.ival = CopLINE(PL_curcop);
7367 LOP(OP_INDEX,XTERM);
7373 LOP(OP_IOCTL,XTERM);
7401 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7406 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7420 LOP(OP_LISTEN,XTERM);
7429 s = scan_pat(s,OP_MATCH);
7430 TERM(sublex_start());
7433 LOP(OP_MAPSTART, XREF);
7436 LOP(OP_MKDIR,XTERM);
7439 LOP(OP_MSGCTL,XTERM);
7442 LOP(OP_MSGGET,XTERM);
7445 LOP(OP_MSGRCV,XTERM);
7448 LOP(OP_MSGSND,XTERM);
7453 PL_in_my = (U16)tmp;
7455 if (isIDFIRST_lazy_if(s,UTF)) {
7456 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7457 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7459 if (!FEATURE_LEXSUBS_IS_ENABLED)
7461 "Experimental \"%s\" subs not enabled",
7462 tmp == KEY_my ? "my" :
7463 tmp == KEY_state ? "state" : "our");
7464 Perl_ck_warner_d(aTHX_
7465 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7466 "The lexical_subs feature is experimental");
7469 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7470 if (!PL_in_my_stash) {
7474 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7475 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7476 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7486 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7491 s = tokenize_use(0, s);
7495 if (*s == '(' || (s = skipspace(s), *s == '('))
7498 if (!PL_lex_allbrackets &&
7499 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7500 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7506 if (isIDFIRST_lazy_if(s,UTF)) {
7508 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7510 for (t=d; isSPACE(*t);)
7512 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7514 && !(t[0] == '=' && t[1] == '>')
7515 && !(t[0] == ':' && t[1] == ':')
7516 && !keyword(s, d-s, 0)
7518 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7519 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7520 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7526 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7528 pl_yylval.ival = OP_OR;
7538 LOP(OP_OPEN_DIR,XTERM);
7541 checkcomma(s,PL_tokenbuf,"filehandle");
7545 checkcomma(s,PL_tokenbuf,"filehandle");
7564 s = force_word(s,WORD,FALSE,TRUE);
7566 s = force_strict_version(s);
7570 LOP(OP_PIPE_OP,XTERM);
7573 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7576 COPLINE_SET_FROM_MULTI_END;
7577 pl_yylval.ival = OP_CONST;
7578 TERM(sublex_start());
7585 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7588 COPLINE_SET_FROM_MULTI_END;
7589 PL_expect = XOPERATOR;
7590 if (SvCUR(PL_lex_stuff)) {
7591 int warned_comma = !ckWARN(WARN_QW);
7592 int warned_comment = warned_comma;
7593 d = SvPV_force(PL_lex_stuff, len);
7595 for (; isSPACE(*d) && len; --len, ++d)
7600 if (!warned_comma || !warned_comment) {
7601 for (; !isSPACE(*d) && len; --len, ++d) {
7602 if (!warned_comma && *d == ',') {
7603 Perl_warner(aTHX_ packWARN(WARN_QW),
7604 "Possible attempt to separate words with commas");
7607 else if (!warned_comment && *d == '#') {
7608 Perl_warner(aTHX_ packWARN(WARN_QW),
7609 "Possible attempt to put comments in qw() list");
7615 for (; !isSPACE(*d) && len; --len, ++d)
7618 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7619 words = op_append_elem(OP_LIST, words,
7620 newSVOP(OP_CONST, 0, tokeq(sv)));
7625 words = newNULLLIST();
7627 SvREFCNT_dec(PL_lex_stuff);
7628 PL_lex_stuff = NULL;
7630 PL_expect = XOPERATOR;
7631 pl_yylval.opval = sawparens(words);
7636 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7639 pl_yylval.ival = OP_STRINGIFY;
7640 if (SvIVX(PL_lex_stuff) == '\'')
7641 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7642 TERM(sublex_start());
7645 s = scan_pat(s,OP_QR);
7646 TERM(sublex_start());
7649 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7652 pl_yylval.ival = OP_BACKTICK;
7653 TERM(sublex_start());
7661 s = force_version(s, FALSE);
7663 else if (*s != 'v' || !isDIGIT(s[1])
7664 || (s = force_version(s, TRUE), *s == 'v'))
7666 *PL_tokenbuf = '\0';
7667 s = force_word(s,WORD,TRUE,TRUE);
7668 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7669 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7670 GV_ADD | (UTF ? SVf_UTF8 : 0));
7672 yyerror("<> at require-statement should be quotes");
7674 if (orig_keyword == KEY_require) {
7680 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7682 PL_last_uni = PL_oldbufptr;
7683 PL_last_lop_op = OP_REQUIRE;
7685 return REPORT( (int)REQUIRE );
7694 LOP(OP_RENAME,XTERM);
7703 LOP(OP_RINDEX,XTERM);
7712 UNIDOR(OP_READLINE);
7715 UNIDOR(OP_BACKTICK);
7724 LOP(OP_REVERSE,XTERM);
7727 UNIDOR(OP_READLINK);
7734 if (pl_yylval.opval)
7735 TERM(sublex_start());
7737 TOKEN(1); /* force error */
7740 checkcomma(s,PL_tokenbuf,"filehandle");
7750 LOP(OP_SELECT,XTERM);
7756 LOP(OP_SEMCTL,XTERM);
7759 LOP(OP_SEMGET,XTERM);
7762 LOP(OP_SEMOP,XTERM);
7768 LOP(OP_SETPGRP,XTERM);
7770 case KEY_setpriority:
7771 LOP(OP_SETPRIORITY,XTERM);
7773 case KEY_sethostent:
7779 case KEY_setservent:
7782 case KEY_setprotoent:
7792 LOP(OP_SEEKDIR,XTERM);
7794 case KEY_setsockopt:
7795 LOP(OP_SSOCKOPT,XTERM);
7801 LOP(OP_SHMCTL,XTERM);
7804 LOP(OP_SHMGET,XTERM);
7807 LOP(OP_SHMREAD,XTERM);
7810 LOP(OP_SHMWRITE,XTERM);
7813 LOP(OP_SHUTDOWN,XTERM);
7822 LOP(OP_SOCKET,XTERM);
7824 case KEY_socketpair:
7825 LOP(OP_SOCKPAIR,XTERM);
7828 checkcomma(s,PL_tokenbuf,"subroutine name");
7831 s = force_word(s,WORD,TRUE,TRUE);
7835 LOP(OP_SPLIT,XTERM);
7838 LOP(OP_SPRINTF,XTERM);
7841 LOP(OP_SPLICE,XTERM);
7856 LOP(OP_SUBSTR,XTERM);
7862 char * const tmpbuf = PL_tokenbuf + 1;
7863 expectation attrful;
7864 bool have_name, have_proto;
7865 const int key = tmp;
7866 SV *format_name = NULL;
7871 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7872 (*s == ':' && s[1] == ':'))
7876 attrful = XATTRBLOCK;
7877 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7879 if (key == KEY_format)
7880 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7882 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7884 PL_tokenbuf, len + 1, 0
7886 sv_setpvn(PL_subname, tmpbuf, len);
7888 sv_setsv(PL_subname,PL_curstname);
7889 sv_catpvs(PL_subname,"::");
7890 sv_catpvn(PL_subname,tmpbuf,len);
7892 if (SvUTF8(PL_linestr))
7893 SvUTF8_on(PL_subname);
7900 if (key == KEY_my || key == KEY_our || key==KEY_state)
7903 /* diag_listed_as: Missing name in "%s sub" */
7905 "Missing name in \"%s\"", PL_bufptr);
7907 PL_expect = XTERMBLOCK;
7908 attrful = XATTRTERM;
7909 sv_setpvs(PL_subname,"?");
7913 if (key == KEY_format) {
7915 NEXTVAL_NEXTTOKE.opval
7916 = (OP*)newSVOP(OP_CONST,0, format_name);
7917 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
7923 /* Look for a prototype */
7924 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
7925 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7926 COPLINE_SET_FROM_MULTI_END;
7928 Perl_croak(aTHX_ "Prototype not terminated");
7929 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
7937 if (*s == ':' && s[1] != ':')
7938 PL_expect = attrful;
7939 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
7941 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
7942 else if (*s != ';' && *s != '}')
7943 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
7947 NEXTVAL_NEXTTOKE.opval =
7948 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
7949 PL_lex_stuff = NULL;
7954 sv_setpvs(PL_subname, "__ANON__");
7956 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7959 force_ident_maybe_lex('&');
7964 LOP(OP_SYSTEM,XREF);
7967 LOP(OP_SYMLINK,XTERM);
7970 LOP(OP_SYSCALL,XTERM);
7973 LOP(OP_SYSOPEN,XTERM);
7976 LOP(OP_SYSSEEK,XTERM);
7979 LOP(OP_SYSREAD,XTERM);
7982 LOP(OP_SYSWRITE,XTERM);
7987 TERM(sublex_start());
8008 LOP(OP_TRUNCATE,XTERM);
8020 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8022 pl_yylval.ival = CopLINE(PL_curcop);
8026 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8028 pl_yylval.ival = CopLINE(PL_curcop);
8032 LOP(OP_UNLINK,XTERM);
8038 LOP(OP_UNPACK,XTERM);
8041 LOP(OP_UTIME,XTERM);
8047 LOP(OP_UNSHIFT,XTERM);
8050 s = tokenize_use(1, s);
8060 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8062 pl_yylval.ival = CopLINE(PL_curcop);
8063 Perl_ck_warner_d(aTHX_
8064 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8065 "when is experimental");
8069 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8071 pl_yylval.ival = CopLINE(PL_curcop);
8075 PL_hints |= HINT_BLOCK_SCOPE;
8082 LOP(OP_WAITPID,XTERM);
8088 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8089 * we use the same number on EBCDIC */
8090 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8094 if (PL_expect == XOPERATOR) {
8095 if (*s == '=' && !PL_lex_allbrackets &&
8096 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8104 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8106 pl_yylval.ival = OP_XOR;
8115 Looks up an identifier in the pad or in a package
8118 PRIVATEREF if this is a lexical name.
8119 WORD if this belongs to a package.
8122 if we're in a my declaration
8123 croak if they tried to say my($foo::bar)
8124 build the ops for a my() declaration
8125 if it's an access to a my() variable
8126 build ops for access to a my() variable
8127 if in a dq string, and they've said @foo and we can't find @foo
8129 build ops for a bareword
8133 S_pending_ident(pTHX)
8136 const char pit = (char)pl_yylval.ival;
8137 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8138 /* All routes through this function want to know if there is a colon. */
8139 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8141 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8142 "### Pending identifier '%s'\n", PL_tokenbuf); });
8144 /* if we're in a my(), we can't allow dynamics here.
8145 $foo'bar has already been turned into $foo::bar, so
8146 just check for colons.
8148 if it's a legal name, the OP is a PADANY.
8151 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8153 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8154 "variable %s in \"our\"",
8155 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8156 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8160 /* "my" variable %s can't be in a package */
8161 /* PL_no_myglob is constant */
8162 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8163 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8164 PL_in_my == KEY_my ? "my" : "state",
8165 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8167 UTF ? SVf_UTF8 : 0);
8171 pl_yylval.opval = newOP(OP_PADANY, 0);
8172 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8173 UTF ? SVf_UTF8 : 0);
8179 build the ops for accesses to a my() variable.
8184 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8186 if (tmp != NOT_IN_PAD) {
8187 /* might be an "our" variable" */
8188 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8189 /* build ops for a bareword */
8190 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8191 HEK * const stashname = HvNAME_HEK(stash);
8192 SV * const sym = newSVhek(stashname);
8193 sv_catpvs(sym, "::");
8194 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8195 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8196 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8200 ((PL_tokenbuf[0] == '$') ? SVt_PV
8201 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8206 pl_yylval.opval = newOP(OP_PADANY, 0);
8207 pl_yylval.opval->op_targ = tmp;
8213 Whine if they've said @foo in a doublequoted string,
8214 and @foo isn't a variable we can find in the symbol
8217 if (ckWARN(WARN_AMBIGUOUS) &&
8218 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8219 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8220 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8221 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8222 /* DO NOT warn for @- and @+ */
8223 && !( PL_tokenbuf[2] == '\0' &&
8224 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8227 /* Downgraded from fatal to warning 20000522 mjd */
8228 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8229 "Possible unintended interpolation of %"UTF8f
8231 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8235 /* build ops for a bareword */
8236 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8237 newSVpvn_flags(PL_tokenbuf + 1,
8239 UTF ? SVf_UTF8 : 0 ));
8240 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8242 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8243 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8244 | ( UTF ? SVf_UTF8 : 0 ),
8245 ((PL_tokenbuf[0] == '$') ? SVt_PV
8246 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8252 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8254 PERL_ARGS_ASSERT_CHECKCOMMA;
8256 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8257 if (ckWARN(WARN_SYNTAX)) {
8260 for (w = s+2; *w && level; w++) {
8268 /* the list of chars below is for end of statements or
8269 * block / parens, boolean operators (&&, ||, //) and branch
8270 * constructs (or, and, if, until, unless, while, err, for).
8271 * Not a very solid hack... */
8272 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8273 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8274 "%s (...) interpreted as function",name);
8277 while (s < PL_bufend && isSPACE(*s))
8281 while (s < PL_bufend && isSPACE(*s))
8283 if (isIDFIRST_lazy_if(s,UTF)) {
8284 const char * const w = s;
8285 s += UTF ? UTF8SKIP(s) : 1;
8286 while (isWORDCHAR_lazy_if(s,UTF))
8287 s += UTF ? UTF8SKIP(s) : 1;
8288 while (s < PL_bufend && isSPACE(*s))
8293 if (keyword(w, s - w, 0))
8296 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8297 if (gv && GvCVu(gv))
8301 Copy(w, tmpbuf+1, s - w, char);
8303 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
8304 if (off != NOT_IN_PAD) return;
8306 Perl_croak(aTHX_ "No comma allowed after %s", what);
8311 /* S_new_constant(): do any overload::constant lookup.
8313 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8314 Best used as sv=new_constant(..., sv, ...).
8315 If s, pv are NULL, calls subroutine with one argument,
8316 and <type> is used with error messages only.
8317 <type> is assumed to be well formed UTF-8 */
8320 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8321 SV *sv, SV *pv, const char *type, STRLEN typelen)
8324 HV * table = GvHV(PL_hintgv); /* ^H */
8329 const char *why1 = "", *why2 = "", *why3 = "";
8331 PERL_ARGS_ASSERT_NEW_CONSTANT;
8332 /* We assume that this is true: */
8333 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8336 /* charnames doesn't work well if there have been errors found */
8337 if (PL_error_count > 0 && *key == 'c')
8339 SvREFCNT_dec_NN(sv);
8340 return &PL_sv_undef;
8343 sv_2mortal(sv); /* Parent created it permanently */
8345 || ! (PL_hints & HINT_LOCALIZE_HH)
8346 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8351 /* Here haven't found what we're looking for. If it is charnames,
8352 * perhaps it needs to be loaded. Try doing that before giving up */
8354 Perl_load_module(aTHX_
8356 newSVpvs("_charnames"),
8357 /* version parameter; no need to specify it, as if
8358 * we get too early a version, will fail anyway,
8359 * not being able to find '_charnames' */
8364 assert(sp == PL_stack_sp);
8365 table = GvHV(PL_hintgv);
8367 && (PL_hints & HINT_LOCALIZE_HH)
8368 && (cvp = hv_fetch(table, key, keylen, FALSE))
8374 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8375 msg = Perl_form(aTHX_
8376 "Constant(%.*s) unknown",
8377 (int)(type ? typelen : len),
8383 why3 = "} is not defined";
8386 msg = Perl_form(aTHX_
8387 /* The +3 is for '\N{'; -4 for that, plus '}' */
8388 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8392 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8393 (int)(type ? typelen : len),
8394 (type ? type: s), why1, why2, why3);
8397 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8398 return SvREFCNT_inc_simple_NN(sv);
8403 pv = newSVpvn_flags(s, len, SVs_TEMP);
8405 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8407 typesv = &PL_sv_undef;
8409 PUSHSTACKi(PERLSI_OVERLOAD);
8421 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8425 /* Check the eval first */
8426 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8428 const char * errstr;
8429 sv_catpvs(errsv, "Propagated");
8430 errstr = SvPV_const(errsv, errlen);
8431 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8433 res = SvREFCNT_inc_simple_NN(sv);
8437 SvREFCNT_inc_simple_void_NN(res);
8446 why1 = "Call to &{$^H{";
8448 why3 = "}} did not return a defined value";
8450 (void)sv_2mortal(sv);
8457 PERL_STATIC_INLINE void
8458 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8459 PERL_ARGS_ASSERT_PARSE_IDENT;
8463 Perl_croak(aTHX_ "%s", ident_too_long);
8464 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8465 /* The UTF-8 case must come first, otherwise things
8466 * like c\N{COMBINING TILDE} would start failing, as the
8467 * isWORDCHAR_A case below would gobble the 'c' up.
8470 char *t = *s + UTF8SKIP(*s);
8471 while (isIDCONT_utf8((U8*)t))
8473 if (*d + (t - *s) > e)
8474 Perl_croak(aTHX_ "%s", ident_too_long);
8475 Copy(*s, *d, t - *s, char);
8479 else if ( isWORDCHAR_A(**s) ) {
8482 } while (isWORDCHAR_A(**s) && *d < e);
8484 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8489 else if (allow_package && **s == ':' && (*s)[1] == ':'
8490 /* Disallow things like Foo::$bar. For the curious, this is
8491 * the code path that triggers the "Bad name after" warning
8492 * when looking for barewords.
8494 && (*s)[2] != '$') {
8504 /* Returns a NUL terminated string, with the length of the string written to
8508 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8511 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8512 bool is_utf8 = cBOOL(UTF);
8514 PERL_ARGS_ASSERT_SCAN_WORD;
8516 parse_ident(&s, &d, e, allow_package, is_utf8);
8523 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8525 I32 herelines = PL_parser->herelines;
8526 SSize_t bracket = -1;
8529 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8530 bool is_utf8 = cBOOL(UTF);
8531 I32 orig_copline = 0, tmp_copline = 0;
8533 PERL_ARGS_ASSERT_SCAN_IDENT;
8538 while (isDIGIT(*s)) {
8540 Perl_croak(aTHX_ "%s", ident_too_long);
8545 parse_ident(&s, &d, e, 1, is_utf8);
8550 /* Either a digit variable, or parse_ident() found an identifier
8551 (anything valid as a bareword), so job done and return. */
8552 if (PL_lex_state != LEX_NORMAL)
8553 PL_lex_state = LEX_INTERPENDMAYBE;
8556 if (*s == '$' && s[1] &&
8557 (isIDFIRST_lazy_if(s+1,is_utf8)
8558 || isDIGIT_A((U8)s[1])
8561 || strnEQ(s+1,"::",2)) )
8563 /* Dereferencing a value in a scalar variable.
8564 The alternatives are different syntaxes for a scalar variable.
8565 Using ' as a leading package separator isn't allowed. :: is. */
8568 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8570 bracket = s - SvPVX(PL_linestr);
8572 orig_copline = CopLINE(PL_curcop);
8573 if (s < PL_bufend && isSPACE(*s)) {
8578 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8579 * iff Unicode semantics are to be used. The legal ones are any of:
8580 * a) all ASCII characters except:
8581 * 1) space-type ones, like \t and SPACE;
8584 * The final case currently doesn't get this far in the program, so we
8585 * don't test for it. If that were to change, it would be ok to allow it.
8586 * c) When not under Unicode rules, any upper Latin1 character
8587 * d) Otherwise, when unicode rules are used, all XIDS characters.
8589 * Because all ASCII characters have the same representation whether
8590 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
8591 * '{' without knowing if is UTF-8 or not.
8592 * EBCDIC already uses the rules that ASCII platforms will use after the
8593 * deprecation cycle; see comment below about the deprecation. */
8595 # define VALID_LEN_ONE_IDENT(s, is_utf8) \
8596 (isGRAPH_A(*(s)) || ((is_utf8) \
8597 ? isIDFIRST_utf8((U8*) (s)) \
8599 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
8601 # define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s)) \
8602 && LIKELY(*(s) != '\0') \
8604 || isASCII_utf8((U8*) (s)) \
8605 || isIDFIRST_utf8((U8*) (s))))
8607 if ((s <= PL_bufend - (is_utf8)
8610 && VALID_LEN_ONE_IDENT(s, is_utf8))
8612 /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
8613 * because often it has no graphic representation. (We can't get to
8614 * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
8617 ? ! isGRAPH_utf8( (U8*) s)
8618 : (! isGRAPH_L1( (U8) *s)
8619 || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
8621 /* Split messages for back compat */
8622 if (isCNTRL_A( (U8) *s)) {
8623 deprecate("literal control characters in variable names");
8626 deprecate("literal non-graphic characters in variable names");
8631 const STRLEN skip = UTF8SKIP(s);
8634 for ( i = 0; i < skip; i++ )
8642 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8643 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8647 /* Warn about ambiguous code after unary operators if {...} notation isn't
8648 used. There's no difference in ambiguity; it's merely a heuristic
8649 about when not to warn. */
8650 else if (ck_uni && bracket == -1)
8652 if (bracket != -1) {
8653 /* If we were processing {...} notation then... */
8654 if (isIDFIRST_lazy_if(d,is_utf8)) {
8655 /* if it starts as a valid identifier, assume that it is one.
8656 (the later check for } being at the expected point will trap
8657 cases where this doesn't pan out.) */
8658 d += is_utf8 ? UTF8SKIP(d) : 1;
8659 parse_ident(&s, &d, e, 1, is_utf8);
8661 tmp_copline = CopLINE(PL_curcop);
8662 if (s < PL_bufend && isSPACE(*s)) {
8665 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8666 /* ${foo[0]} and ${foo{bar}} notation. */
8667 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8668 const char * const brack =
8670 ((*s == '[') ? "[...]" : "{...}");
8671 orig_copline = CopLINE(PL_curcop);
8672 CopLINE_set(PL_curcop, tmp_copline);
8673 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8674 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8675 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8676 funny, dest, brack, funny, dest, brack);
8677 CopLINE_set(PL_curcop, orig_copline);
8680 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8681 PL_lex_allbrackets++;
8685 /* Handle extended ${^Foo} variables
8686 * 1999-02-27 mjd-perl-patch@plover.com */
8687 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8691 while (isWORDCHAR(*s) && d < e) {
8695 Perl_croak(aTHX_ "%s", ident_too_long);
8700 tmp_copline = CopLINE(PL_curcop);
8701 if (s < PL_bufend && isSPACE(*s)) {
8705 /* Expect to find a closing } after consuming any trailing whitespace.
8709 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8710 PL_lex_state = LEX_INTERPEND;
8713 if (PL_lex_state == LEX_NORMAL) {
8714 if (ckWARN(WARN_AMBIGUOUS) &&
8715 (keyword(dest, d - dest, 0)
8716 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8718 SV *tmp = newSVpvn_flags( dest, d - dest,
8719 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8722 orig_copline = CopLINE(PL_curcop);
8723 CopLINE_set(PL_curcop, tmp_copline);
8724 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8725 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8726 funny, SVfARG(tmp), funny, SVfARG(tmp));
8727 CopLINE_set(PL_curcop, orig_copline);
8732 /* Didn't find the closing } at the point we expected, so restore
8733 state such that the next thing to process is the opening { and */
8734 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8735 CopLINE_set(PL_curcop, orig_copline);
8736 PL_parser->herelines = herelines;
8740 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8741 PL_lex_state = LEX_INTERPEND;
8746 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
8748 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
8749 * found in the parse starting at 's', based on the subset that are valid
8750 * in this context input to this routine in 'valid_flags'. Advances s.
8751 * Returns TRUE if the input should be treated as a valid flag, so the next
8752 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
8753 * upon first call on the current regex. This routine will set it to any
8754 * charset modifier found. The caller shouldn't change it. This way,
8755 * another charset modifier encountered in the parse can be detected as an
8756 * error, as we have decided to allow only one */
8759 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8761 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8762 if (isWORDCHAR_lazy_if(*s, UTF)) {
8763 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8764 UTF ? SVf_UTF8 : 0);
8766 /* Pretend that it worked, so will continue processing before
8775 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
8776 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8777 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8778 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8779 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8780 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8781 case LOCALE_PAT_MOD:
8783 goto multiple_charsets;
8785 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8788 case UNICODE_PAT_MOD:
8790 goto multiple_charsets;
8792 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8795 case ASCII_RESTRICT_PAT_MOD:
8797 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8801 /* Error if previous modifier wasn't an 'a', but if it was, see
8802 * if, and accept, a second occurrence (only) */
8804 || get_regex_charset(*pmfl)
8805 != REGEX_ASCII_RESTRICTED_CHARSET)
8807 goto multiple_charsets;
8809 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8813 case DEPENDS_PAT_MOD:
8815 goto multiple_charsets;
8817 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8826 if (*charset != c) {
8827 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8829 else if (c == 'a') {
8830 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8831 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8834 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8837 /* Pretend that it worked, so will continue processing before dieing */
8843 S_scan_pat(pTHX_ char *start, I32 type)
8847 const char * const valid_flags =
8848 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8849 char charset = '\0'; /* character set modifier */
8850 unsigned int x_mod_count = 0;
8852 PERL_ARGS_ASSERT_SCAN_PAT;
8854 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8856 Perl_croak(aTHX_ "Search pattern not terminated");
8858 pm = (PMOP*)newPMOP(type, 0);
8859 if (PL_multi_open == '?') {
8860 /* This is the only point in the code that sets PMf_ONCE: */
8861 pm->op_pmflags |= PMf_ONCE;
8863 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8864 allows us to restrict the list needed by reset to just the ??
8866 assert(type != OP_TRANS);
8868 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8871 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8874 elements = mg->mg_len / sizeof(PMOP**);
8875 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8876 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8877 mg->mg_len = elements * sizeof(PMOP**);
8878 PmopSTASH_set(pm,PL_curstash);
8882 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8883 * anon CV. False positives like qr/[(?{]/ are harmless */
8885 if (type == OP_QR) {
8887 char *e, *p = SvPV(PL_lex_stuff, len);
8889 for (; p < e; p++) {
8890 if (p[0] == '(' && p[1] == '?'
8891 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8893 pm->op_pmflags |= PMf_HAS_CV;
8897 pm->op_pmflags |= PMf_IS_QR;
8900 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
8901 &s, &charset, &x_mod_count))
8903 /* issue a warning if /c is specified,but /g is not */
8904 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8906 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8907 "Use of /c modifier is meaningless without /g" );
8910 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
8912 PL_lex_op = (OP*)pm;
8913 pl_yylval.ival = OP_MATCH;
8918 S_scan_subst(pTHX_ char *start)
8925 char charset = '\0'; /* character set modifier */
8926 unsigned int x_mod_count = 0;
8929 PERL_ARGS_ASSERT_SCAN_SUBST;
8931 pl_yylval.ival = OP_NULL;
8933 s = scan_str(start, TRUE, FALSE, FALSE, &t);
8936 Perl_croak(aTHX_ "Substitution pattern not terminated");
8940 first_start = PL_multi_start;
8941 first_line = CopLINE(PL_curcop);
8942 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8945 SvREFCNT_dec(PL_lex_stuff);
8946 PL_lex_stuff = NULL;
8948 Perl_croak(aTHX_ "Substitution replacement not terminated");
8950 PL_multi_start = first_start; /* so whole substitution is taken together */
8952 pm = (PMOP*)newPMOP(OP_SUBST, 0);
8956 if (*s == EXEC_PAT_MOD) {
8960 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
8961 &s, &charset, &x_mod_count))
8967 STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count);
8969 if ((pm->op_pmflags & PMf_CONTINUE)) {
8970 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
8974 SV * const repl = newSVpvs("");
8977 pm->op_pmflags |= PMf_EVAL;
8980 sv_catpvs(repl, "eval ");
8982 sv_catpvs(repl, "do ");
8984 sv_catpvs(repl, "{");
8985 sv_catsv(repl, PL_sublex_info.repl);
8986 sv_catpvs(repl, "}");
8988 SvREFCNT_dec(PL_sublex_info.repl);
8989 PL_sublex_info.repl = repl;
8991 if (CopLINE(PL_curcop) != first_line) {
8992 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
8993 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
8994 CopLINE(PL_curcop) - first_line;
8995 CopLINE_set(PL_curcop, first_line);
8998 PL_lex_op = (OP*)pm;
8999 pl_yylval.ival = OP_SUBST;
9004 S_scan_trans(pTHX_ char *start)
9011 bool nondestruct = 0;
9014 PERL_ARGS_ASSERT_SCAN_TRANS;
9016 pl_yylval.ival = OP_NULL;
9018 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9020 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9024 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9027 SvREFCNT_dec(PL_lex_stuff);
9028 PL_lex_stuff = NULL;
9030 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9033 complement = del = squash = 0;
9037 complement = OPpTRANS_COMPLEMENT;
9040 del = OPpTRANS_DELETE;
9043 squash = OPpTRANS_SQUASH;
9055 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9056 o->op_private &= ~OPpTRANS_ALL;
9057 o->op_private |= del|squash|complement|
9058 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9059 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9062 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9069 Takes a pointer to the first < in <<FOO.
9070 Returns a pointer to the byte following <<FOO.
9072 This function scans a heredoc, which involves different methods
9073 depending on whether we are in a string eval, quoted construct, etc.
9074 This is because PL_linestr could containing a single line of input, or
9075 a whole string being evalled, or the contents of the current quote-
9078 The two basic methods are:
9079 - Steal lines from the input stream
9080 - Scan the heredoc in PL_linestr and remove it therefrom
9082 In a file scope or filtered eval, the first method is used; in a
9083 string eval, the second.
9085 In a quote-like operator, we have to choose between the two,
9086 depending on where we can find a newline. We peek into outer lex-
9087 ing scopes until we find one with a newline in it. If we reach the
9088 outermost lexing scope and it is a file, we use the stream method.
9089 Otherwise it is treated as an eval.
9093 S_scan_heredoc(pTHX_ char *s)
9095 I32 op_type = OP_SCALAR;
9102 const bool infile = PL_rsfp || PL_parser->filtered;
9103 const line_t origline = CopLINE(PL_curcop);
9104 LEXSHARED *shared = PL_parser->lex_shared;
9106 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9109 d = PL_tokenbuf + 1;
9110 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9111 *PL_tokenbuf = '\n';
9113 while (SPACE_OR_TAB(*peek))
9115 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9118 s = delimcpy(d, e, s, PL_bufend, term, &len);
9120 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9126 /* <<\FOO is equivalent to <<'FOO' */
9130 if (!isWORDCHAR_lazy_if(s,UTF))
9131 deprecate("bare << to mean <<\"\"");
9132 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9137 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9138 Perl_croak(aTHX_ "Delimiter for here document is too long");
9141 len = d - PL_tokenbuf;
9143 #ifndef PERL_STRICT_CR
9144 d = strchr(s, '\r');
9146 char * const olds = s;
9148 while (s < PL_bufend) {
9154 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9163 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9168 tmpstr = newSV_type(SVt_PVIV);
9172 SvIV_set(tmpstr, -1);
9174 else if (term == '`') {
9175 op_type = OP_BACKTICK;
9176 SvIV_set(tmpstr, '\\');
9179 PL_multi_start = origline + 1 + PL_parser->herelines;
9180 PL_multi_open = PL_multi_close = '<';
9181 /* inside a string eval or quote-like operator */
9182 if (!infile || PL_lex_inwhat) {
9185 char * const olds = s;
9186 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9187 /* These two fields are not set until an inner lexing scope is
9188 entered. But we need them set here. */
9189 shared->ls_bufptr = s;
9190 shared->ls_linestr = PL_linestr;
9192 /* Look for a newline. If the current buffer does not have one,
9193 peek into the line buffer of the parent lexing scope, going
9194 up as many levels as necessary to find one with a newline
9197 while (!(s = (char *)memchr(
9198 (void *)shared->ls_bufptr, '\n',
9199 SvEND(shared->ls_linestr)-shared->ls_bufptr
9201 shared = shared->ls_prev;
9202 /* shared is only null if we have gone beyond the outermost
9203 lexing scope. In a file, we will have broken out of the
9204 loop in the previous iteration. In an eval, the string buf-
9205 fer ends with "\n;", so the while condition above will have
9206 evaluated to false. So shared can never be null. */
9208 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9209 most lexing scope. In a file, shared->ls_linestr at that
9210 level is just one line, so there is no body to steal. */
9211 if (infile && !shared->ls_prev) {
9217 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9220 linestr = shared->ls_linestr;
9221 bufend = SvEND(linestr);
9223 while (s < bufend - len + 1 &&
9224 memNE(s,PL_tokenbuf,len) ) {
9226 ++PL_parser->herelines;
9228 if (s >= bufend - len + 1) {
9231 sv_setpvn(tmpstr,d+1,s-d);
9233 /* the preceding stmt passes a newline */
9234 PL_parser->herelines++;
9236 /* s now points to the newline after the heredoc terminator.
9237 d points to the newline before the body of the heredoc.
9240 /* We are going to modify linestr in place here, so set
9241 aside copies of the string if necessary for re-evals or
9243 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9244 check shared->re_eval_str. */
9245 if (shared->re_eval_start || shared->re_eval_str) {
9246 /* Set aside the rest of the regexp */
9247 if (!shared->re_eval_str)
9248 shared->re_eval_str =
9249 newSVpvn(shared->re_eval_start,
9250 bufend - shared->re_eval_start);
9251 shared->re_eval_start -= s-d;
9253 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9254 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9255 cx->blk_eval.cur_text == linestr)
9257 cx->blk_eval.cur_text = newSVsv(linestr);
9258 SvSCREAM_on(cx->blk_eval.cur_text);
9260 /* Copy everything from s onwards back to d. */
9261 Move(s,d,bufend-s + 1,char);
9262 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9263 /* Setting PL_bufend only applies when we have not dug deeper
9264 into other scopes, because sublex_done sets PL_bufend to
9265 SvEND(PL_linestr). */
9266 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9273 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9274 term = PL_tokenbuf[1];
9276 linestr_save = PL_linestr; /* must restore this afterwards */
9277 d = s; /* and this */
9278 PL_linestr = newSVpvs("");
9279 PL_bufend = SvPVX(PL_linestr);
9281 PL_bufptr = PL_bufend;
9282 CopLINE_set(PL_curcop,
9283 origline + 1 + PL_parser->herelines);
9284 if (!lex_next_chunk(LEX_NO_TERM)
9285 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9286 /* Simply freeing linestr_save might seem simpler here, as it
9287 does not matter what PL_linestr points to, since we are
9288 about to croak; but in a quote-like op, linestr_save
9289 will have been prospectively freed already, via
9290 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
9291 restore PL_linestr. */
9292 SvREFCNT_dec_NN(PL_linestr);
9293 PL_linestr = linestr_save;
9296 CopLINE_set(PL_curcop, origline);
9297 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9298 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9299 /* ^That should be enough to avoid this needing to grow: */
9300 sv_catpvs(PL_linestr, "\n\0");
9301 assert(s == SvPVX(PL_linestr));
9302 PL_bufend = SvEND(PL_linestr);
9305 PL_parser->herelines++;
9306 PL_last_lop = PL_last_uni = NULL;
9307 #ifndef PERL_STRICT_CR
9308 if (PL_bufend - PL_linestart >= 2) {
9309 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9310 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9312 PL_bufend[-2] = '\n';
9314 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9316 else if (PL_bufend[-1] == '\r')
9317 PL_bufend[-1] = '\n';
9319 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9320 PL_bufend[-1] = '\n';
9322 if (*s == term && PL_bufend-s >= len
9323 && memEQ(s,PL_tokenbuf + 1,len)) {
9324 SvREFCNT_dec(PL_linestr);
9325 PL_linestr = linestr_save;
9326 PL_linestart = SvPVX(linestr_save);
9327 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9332 sv_catsv(tmpstr,PL_linestr);
9336 PL_multi_end = origline + PL_parser->herelines;
9337 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9338 SvPV_shrink_to_cur(tmpstr);
9341 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9343 else if (IN_ENCODING)
9344 sv_recode_to_utf8(tmpstr, _get_encoding());
9346 PL_lex_stuff = tmpstr;
9347 pl_yylval.ival = op_type;
9351 SvREFCNT_dec(tmpstr);
9352 CopLINE_set(PL_curcop, origline);
9353 missingterm(PL_tokenbuf + 1);
9357 takes: current position in input buffer
9358 returns: new position in input buffer
9359 side-effects: pl_yylval and lex_op are set.
9364 <<>> read from ARGV without magic open
9365 <FH> read from filehandle
9366 <pkg::FH> read from package qualified filehandle
9367 <pkg'FH> read from package qualified filehandle
9368 <$fh> read from filehandle in $fh
9374 S_scan_inputsymbol(pTHX_ char *start)
9376 char *s = start; /* current position in buffer */
9379 bool nomagicopen = FALSE;
9380 char *d = PL_tokenbuf; /* start of temp holding space */
9381 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9383 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9385 end = strchr(s, '\n');
9388 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
9395 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9397 /* die if we didn't have space for the contents of the <>,
9398 or if it didn't end, or if we see a newline
9401 if (len >= (I32)sizeof PL_tokenbuf)
9402 Perl_croak(aTHX_ "Excessively long <> operator");
9404 Perl_croak(aTHX_ "Unterminated <> operator");
9409 Remember, only scalar variables are interpreted as filehandles by
9410 this code. Anything more complex (e.g., <$fh{$num}>) will be
9411 treated as a glob() call.
9412 This code makes use of the fact that except for the $ at the front,
9413 a scalar variable and a filehandle look the same.
9415 if (*d == '$' && d[1]) d++;
9417 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9418 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9419 d += UTF ? UTF8SKIP(d) : 1;
9421 /* If we've tried to read what we allow filehandles to look like, and
9422 there's still text left, then it must be a glob() and not a getline.
9423 Use scan_str to pull out the stuff between the <> and treat it
9424 as nothing more than a string.
9427 if (d - PL_tokenbuf != len) {
9428 pl_yylval.ival = OP_GLOB;
9429 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9431 Perl_croak(aTHX_ "Glob not terminated");
9435 bool readline_overriden = FALSE;
9437 /* we're in a filehandle read situation */
9440 /* turn <> into <ARGV> */
9442 Copy("ARGV",d,5,char);
9444 /* Check whether readline() is overriden */
9445 if ((gv_readline = gv_override("readline",8)))
9446 readline_overriden = TRUE;
9448 /* if <$fh>, create the ops to turn the variable into a
9452 /* try to find it in the pad for this block, otherwise find
9453 add symbol table ops
9455 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
9456 if (tmp != NOT_IN_PAD) {
9457 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9458 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9459 HEK * const stashname = HvNAME_HEK(stash);
9460 SV * const sym = sv_2mortal(newSVhek(stashname));
9461 sv_catpvs(sym, "::");
9467 OP * const o = newOP(OP_PADSV, 0);
9469 PL_lex_op = readline_overriden
9470 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9471 op_append_elem(OP_LIST, o,
9472 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9473 : (OP*)newUNOP(OP_READLINE, 0, o);
9481 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9483 PL_lex_op = readline_overriden
9484 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9485 op_append_elem(OP_LIST,
9486 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9487 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9488 : (OP*)newUNOP(OP_READLINE, 0,
9489 newUNOP(OP_RV2SV, 0,
9490 newGVOP(OP_GV, 0, gv)));
9492 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9493 pl_yylval.ival = OP_NULL;
9496 /* If it's none of the above, it must be a literal filehandle
9497 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9499 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9500 PL_lex_op = readline_overriden
9501 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9502 op_append_elem(OP_LIST,
9503 newGVOP(OP_GV, 0, gv),
9504 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9505 : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
9506 pl_yylval.ival = OP_NULL;
9516 start position in buffer
9517 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9518 only if they are of the open/close form
9519 keep_delims preserve the delimiters around the string
9520 re_reparse compiling a run-time /(?{})/:
9521 collapse // to /, and skip encoding src
9522 delimp if non-null, this is set to the position of
9523 the closing delimiter, or just after it if
9524 the closing and opening delimiters differ
9525 (i.e., the opening delimiter of a substitu-
9527 returns: position to continue reading from buffer
9528 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9529 updates the read buffer.
9531 This subroutine pulls a string out of the input. It is called for:
9532 q single quotes q(literal text)
9533 ' single quotes 'literal text'
9534 qq double quotes qq(interpolate $here please)
9535 " double quotes "interpolate $here please"
9536 qx backticks qx(/bin/ls -l)
9537 ` backticks `/bin/ls -l`
9538 qw quote words @EXPORT_OK = qw( func() $spam )
9539 m// regexp match m/this/
9540 s/// regexp substitute s/this/that/
9541 tr/// string transliterate tr/this/that/
9542 y/// string transliterate y/this/that/
9543 ($*@) sub prototypes sub foo ($)
9544 (stuff) sub attr parameters sub foo : attr(stuff)
9545 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9547 In most of these cases (all but <>, patterns and transliterate)
9548 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9549 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9550 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9553 It skips whitespace before the string starts, and treats the first
9554 character as the delimiter. If the delimiter is one of ([{< then
9555 the corresponding "close" character )]}> is used as the closing
9556 delimiter. It allows quoting of delimiters, and if the string has
9557 balanced delimiters ([{<>}]) it allows nesting.
9559 On success, the SV with the resulting string is put into lex_stuff or,
9560 if that is already non-NULL, into lex_repl. The second case occurs only
9561 when parsing the RHS of the special constructs s/// and tr/// (y///).
9562 For convenience, the terminating delimiter character is stuffed into
9567 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9571 SV *sv; /* scalar value: string */
9572 const char *tmps; /* temp string, used for delimiter matching */
9573 char *s = start; /* current position in the buffer */
9574 char term; /* terminating character */
9575 char *to; /* current position in the sv's data */
9576 I32 brackets = 1; /* bracket nesting level */
9577 bool has_utf8 = FALSE; /* is there any utf8 content? */
9578 I32 termcode; /* terminating char. code */
9579 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9580 STRLEN termlen; /* length of terminating string */
9581 int last_off = 0; /* last position for nesting bracket */
9584 PERL_ARGS_ASSERT_SCAN_STR;
9586 /* skip space before the delimiter */
9591 /* mark where we are, in case we need to report errors */
9594 /* after skipping whitespace, the next character is the terminator */
9597 termcode = termstr[0] = term;
9601 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9602 Copy(s, termstr, termlen, U8);
9603 if (!UTF8_IS_INVARIANT(term))
9607 /* mark where we are */
9608 PL_multi_start = CopLINE(PL_curcop);
9609 PL_multi_open = term;
9610 herelines = PL_parser->herelines;
9612 /* find corresponding closing delimiter */
9613 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9614 termcode = termstr[0] = term = tmps[5];
9616 PL_multi_close = term;
9618 if (PL_multi_open == PL_multi_close) {
9619 keep_bracketed_quoted = FALSE;
9622 /* create a new SV to hold the contents. 79 is the SV's initial length.
9623 What a random number. */
9624 sv = newSV_type(SVt_PVIV);
9626 SvIV_set(sv, termcode);
9627 (void)SvPOK_only(sv); /* validate pointer */
9629 /* move past delimiter and try to read a complete string */
9631 sv_catpvn(sv, s, termlen);
9634 if (IN_ENCODING && !UTF && !re_reparse) {
9638 int offset = s - SvPVX_const(PL_linestr);
9639 const bool found = sv_cat_decode(sv, _get_encoding(), PL_linestr,
9640 &offset, (char*)termstr, termlen);
9644 if (SvIsCOW(PL_linestr)) {
9645 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9646 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9647 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9648 char *buf = SvPVX(PL_linestr);
9649 bufend_pos = PL_parser->bufend - buf;
9650 bufptr_pos = PL_parser->bufptr - buf;
9651 oldbufptr_pos = PL_parser->oldbufptr - buf;
9652 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9653 linestart_pos = PL_parser->linestart - buf;
9654 last_uni_pos = PL_parser->last_uni
9655 ? PL_parser->last_uni - buf
9657 last_lop_pos = PL_parser->last_lop
9658 ? PL_parser->last_lop - buf
9661 PL_parser->lex_shared->re_eval_start ?
9662 PL_parser->lex_shared->re_eval_start - buf : 0;
9665 sv_force_normal(PL_linestr);
9667 buf = SvPVX(PL_linestr);
9668 PL_parser->bufend = buf + bufend_pos;
9669 PL_parser->bufptr = buf + bufptr_pos;
9670 PL_parser->oldbufptr = buf + oldbufptr_pos;
9671 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9672 PL_parser->linestart = buf + linestart_pos;
9673 if (PL_parser->last_uni)
9674 PL_parser->last_uni = buf + last_uni_pos;
9675 if (PL_parser->last_lop)
9676 PL_parser->last_lop = buf + last_lop_pos;
9677 if (PL_parser->lex_shared->re_eval_start)
9678 PL_parser->lex_shared->re_eval_start =
9679 buf + re_eval_start_pos;
9682 ns = SvPVX_const(PL_linestr) + offset;
9683 svlast = SvEND(sv) - 1;
9685 for (; s < ns; s++) {
9686 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9687 COPLINE_INC_WITH_HERELINES;
9690 goto read_more_line;
9692 /* handle quoted delimiters */
9693 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9695 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9697 if ((svlast-1 - t) % 2) {
9698 if (!keep_bracketed_quoted) {
9701 SvCUR_set(sv, SvCUR(sv) - 1);
9706 if (PL_multi_open == PL_multi_close) {
9712 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9713 /* At here, all closes are "was quoted" one,
9714 so we don't check PL_multi_close. */
9716 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9721 else if (*t == PL_multi_open)
9729 SvCUR_set(sv, w - SvPVX_const(sv));
9731 last_off = w - SvPVX(sv);
9732 if (--brackets <= 0)
9738 SvCUR_set(sv, SvCUR(sv) - 1);
9744 /* extend sv if need be */
9745 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9746 /* set 'to' to the next character in the sv's string */
9747 to = SvPVX(sv)+SvCUR(sv);
9749 /* if open delimiter is the close delimiter read unbridle */
9750 if (PL_multi_open == PL_multi_close) {
9751 for (; s < PL_bufend; s++,to++) {
9752 /* embedded newlines increment the current line number */
9753 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9754 COPLINE_INC_WITH_HERELINES;
9755 /* handle quoted delimiters */
9756 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9757 if (!keep_bracketed_quoted
9759 || (re_reparse && s[1] == '\\'))
9762 else /* any other quotes are simply copied straight through */
9765 /* terminate when run out of buffer (the for() condition), or
9766 have found the terminator */
9767 else if (*s == term) {
9770 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9773 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9779 /* if the terminator isn't the same as the start character (e.g.,
9780 matched brackets), we have to allow more in the quoting, and
9781 be prepared for nested brackets.
9784 /* read until we run out of string, or we find the terminator */
9785 for (; s < PL_bufend; s++,to++) {
9786 /* embedded newlines increment the line count */
9787 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9788 COPLINE_INC_WITH_HERELINES;
9789 /* backslashes can escape the open or closing characters */
9790 if (*s == '\\' && s+1 < PL_bufend) {
9791 if (!keep_bracketed_quoted &&
9792 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9799 /* allow nested opens and closes */
9800 else if (*s == PL_multi_close && --brackets <= 0)
9802 else if (*s == PL_multi_open)
9804 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9809 /* terminate the copied string and update the sv's end-of-string */
9811 SvCUR_set(sv, to - SvPVX_const(sv));
9814 * this next chunk reads more into the buffer if we're not done yet
9818 break; /* handle case where we are done yet :-) */
9820 #ifndef PERL_STRICT_CR
9821 if (to - SvPVX_const(sv) >= 2) {
9822 if ((to[-2] == '\r' && to[-1] == '\n') ||
9823 (to[-2] == '\n' && to[-1] == '\r'))
9827 SvCUR_set(sv, to - SvPVX_const(sv));
9829 else if (to[-1] == '\r')
9832 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9837 /* if we're out of file, or a read fails, bail and reset the current
9838 line marker so we can report where the unterminated string began
9840 COPLINE_INC_WITH_HERELINES;
9841 PL_bufptr = PL_bufend;
9842 if (!lex_next_chunk(0)) {
9844 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9850 /* at this point, we have successfully read the delimited string */
9852 if (!IN_ENCODING || UTF || re_reparse) {
9855 sv_catpvn(sv, s, termlen);
9858 if (has_utf8 || (IN_ENCODING && !re_reparse))
9861 PL_multi_end = CopLINE(PL_curcop);
9862 CopLINE_set(PL_curcop, PL_multi_start);
9863 PL_parser->herelines = herelines;
9865 /* if we allocated too much space, give some back */
9866 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9867 SvLEN_set(sv, SvCUR(sv) + 1);
9868 SvPV_renew(sv, SvLEN(sv));
9871 /* decide whether this is the first or second quoted string we've read
9876 PL_sublex_info.repl = sv;
9879 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9885 takes: pointer to position in buffer
9886 returns: pointer to new position in buffer
9887 side-effects: builds ops for the constant in pl_yylval.op
9889 Read a number in any of the formats that Perl accepts:
9891 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9892 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9893 0b[01](_?[01])* binary integers
9894 0[0-7](_?[0-7])* octal integers
9895 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9896 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9898 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9901 If it reads a number without a decimal point or an exponent, it will
9902 try converting the number to an integer and see if it can do so
9903 without loss of precision.
9907 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9909 const char *s = start; /* current position in buffer */
9910 char *d; /* destination in temp buffer */
9911 char *e; /* end of temp buffer */
9912 NV nv; /* number read, as a double */
9913 SV *sv = NULL; /* place to put the converted number */
9914 bool floatit; /* boolean: int or float? */
9915 const char *lastub = NULL; /* position of last underbar */
9916 static const char* const number_too_long = "Number too long";
9917 /* Hexadecimal floating point.
9919 * In many places (where we have quads and NV is IEEE 754 double)
9920 * we can fit the mantissa bits of a NV into an unsigned quad.
9921 * (Note that UVs might not be quads even when we have quads.)
9922 * This will not work everywhere, though (either no quads, or
9923 * using long doubles), in which case we have to resort to NV,
9924 * which will probably mean horrible loss of precision due to
9925 * multiple fp operations. */
9928 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
9929 # define HEXFP_UQUAD
9930 Uquad_t hexfp_uquad = 0;
9931 int hexfp_frac_bits = 0;
9936 NV hexfp_mult = 1.0;
9937 UV high_non_zero = 0; /* highest digit */
9939 PERL_ARGS_ASSERT_SCAN_NUM;
9941 /* We use the first character to decide what type of number this is */
9945 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
9947 /* if it starts with a 0, it could be an octal number, a decimal in
9948 0.13 disguise, or a hexadecimal number, or a binary number. */
9952 u holds the "number so far"
9953 shift the power of 2 of the base
9954 (hex == 4, octal == 3, binary == 1)
9955 overflowed was the number more than we can hold?
9957 Shift is used when we add a digit. It also serves as an "are
9958 we in octal/hex/binary?" indicator to disallow hex characters
9964 bool overflowed = FALSE;
9965 bool just_zero = TRUE; /* just plain 0 or binary number? */
9966 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
9967 static const char* const bases[5] =
9968 { "", "binary", "", "octal", "hexadecimal" };
9969 static const char* const Bases[5] =
9970 { "", "Binary", "", "Octal", "Hexadecimal" };
9971 static const char* const maxima[5] =
9973 "0b11111111111111111111111111111111",
9977 const char *base, *Base, *max;
9980 if (isALPHA_FOLD_EQ(s[1], 'x')) {
9984 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
9989 /* check for a decimal in disguise */
9990 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
9992 /* so it must be octal */
9999 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10000 "Misplaced _ in number");
10004 base = bases[shift];
10005 Base = Bases[shift];
10006 max = maxima[shift];
10008 /* read the rest of the number */
10010 /* x is used in the overflow test,
10011 b is the digit we're adding on. */
10016 /* if we don't mention it, we're done */
10020 /* _ are ignored -- but warned about if consecutive */
10022 if (lastub && s == lastub + 1)
10023 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10024 "Misplaced _ in number");
10028 /* 8 and 9 are not octal */
10029 case '8': case '9':
10031 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10035 case '2': case '3': case '4':
10036 case '5': case '6': case '7':
10038 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10041 case '0': case '1':
10042 b = *s++ & 15; /* ASCII digit -> value of digit */
10046 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10047 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10048 /* make sure they said 0x */
10051 b = (*s++ & 7) + 9;
10053 /* Prepare to put the digit we have onto the end
10054 of the number so far. We check for overflows.
10060 x = u << shift; /* make room for the digit */
10062 total_bits += shift;
10064 if ((x >> shift) != u
10065 && !(PL_hints & HINT_NEW_BINARY)) {
10068 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10069 "Integer overflow in %s number",
10072 u = x | b; /* add the digit to the end */
10075 n *= nvshift[shift];
10076 /* If an NV has not enough bits in its
10077 * mantissa to represent an UV this summing of
10078 * small low-order numbers is a waste of time
10079 * (because the NV cannot preserve the
10080 * low-order bits anyway): we could just
10081 * remember when did we overflow and in the
10082 * end just multiply n by the right
10087 if (high_non_zero == 0 && b > 0)
10090 /* this could be hexfp, but peek ahead
10091 * to avoid matching ".." */
10092 if (UNLIKELY(HEXFP_PEEK(s))) {
10100 /* if we get here, we had success: make a scalar value from
10105 /* final misplaced underbar check */
10106 if (s[-1] == '_') {
10107 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10110 if (UNLIKELY(HEXFP_PEEK(s))) {
10111 /* Do sloppy (on the underbars) but quick detection
10112 * (and value construction) for hexfp, the decimal
10113 * detection will shortly be more thorough with the
10114 * underbar checks. */
10118 #else /* HEXFP_NV */
10123 NV mult = 1 / 16.0;
10126 while (isXDIGIT(*h) || *h == '_') {
10127 if (isXDIGIT(*h)) {
10128 U8 b = XDIGIT_VALUE(*h);
10129 total_bits += shift;
10131 hexfp_uquad <<= shift;
10133 hexfp_frac_bits += shift;
10134 #else /* HEXFP_NV */
10135 hexfp_nv += b * mult;
10143 if (total_bits >= 4) {
10144 if (high_non_zero < 0x8)
10146 if (high_non_zero < 0x4)
10148 if (high_non_zero < 0x2)
10152 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10153 bool negexp = FALSE;
10157 else if (*h == '-') {
10163 while (isDIGIT(*h) || *h == '_') {
10166 hexfp_exp += *h - '0';
10169 -hexfp_exp < NV_MIN_EXP - 1) {
10170 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10171 "Hexadecimal float: exponent underflow");
10178 hexfp_exp > NV_MAX_EXP - 1) {
10179 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10180 "Hexadecimal float: exponent overflow");
10189 hexfp_exp = -hexfp_exp;
10191 hexfp_exp -= hexfp_frac_bits;
10193 hexfp_mult = pow(2.0, hexfp_exp);
10201 if (n > 4294967295.0)
10202 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10203 "%s number > %s non-portable",
10209 if (u > 0xffffffff)
10210 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10211 "%s number > %s non-portable",
10216 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10217 sv = new_constant(start, s - start, "integer",
10218 sv, NULL, NULL, 0);
10219 else if (PL_hints & HINT_NEW_BINARY)
10220 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10225 handle decimal numbers.
10226 we're also sent here when we read a 0 as the first digit
10228 case '1': case '2': case '3': case '4': case '5':
10229 case '6': case '7': case '8': case '9': case '.':
10232 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10241 /* read next group of digits and _ and copy into d */
10242 while (isDIGIT(*s) || *s == '_' ||
10243 UNLIKELY(hexfp && isXDIGIT(*s))) {
10244 /* skip underscores, checking for misplaced ones
10248 if (lastub && s == lastub + 1)
10249 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10250 "Misplaced _ in number");
10254 /* check for end of fixed-length buffer */
10256 Perl_croak(aTHX_ "%s", number_too_long);
10257 /* if we're ok, copy the character */
10262 /* final misplaced underbar check */
10263 if (lastub && s == lastub + 1) {
10264 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10267 /* read a decimal portion if there is one. avoid
10268 3..5 being interpreted as the number 3. followed
10271 if (*s == '.' && s[1] != '.') {
10276 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10277 "Misplaced _ in number");
10281 /* copy, ignoring underbars, until we run out of digits.
10283 for (; isDIGIT(*s) || *s == '_' ||
10284 UNLIKELY(hexfp && isXDIGIT(*s));
10286 /* fixed length buffer check */
10288 Perl_croak(aTHX_ "%s", number_too_long);
10290 if (lastub && s == lastub + 1)
10291 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10292 "Misplaced _ in number");
10298 /* fractional part ending in underbar? */
10299 if (s[-1] == '_') {
10300 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10301 "Misplaced _ in number");
10303 if (*s == '.' && isDIGIT(s[1])) {
10304 /* oops, it's really a v-string, but without the "v" */
10310 /* read exponent part, if present */
10311 if ((isALPHA_FOLD_EQ(*s, 'e')
10312 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10313 && strchr("+-0123456789_", s[1]))
10317 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10318 ditto for p (hexfloats) */
10319 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10320 /* At least some Mach atof()s don't grok 'E' */
10323 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10330 /* stray preinitial _ */
10332 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10333 "Misplaced _ in number");
10337 /* allow positive or negative exponent */
10338 if (*s == '+' || *s == '-')
10341 /* stray initial _ */
10343 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10344 "Misplaced _ in number");
10348 /* read digits of exponent */
10349 while (isDIGIT(*s) || *s == '_') {
10352 Perl_croak(aTHX_ "%s", number_too_long);
10356 if (((lastub && s == lastub + 1) ||
10357 (!isDIGIT(s[1]) && s[1] != '_')))
10358 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10359 "Misplaced _ in number");
10367 We try to do an integer conversion first if no characters
10368 indicating "float" have been found.
10373 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10375 if (flags == IS_NUMBER_IN_UV) {
10377 sv = newSViv(uv); /* Prefer IVs over UVs. */
10380 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10381 if (uv <= (UV) IV_MIN)
10382 sv = newSViv(-(IV)uv);
10389 STORE_NUMERIC_LOCAL_SET_STANDARD();
10390 /* terminate the string */
10392 if (UNLIKELY(hexfp)) {
10393 # ifdef NV_MANT_DIG
10394 if (total_bits > NV_MANT_DIG)
10395 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10396 "Hexadecimal float: mantissa overflow");
10399 nv = hexfp_uquad * hexfp_mult;
10400 #else /* HEXFP_NV */
10401 nv = hexfp_nv * hexfp_mult;
10404 nv = Atof(PL_tokenbuf);
10406 RESTORE_NUMERIC_LOCAL();
10411 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10412 const char *const key = floatit ? "float" : "integer";
10413 const STRLEN keylen = floatit ? 5 : 7;
10414 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10415 key, keylen, sv, NULL, NULL, 0);
10419 /* if it starts with a v, it could be a v-string */
10422 sv = newSV(5); /* preallocate storage space */
10423 ENTER_with_name("scan_vstring");
10425 s = scan_vstring(s, PL_bufend, sv);
10426 SvREFCNT_inc_simple_void_NN(sv);
10427 LEAVE_with_name("scan_vstring");
10431 /* make the op for the constant and return */
10434 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10436 lvalp->opval = NULL;
10442 S_scan_formline(pTHX_ char *s)
10446 SV * const stuff = newSVpvs("");
10447 bool needargs = FALSE;
10448 bool eofmt = FALSE;
10450 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10452 while (!needargs) {
10455 #ifdef PERL_STRICT_CR
10456 while (SPACE_OR_TAB(*t))
10459 while (SPACE_OR_TAB(*t) || *t == '\r')
10462 if (*t == '\n' || t == PL_bufend) {
10467 eol = (char *) memchr(s,'\n',PL_bufend-s);
10471 for (t = s; t < eol; t++) {
10472 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10474 goto enough; /* ~~ must be first line in formline */
10476 if (*t == '@' || *t == '^')
10480 sv_catpvn(stuff, s, eol-s);
10481 #ifndef PERL_STRICT_CR
10482 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10483 char *end = SvPVX(stuff) + SvCUR(stuff);
10486 SvCUR_set(stuff, SvCUR(stuff) - 1);
10494 if ((PL_rsfp || PL_parser->filtered)
10495 && PL_parser->form_lex_state == LEX_NORMAL) {
10497 PL_bufptr = PL_bufend;
10498 COPLINE_INC_WITH_HERELINES;
10499 got_some = lex_next_chunk(0);
10500 CopLINE_dec(PL_curcop);
10508 if (!SvCUR(stuff) || needargs)
10509 PL_lex_state = PL_parser->form_lex_state;
10510 if (SvCUR(stuff)) {
10511 PL_expect = XSTATE;
10513 const char *s2 = s;
10514 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10518 PL_expect = XTERMBLOCK;
10519 NEXTVAL_NEXTTOKE.ival = 0;
10522 NEXTVAL_NEXTTOKE.ival = 0;
10523 force_next(FORMLBRACK);
10526 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10528 else if (IN_ENCODING)
10529 sv_recode_to_utf8(stuff, _get_encoding());
10531 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10535 SvREFCNT_dec(stuff);
10537 PL_lex_formbrack = 0;
10543 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10545 const I32 oldsavestack_ix = PL_savestack_ix;
10546 CV* const outsidecv = PL_compcv;
10548 SAVEI32(PL_subline);
10549 save_item(PL_subname);
10550 SAVESPTR(PL_compcv);
10552 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10553 CvFLAGS(PL_compcv) |= flags;
10555 PL_subline = CopLINE(PL_curcop);
10556 CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB));
10557 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10558 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10559 if (outsidecv && CvPADLIST(outsidecv))
10560 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10562 return oldsavestack_ix;
10566 S_yywarn(pTHX_ const char *const s, U32 flags)
10568 PERL_ARGS_ASSERT_YYWARN;
10570 PL_in_eval |= EVAL_WARNONLY;
10571 yyerror_pv(s, flags);
10576 Perl_yyerror(pTHX_ const char *const s)
10578 PERL_ARGS_ASSERT_YYERROR;
10579 return yyerror_pvn(s, strlen(s), 0);
10583 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10585 PERL_ARGS_ASSERT_YYERROR_PV;
10586 return yyerror_pvn(s, strlen(s), flags);
10590 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10592 const char *context = NULL;
10595 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10596 int yychar = PL_parser->yychar;
10598 PERL_ARGS_ASSERT_YYERROR_PVN;
10600 if (!yychar || (yychar == ';' && !PL_rsfp))
10601 sv_catpvs(where_sv, "at EOF");
10602 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10603 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10604 PL_oldbufptr != PL_bufptr) {
10607 The code below is removed for NetWare because it abends/crashes on NetWare
10608 when the script has error such as not having the closing quotes like:
10609 if ($var eq "value)
10610 Checking of white spaces is anyway done in NetWare code.
10613 while (isSPACE(*PL_oldoldbufptr))
10616 context = PL_oldoldbufptr;
10617 contlen = PL_bufptr - PL_oldoldbufptr;
10619 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10620 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10623 The code below is removed for NetWare because it abends/crashes on NetWare
10624 when the script has error such as not having the closing quotes like:
10625 if ($var eq "value)
10626 Checking of white spaces is anyway done in NetWare code.
10629 while (isSPACE(*PL_oldbufptr))
10632 context = PL_oldbufptr;
10633 contlen = PL_bufptr - PL_oldbufptr;
10635 else if (yychar > 255)
10636 sv_catpvs(where_sv, "next token ???");
10637 else if (yychar == -2) { /* YYEMPTY */
10638 if (PL_lex_state == LEX_NORMAL ||
10639 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10640 sv_catpvs(where_sv, "at end of line");
10641 else if (PL_lex_inpat)
10642 sv_catpvs(where_sv, "within pattern");
10644 sv_catpvs(where_sv, "within string");
10647 sv_catpvs(where_sv, "next char ");
10649 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10650 else if (isPRINT_LC(yychar)) {
10651 const char string = yychar;
10652 sv_catpvn(where_sv, &string, 1);
10655 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10657 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10658 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10659 OutCopFILE(PL_curcop),
10660 (IV)(PL_parser->preambling == NOLINE
10661 ? CopLINE(PL_curcop)
10662 : PL_parser->preambling));
10664 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10665 UTF8fARG(UTF, contlen, context));
10667 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10668 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10669 Perl_sv_catpvf(aTHX_ msg,
10670 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10671 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10674 if (PL_in_eval & EVAL_WARNONLY) {
10675 PL_in_eval &= ~EVAL_WARNONLY;
10676 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10680 if (PL_error_count >= 10) {
10682 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10683 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10684 SVfARG(errsv), OutCopFILE(PL_curcop));
10686 Perl_croak(aTHX_ "%s has too many errors.\n",
10687 OutCopFILE(PL_curcop));
10690 PL_in_my_stash = NULL;
10695 S_swallow_bom(pTHX_ U8 *s)
10697 const STRLEN slen = SvCUR(PL_linestr);
10699 PERL_ARGS_ASSERT_SWALLOW_BOM;
10703 if (s[1] == 0xFE) {
10704 /* UTF-16 little-endian? (or UTF-32LE?) */
10705 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10706 /* diag_listed_as: Unsupported script encoding %s */
10707 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10708 #ifndef PERL_NO_UTF16_FILTER
10709 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10711 if (PL_bufend > (char*)s) {
10712 s = add_utf16_textfilter(s, TRUE);
10715 /* diag_listed_as: Unsupported script encoding %s */
10716 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10721 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10722 #ifndef PERL_NO_UTF16_FILTER
10723 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10725 if (PL_bufend > (char *)s) {
10726 s = add_utf16_textfilter(s, FALSE);
10729 /* diag_listed_as: Unsupported script encoding %s */
10730 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10734 case BOM_UTF8_FIRST_BYTE: {
10735 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10736 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10737 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10738 s += len + 1; /* UTF-8 */
10745 if (s[2] == 0xFE && s[3] == 0xFF) {
10746 /* UTF-32 big-endian */
10747 /* diag_listed_as: Unsupported script encoding %s */
10748 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10751 else if (s[2] == 0 && s[3] != 0) {
10754 * are a good indicator of UTF-16BE. */
10755 #ifndef PERL_NO_UTF16_FILTER
10756 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10757 s = add_utf16_textfilter(s, FALSE);
10759 /* diag_listed_as: Unsupported script encoding %s */
10760 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10767 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10770 * are a good indicator of UTF-16LE. */
10771 #ifndef PERL_NO_UTF16_FILTER
10772 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10773 s = add_utf16_textfilter(s, TRUE);
10775 /* diag_listed_as: Unsupported script encoding %s */
10776 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10784 #ifndef PERL_NO_UTF16_FILTER
10786 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10788 SV *const filter = FILTER_DATA(idx);
10789 /* We re-use this each time round, throwing the contents away before we
10791 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10792 SV *const utf8_buffer = filter;
10793 IV status = IoPAGE(filter);
10794 const bool reverse = cBOOL(IoLINES(filter));
10797 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10799 /* As we're automatically added, at the lowest level, and hence only called
10800 from this file, we can be sure that we're not called in block mode. Hence
10801 don't bother writing code to deal with block mode. */
10803 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10806 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10808 DEBUG_P(PerlIO_printf(Perl_debug_log,
10809 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10810 FPTR2DPTR(void *, S_utf16_textfilter),
10811 reverse ? 'l' : 'b', idx, maxlen, status,
10812 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10819 /* First, look in our buffer of existing UTF-8 data: */
10820 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10824 } else if (status == 0) {
10826 IoPAGE(filter) = 0;
10827 nl = SvEND(utf8_buffer);
10830 STRLEN got = nl - SvPVX(utf8_buffer);
10831 /* Did we have anything to append? */
10833 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10834 /* Everything else in this code works just fine if SVp_POK isn't
10835 set. This, however, needs it, and we need it to work, else
10836 we loop infinitely because the buffer is never consumed. */
10837 sv_chop(utf8_buffer, nl);
10841 /* OK, not a complete line there, so need to read some more UTF-16.
10842 Read an extra octect if the buffer currently has an odd number. */
10846 if (SvCUR(utf16_buffer) >= 2) {
10847 /* Location of the high octet of the last complete code point.
10848 Gosh, UTF-16 is a pain. All the benefits of variable length,
10849 *coupled* with all the benefits of partial reads and
10851 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10852 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10854 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10858 /* We have the first half of a surrogate. Read more. */
10859 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10862 status = FILTER_READ(idx + 1, utf16_buffer,
10863 160 + (SvCUR(utf16_buffer) & 1));
10864 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10865 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10868 IoPAGE(filter) = status;
10873 chars = SvCUR(utf16_buffer) >> 1;
10874 have = SvCUR(utf8_buffer);
10875 SvGROW(utf8_buffer, have + chars * 3 + 1);
10878 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10879 (U8*)SvPVX_const(utf8_buffer) + have,
10880 chars * 2, &newlen);
10882 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10883 (U8*)SvPVX_const(utf8_buffer) + have,
10884 chars * 2, &newlen);
10886 SvCUR_set(utf8_buffer, have + newlen);
10889 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10890 it's private to us, and utf16_to_utf8{,reversed} take a
10891 (pointer,length) pair, rather than a NUL-terminated string. */
10892 if(SvCUR(utf16_buffer) & 1) {
10893 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10894 SvCUR_set(utf16_buffer, 1);
10896 SvCUR_set(utf16_buffer, 0);
10899 DEBUG_P(PerlIO_printf(Perl_debug_log,
10900 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10902 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10903 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10908 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10910 SV *filter = filter_add(S_utf16_textfilter, NULL);
10912 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10914 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10915 sv_setpvs(filter, "");
10916 IoLINES(filter) = reversed;
10917 IoPAGE(filter) = 1; /* Not EOF */
10919 /* Sadly, we have to return a valid pointer, come what may, so we have to
10920 ignore any error return from this. */
10921 SvCUR_set(PL_linestr, 0);
10922 if (FILTER_READ(0, PL_linestr, 0)) {
10923 SvUTF8_on(PL_linestr);
10925 SvUTF8_on(PL_linestr);
10927 PL_bufend = SvEND(PL_linestr);
10928 return (U8*)SvPVX(PL_linestr);
10933 Returns a pointer to the next character after the parsed
10934 vstring, as well as updating the passed in sv.
10936 Function must be called like
10938 sv = sv_2mortal(newSV(5));
10939 s = scan_vstring(s,e,sv);
10941 where s and e are the start and end of the string.
10942 The sv should already be large enough to store the vstring
10943 passed in, for performance reasons.
10945 This function may croak if fatal warnings are enabled in the
10946 calling scope, hence the sv_2mortal in the example (to prevent
10947 a leak). Make sure to do SvREFCNT_inc afterwards if you use
10953 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10955 const char *pos = s;
10956 const char *start = s;
10958 PERL_ARGS_ASSERT_SCAN_VSTRING;
10960 if (*pos == 'v') pos++; /* get past 'v' */
10961 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10963 if ( *pos != '.') {
10964 /* this may not be a v-string if followed by => */
10965 const char *next = pos;
10966 while (next < e && isSPACE(*next))
10968 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10969 /* return string not v-string */
10970 sv_setpvn(sv,(char *)s,pos-s);
10971 return (char *)pos;
10975 if (!isALPHA(*pos)) {
10976 U8 tmpbuf[UTF8_MAXBYTES+1];
10979 s++; /* get past 'v' */
10984 /* this is atoi() that tolerates underscores */
10987 const char *end = pos;
10989 while (--end >= s) {
10991 const UV orev = rev;
10992 rev += (*end - '0') * mult;
10995 /* diag_listed_as: Integer overflow in %s number */
10996 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10997 "Integer overflow in decimal number");
11001 if (rev > 0x7FFFFFFF)
11002 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11004 /* Append native character for the rev point */
11005 tmpend = uvchr_to_utf8(tmpbuf, rev);
11006 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11007 if (!UVCHR_IS_INVARIANT(rev))
11009 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11015 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11019 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11026 Perl_keyword_plugin_standard(pTHX_
11027 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11029 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11030 PERL_UNUSED_CONTEXT;
11031 PERL_UNUSED_ARG(keyword_ptr);
11032 PERL_UNUSED_ARG(keyword_len);
11033 PERL_UNUSED_ARG(op_ptr);
11034 return KEYWORD_PLUGIN_DECLINE;
11037 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11039 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11041 SAVEI32(PL_lex_brackets);
11042 if (PL_lex_brackets > 100)
11043 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11044 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11045 SAVEI32(PL_lex_allbrackets);
11046 PL_lex_allbrackets = 0;
11047 SAVEI8(PL_lex_fakeeof);
11048 PL_lex_fakeeof = (U8)fakeeof;
11049 if(yyparse(gramtype) && !PL_parser->error_count)
11050 qerror(Perl_mess(aTHX_ "Parse error"));
11053 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11055 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11059 SAVEVPTR(PL_eval_root);
11060 PL_eval_root = NULL;
11061 parse_recdescent(gramtype, fakeeof);
11067 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11069 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11072 if (flags & ~PARSE_OPTIONAL)
11073 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11074 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11075 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11076 if (!PL_parser->error_count)
11077 qerror(Perl_mess(aTHX_ "Parse error"));
11078 exprop = newOP(OP_NULL, 0);
11084 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11086 Parse a Perl arithmetic expression. This may contain operators of precedence
11087 down to the bit shift operators. The expression must be followed (and thus
11088 terminated) either by a comparison or lower-precedence operator or by
11089 something that would normally terminate an expression such as semicolon.
11090 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11091 otherwise it is mandatory. It is up to the caller to ensure that the
11092 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11093 the source of the code to be parsed and the lexical context for the
11096 The op tree representing the expression is returned. If an optional
11097 expression is absent, a null pointer is returned, otherwise the pointer
11100 If an error occurs in parsing or compilation, in most cases a valid op
11101 tree is returned anyway. The error is reflected in the parser state,
11102 normally resulting in a single exception at the top level of parsing
11103 which covers all the compilation errors that occurred. Some compilation
11104 errors, however, will throw an exception immediately.
11110 Perl_parse_arithexpr(pTHX_ U32 flags)
11112 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11116 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11118 Parse a Perl term expression. This may contain operators of precedence
11119 down to the assignment operators. The expression must be followed (and thus
11120 terminated) either by a comma or lower-precedence operator or by
11121 something that would normally terminate an expression such as semicolon.
11122 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11123 otherwise it is mandatory. It is up to the caller to ensure that the
11124 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11125 the source of the code to be parsed and the lexical context for the
11128 The op tree representing the expression is returned. If an optional
11129 expression is absent, a null pointer is returned, otherwise the pointer
11132 If an error occurs in parsing or compilation, in most cases a valid op
11133 tree is returned anyway. The error is reflected in the parser state,
11134 normally resulting in a single exception at the top level of parsing
11135 which covers all the compilation errors that occurred. Some compilation
11136 errors, however, will throw an exception immediately.
11142 Perl_parse_termexpr(pTHX_ U32 flags)
11144 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11148 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11150 Parse a Perl list expression. This may contain operators of precedence
11151 down to the comma operator. The expression must be followed (and thus
11152 terminated) either by a low-precedence logic operator such as C<or> or by
11153 something that would normally terminate an expression such as semicolon.
11154 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11155 otherwise it is mandatory. It is up to the caller to ensure that the
11156 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11157 the source of the code to be parsed and the lexical context for the
11160 The op tree representing the expression is returned. If an optional
11161 expression is absent, a null pointer is returned, otherwise the pointer
11164 If an error occurs in parsing or compilation, in most cases a valid op
11165 tree is returned anyway. The error is reflected in the parser state,
11166 normally resulting in a single exception at the top level of parsing
11167 which covers all the compilation errors that occurred. Some compilation
11168 errors, however, will throw an exception immediately.
11174 Perl_parse_listexpr(pTHX_ U32 flags)
11176 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11180 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11182 Parse a single complete Perl expression. This allows the full
11183 expression grammar, including the lowest-precedence operators such
11184 as C<or>. The expression must be followed (and thus terminated) by a
11185 token that an expression would normally be terminated by: end-of-file,
11186 closing bracketing punctuation, semicolon, or one of the keywords that
11187 signals a postfix expression-statement modifier. If I<flags> includes
11188 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11189 mandatory. It is up to the caller to ensure that the dynamic parser
11190 state (L</PL_parser> et al) is correctly set to reflect the source of
11191 the code to be parsed and the lexical context for the expression.
11193 The op tree representing the expression is returned. If an optional
11194 expression is absent, a null pointer is returned, otherwise the pointer
11197 If an error occurs in parsing or compilation, in most cases a valid op
11198 tree is returned anyway. The error is reflected in the parser state,
11199 normally resulting in a single exception at the top level of parsing
11200 which covers all the compilation errors that occurred. Some compilation
11201 errors, however, will throw an exception immediately.
11207 Perl_parse_fullexpr(pTHX_ U32 flags)
11209 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11213 =for apidoc Amx|OP *|parse_block|U32 flags
11215 Parse a single complete Perl code block. This consists of an opening
11216 brace, a sequence of statements, and a closing brace. The block
11217 constitutes a lexical scope, so C<my> variables and various compile-time
11218 effects can be contained within it. It is up to the caller to ensure
11219 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11220 reflect the source of the code to be parsed and the lexical context for
11223 The op tree representing the code block is returned. This is always a
11224 real op, never a null pointer. It will normally be a C<lineseq> list,
11225 including C<nextstate> or equivalent ops. No ops to construct any kind
11226 of runtime scope are included by virtue of it being a block.
11228 If an error occurs in parsing or compilation, in most cases a valid op
11229 tree (most likely null) is returned anyway. The error is reflected in
11230 the parser state, normally resulting in a single exception at the top
11231 level of parsing which covers all the compilation errors that occurred.
11232 Some compilation errors, however, will throw an exception immediately.
11234 The I<flags> parameter is reserved for future use, and must always
11241 Perl_parse_block(pTHX_ U32 flags)
11244 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11245 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11249 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11251 Parse a single unadorned Perl statement. This may be a normal imperative
11252 statement or a declaration that has compile-time effect. It does not
11253 include any label or other affixture. It is up to the caller to ensure
11254 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11255 reflect the source of the code to be parsed and the lexical context for
11258 The op tree representing the statement is returned. This may be a
11259 null pointer if the statement is null, for example if it was actually
11260 a subroutine definition (which has compile-time side effects). If not
11261 null, it will be ops directly implementing the statement, suitable to
11262 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11263 equivalent op (except for those embedded in a scope contained entirely
11264 within the statement).
11266 If an error occurs in parsing or compilation, in most cases a valid op
11267 tree (most likely null) is returned anyway. The error is reflected in
11268 the parser state, normally resulting in a single exception at the top
11269 level of parsing which covers all the compilation errors that occurred.
11270 Some compilation errors, however, will throw an exception immediately.
11272 The I<flags> parameter is reserved for future use, and must always
11279 Perl_parse_barestmt(pTHX_ U32 flags)
11282 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11283 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11287 =for apidoc Amx|SV *|parse_label|U32 flags
11289 Parse a single label, possibly optional, of the type that may prefix a
11290 Perl statement. It is up to the caller to ensure that the dynamic parser
11291 state (L</PL_parser> et al) is correctly set to reflect the source of
11292 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11293 label is optional, otherwise it is mandatory.
11295 The name of the label is returned in the form of a fresh scalar. If an
11296 optional label is absent, a null pointer is returned.
11298 If an error occurs in parsing, which can only occur if the label is
11299 mandatory, a valid label is returned anyway. The error is reflected in
11300 the parser state, normally resulting in a single exception at the top
11301 level of parsing which covers all the compilation errors that occurred.
11307 Perl_parse_label(pTHX_ U32 flags)
11309 if (flags & ~PARSE_OPTIONAL)
11310 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11311 if (PL_lex_state == LEX_KNOWNEXT) {
11312 PL_parser->yychar = yylex();
11313 if (PL_parser->yychar == LABEL) {
11314 char * const lpv = pl_yylval.pval;
11315 STRLEN llen = strlen(lpv);
11316 PL_parser->yychar = YYEMPTY;
11317 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11324 STRLEN wlen, bufptr_pos;
11327 if (!isIDFIRST_lazy_if(s, UTF))
11329 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11330 if (word_takes_any_delimeter(s, wlen))
11332 bufptr_pos = s - SvPVX(PL_linestr);
11334 lex_read_space(LEX_KEEP_PREVIOUS);
11336 s = SvPVX(PL_linestr) + bufptr_pos;
11337 if (t[0] == ':' && t[1] != ':') {
11338 PL_oldoldbufptr = PL_oldbufptr;
11341 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11345 if (flags & PARSE_OPTIONAL) {
11348 qerror(Perl_mess(aTHX_ "Parse error"));
11349 return newSVpvs("x");
11356 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11358 Parse a single complete Perl statement. This may be a normal imperative
11359 statement or a declaration that has compile-time effect, and may include
11360 optional labels. It is up to the caller to ensure that the dynamic
11361 parser state (L</PL_parser> et al) is correctly set to reflect the source
11362 of the code to be parsed and the lexical context for the statement.
11364 The op tree representing the statement is returned. This may be a
11365 null pointer if the statement is null, for example if it was actually
11366 a subroutine definition (which has compile-time side effects). If not
11367 null, it will be the result of a L</newSTATEOP> call, normally including
11368 a C<nextstate> or equivalent op.
11370 If an error occurs in parsing or compilation, in most cases a valid op
11371 tree (most likely null) is returned anyway. The error is reflected in
11372 the parser state, normally resulting in a single exception at the top
11373 level of parsing which covers all the compilation errors that occurred.
11374 Some compilation errors, however, will throw an exception immediately.
11376 The I<flags> parameter is reserved for future use, and must always
11383 Perl_parse_fullstmt(pTHX_ U32 flags)
11386 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11387 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11391 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11393 Parse a sequence of zero or more Perl statements. These may be normal
11394 imperative statements, including optional labels, or declarations
11395 that have compile-time effect, or any mixture thereof. The statement
11396 sequence ends when a closing brace or end-of-file is encountered in a
11397 place where a new statement could have validly started. It is up to
11398 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11399 is correctly set to reflect the source of the code to be parsed and the
11400 lexical context for the statements.
11402 The op tree representing the statement sequence is returned. This may
11403 be a null pointer if the statements were all null, for example if there
11404 were no statements or if there were only subroutine definitions (which
11405 have compile-time side effects). If not null, it will be a C<lineseq>
11406 list, normally including C<nextstate> or equivalent ops.
11408 If an error occurs in parsing or compilation, in most cases a valid op
11409 tree is returned anyway. The error is reflected in the parser state,
11410 normally resulting in a single exception at the top level of parsing
11411 which covers all the compilation errors that occurred. Some compilation
11412 errors, however, will throw an exception immediately.
11414 The I<flags> parameter is reserved for future use, and must always
11421 Perl_parse_stmtseq(pTHX_ U32 flags)
11426 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11427 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11428 c = lex_peek_unichar(0);
11429 if (c != -1 && c != /*{*/'}')
11430 qerror(Perl_mess(aTHX_ "Parse error"));
11434 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11436 S_lex_token_boundary(pTHX)
11438 PL_oldoldbufptr = PL_oldbufptr;
11439 PL_oldbufptr = PL_bufptr;
11442 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11444 S_parse_opt_lexvar(pTHX)
11449 lex_token_boundary();
11450 sigil = lex_read_unichar(0);
11451 if (lex_peek_unichar(0) == '#') {
11452 qerror(Perl_mess(aTHX_ "Parse error"));
11456 c = lex_peek_unichar(0);
11457 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11460 d = PL_tokenbuf + 1;
11461 PL_tokenbuf[0] = (char)sigil;
11462 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11464 if (d == PL_tokenbuf+1)
11466 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11467 OPf_MOD | (OPpLVAL_INTRO<<8));
11468 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11473 Perl_parse_subsignature(pTHX)
11476 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11477 OP *initops = NULL;
11479 c = lex_peek_unichar(0);
11480 while (c != /*(*/')') {
11484 if (prev_type == 2)
11485 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11486 var = parse_opt_lexvar();
11488 newBINOP(OP_AELEM, 0,
11489 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11491 newSVOP(OP_CONST, 0, newSViv(pos))) :
11494 c = lex_peek_unichar(0);
11496 lex_token_boundary();
11497 lex_read_unichar(0);
11499 c = lex_peek_unichar(0);
11500 if (c == ',' || c == /*(*/')') {
11502 qerror(Perl_mess(aTHX_ "Optional parameter "
11503 "lacks default expression"));
11505 OP *defexpr = parse_termexpr(0);
11506 if (defexpr->op_type == OP_UNDEF &&
11507 !(defexpr->op_flags & OPf_KIDS)) {
11512 scalar(newUNOP(OP_RV2AV, 0,
11513 newGVOP(OP_GV, 0, PL_defgv))),
11514 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11516 newCONDOP(0, ifop, expr, defexpr) :
11517 newLOGOP(OP_OR, 0, ifop, defexpr);
11522 if (prev_type == 1)
11523 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11524 "follows optional parameter"));
11526 min_arity = pos + 1;
11528 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11530 initops = op_append_list(OP_LINESEQ, initops,
11531 newSTATEOP(0, NULL, expr));
11537 if (prev_type == 2)
11538 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11539 var = parse_opt_lexvar();
11541 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11542 newBINOP(OP_BIT_AND, 0,
11543 scalar(newUNOP(OP_RV2AV, 0,
11544 newGVOP(OP_GV, 0, PL_defgv))),
11545 newSVOP(OP_CONST, 0, newSViv(1))),
11546 op_convert_list(OP_DIE, 0,
11547 op_convert_list(OP_SPRINTF, 0,
11548 op_append_list(OP_LIST,
11549 newSVOP(OP_CONST, 0,
11550 newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
11552 op_append_list(OP_LIST,
11553 newSVOP(OP_CONST, 0, newSViv(1)),
11554 newSVOP(OP_CONST, 0, newSViv(2))),
11555 newOP(OP_CALLER, 0))))));
11556 if (pos != min_arity)
11557 chkop = newLOGOP(OP_AND, 0,
11559 scalar(newUNOP(OP_RV2AV, 0,
11560 newGVOP(OP_GV, 0, PL_defgv))),
11561 newSVOP(OP_CONST, 0, newSViv(pos))),
11563 initops = op_append_list(OP_LINESEQ,
11564 newSTATEOP(0, NULL, chkop),
11569 op_prepend_elem(OP_ASLICE,
11570 newOP(OP_PUSHMARK, 0),
11571 newLISTOP(OP_ASLICE, 0,
11573 newSVOP(OP_CONST, 0, newSViv(pos)),
11574 newUNOP(OP_AV2ARYLEN, 0,
11575 ref(newUNOP(OP_RV2AV, 0,
11576 newGVOP(OP_GV, 0, PL_defgv)),
11578 ref(newUNOP(OP_RV2AV, 0,
11579 newGVOP(OP_GV, 0, PL_defgv)),
11581 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11582 initops = op_append_list(OP_LINESEQ, initops,
11583 newSTATEOP(0, NULL,
11584 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11591 qerror(Perl_mess(aTHX_ "Parse error"));
11595 c = lex_peek_unichar(0);
11597 case /*(*/')': break;
11600 lex_token_boundary();
11601 lex_read_unichar(0);
11603 c = lex_peek_unichar(0);
11604 } while (c == ',');
11610 if (min_arity != 0) {
11611 initops = op_append_list(OP_LINESEQ,
11612 newSTATEOP(0, NULL,
11615 scalar(newUNOP(OP_RV2AV, 0,
11616 newGVOP(OP_GV, 0, PL_defgv))),
11617 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11618 op_convert_list(OP_DIE, 0,
11619 op_convert_list(OP_SPRINTF, 0,
11620 op_append_list(OP_LIST,
11621 newSVOP(OP_CONST, 0,
11622 newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
11624 op_append_list(OP_LIST,
11625 newSVOP(OP_CONST, 0, newSViv(1)),
11626 newSVOP(OP_CONST, 0, newSViv(2))),
11627 newOP(OP_CALLER, 0))))))),
11630 if (max_arity != -1) {
11631 initops = op_append_list(OP_LINESEQ,
11632 newSTATEOP(0, NULL,
11635 scalar(newUNOP(OP_RV2AV, 0,
11636 newGVOP(OP_GV, 0, PL_defgv))),
11637 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11638 op_convert_list(OP_DIE, 0,
11639 op_convert_list(OP_SPRINTF, 0,
11640 op_append_list(OP_LIST,
11641 newSVOP(OP_CONST, 0,
11642 newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
11644 op_append_list(OP_LIST,
11645 newSVOP(OP_CONST, 0, newSViv(1)),
11646 newSVOP(OP_CONST, 0, newSViv(2))),
11647 newOP(OP_CALLER, 0))))))),
11655 * c-indentation-style: bsd
11656 * c-basic-offset: 4
11657 * indent-tabs-mode: nil
11660 * ex: set ts=8 sts=4 sw=4 et: