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 (!IN_BYTES)
104 # define UTF ((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, REPORT(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, REPORT((int)BITOROP)))
224 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
225 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
226 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((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, REPORT((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, REPORT((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 ((char)rv > ' ' && (char)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;
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 assert(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_ascii_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)
1990 * int allow_initial_tick : used by the "sub" lexer only.
1994 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
1999 PERL_ARGS_ASSERT_FORCE_WORD;
2001 start = skipspace(start);
2003 if (isIDFIRST_lazy_if(s,UTF) ||
2004 (allow_pack && *s == ':') )
2006 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2007 if (check_keyword) {
2008 char *s2 = PL_tokenbuf;
2009 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2011 if (keyword(s2, len, 0))
2014 if (token == METHOD) {
2019 PL_expect = XOPERATOR;
2022 NEXTVAL_NEXTTOKE.opval
2023 = (OP*)newSVOP(OP_CONST,0,
2024 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2025 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2033 * Called when the lexer wants $foo *foo &foo etc, but the program
2034 * text only contains the "foo" portion. The first argument is a pointer
2035 * to the "foo", and the second argument is the type symbol to prefix.
2036 * Forces the next token to be a "WORD".
2037 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2041 S_force_ident(pTHX_ const char *s, int kind)
2043 PERL_ARGS_ASSERT_FORCE_IDENT;
2046 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2047 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2048 UTF ? SVf_UTF8 : 0));
2049 NEXTVAL_NEXTTOKE.opval = o;
2052 o->op_private = OPpCONST_ENTERED;
2053 /* XXX see note in pp_entereval() for why we forgo typo
2054 warnings if the symbol must be introduced in an eval.
2056 gv_fetchpvn_flags(s, len,
2057 (PL_in_eval ? GV_ADDMULTI
2058 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2059 kind == '$' ? SVt_PV :
2060 kind == '@' ? SVt_PVAV :
2061 kind == '%' ? SVt_PVHV :
2069 S_force_ident_maybe_lex(pTHX_ char pit)
2071 NEXTVAL_NEXTTOKE.ival = pit;
2076 Perl_str_to_version(pTHX_ SV *sv)
2081 const char *start = SvPV_const(sv,len);
2082 const char * const end = start + len;
2083 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2085 PERL_ARGS_ASSERT_STR_TO_VERSION;
2087 while (start < end) {
2091 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2096 retval += ((NV)n)/nshift;
2105 * Forces the next token to be a version number.
2106 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2107 * and if "guessing" is TRUE, then no new token is created (and the caller
2108 * must use an alternative parsing method).
2112 S_force_version(pTHX_ char *s, int guessing)
2117 PERL_ARGS_ASSERT_FORCE_VERSION;
2125 while (isDIGIT(*d) || *d == '_' || *d == '.')
2127 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2129 s = scan_num(s, &pl_yylval);
2130 version = pl_yylval.opval;
2131 ver = cSVOPx(version)->op_sv;
2132 if (SvPOK(ver) && !SvNIOK(ver)) {
2133 SvUPGRADE(ver, SVt_PVNV);
2134 SvNV_set(ver, str_to_version(ver));
2135 SvNOK_on(ver); /* hint that it is a version */
2138 else if (guessing) {
2143 /* NOTE: The parser sees the package name and the VERSION swapped */
2144 NEXTVAL_NEXTTOKE.opval = version;
2151 * S_force_strict_version
2152 * Forces the next token to be a version number using strict syntax rules.
2156 S_force_strict_version(pTHX_ char *s)
2159 const char *errstr = NULL;
2161 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2163 while (isSPACE(*s)) /* leading whitespace */
2166 if (is_STRICT_VERSION(s,&errstr)) {
2168 s = (char *)scan_version(s, ver, 0);
2169 version = newSVOP(OP_CONST, 0, ver);
2171 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2172 (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2176 yyerror(errstr); /* version required */
2180 /* NOTE: The parser sees the package name and the VERSION swapped */
2181 NEXTVAL_NEXTTOKE.opval = version;
2189 * Tokenize a quoted string passed in as an SV. It finds the next
2190 * chunk, up to end of string or a backslash. It may make a new
2191 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2196 S_tokeq(pTHX_ SV *sv)
2203 PERL_ARGS_ASSERT_TOKEQ;
2207 assert (!SvIsCOW(sv));
2208 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2212 /* This is relying on the SV being "well formed" with a trailing '\0' */
2213 while (s < send && !(*s == '\\' && s[1] == '\\'))
2218 if ( PL_hints & HINT_NEW_STRING ) {
2219 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2220 SVs_TEMP | SvUTF8(sv));
2224 if (s + 1 < send && (s[1] == '\\'))
2225 s++; /* all that, just for this */
2230 SvCUR_set(sv, d - SvPVX_const(sv));
2232 if ( PL_hints & HINT_NEW_STRING )
2233 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2238 * Now come three functions related to double-quote context,
2239 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2240 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2241 * interact with PL_lex_state, and create fake ( ... ) argument lists
2242 * to handle functions and concatenation.
2246 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2251 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2253 * Pattern matching will set PL_lex_op to the pattern-matching op to
2254 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2256 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2258 * Everything else becomes a FUNC.
2260 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2261 * had an OP_CONST or OP_READLINE). This just sets us up for a
2262 * call to S_sublex_push().
2266 S_sublex_start(pTHX)
2268 const I32 op_type = pl_yylval.ival;
2270 if (op_type == OP_NULL) {
2271 pl_yylval.opval = PL_lex_op;
2275 if (op_type == OP_CONST) {
2276 SV *sv = tokeq(PL_lex_stuff);
2278 if (SvTYPE(sv) == SVt_PVIV) {
2279 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2281 const char * const p = SvPV_const(sv, len);
2282 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2286 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2287 PL_lex_stuff = NULL;
2291 PL_sublex_info.super_state = PL_lex_state;
2292 PL_sublex_info.sub_inwhat = (U16)op_type;
2293 PL_sublex_info.sub_op = PL_lex_op;
2294 PL_lex_state = LEX_INTERPPUSH;
2298 pl_yylval.opval = PL_lex_op;
2308 * Create a new scope to save the lexing state. The scope will be
2309 * ended in S_sublex_done. Returns a '(', starting the function arguments
2310 * to the uc, lc, etc. found before.
2311 * Sets PL_lex_state to LEX_INTERPCONCAT.
2318 const bool is_heredoc = PL_multi_close == '<';
2321 PL_lex_state = PL_sublex_info.super_state;
2322 SAVEI8(PL_lex_dojoin);
2323 SAVEI32(PL_lex_brackets);
2324 SAVEI32(PL_lex_allbrackets);
2325 SAVEI32(PL_lex_formbrack);
2326 SAVEI8(PL_lex_fakeeof);
2327 SAVEI32(PL_lex_casemods);
2328 SAVEI32(PL_lex_starts);
2329 SAVEI8(PL_lex_state);
2330 SAVESPTR(PL_lex_repl);
2331 SAVEVPTR(PL_lex_inpat);
2332 SAVEI16(PL_lex_inwhat);
2335 SAVECOPLINE(PL_curcop);
2336 SAVEI32(PL_multi_end);
2337 SAVEI32(PL_parser->herelines);
2338 PL_parser->herelines = 0;
2340 SAVEI8(PL_multi_close);
2341 SAVEPPTR(PL_bufptr);
2342 SAVEPPTR(PL_bufend);
2343 SAVEPPTR(PL_oldbufptr);
2344 SAVEPPTR(PL_oldoldbufptr);
2345 SAVEPPTR(PL_last_lop);
2346 SAVEPPTR(PL_last_uni);
2347 SAVEPPTR(PL_linestart);
2348 SAVESPTR(PL_linestr);
2349 SAVEGENERICPV(PL_lex_brackstack);
2350 SAVEGENERICPV(PL_lex_casestack);
2351 SAVEGENERICPV(PL_parser->lex_shared);
2352 SAVEBOOL(PL_parser->lex_re_reparsing);
2353 SAVEI32(PL_copline);
2355 /* The here-doc parser needs to be able to peek into outer lexing
2356 scopes to find the body of the here-doc. So we put PL_linestr and
2357 PL_bufptr into lex_shared, to ‘share’ those values.
2359 PL_parser->lex_shared->ls_linestr = PL_linestr;
2360 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2362 PL_linestr = PL_lex_stuff;
2363 PL_lex_repl = PL_sublex_info.repl;
2364 PL_lex_stuff = NULL;
2365 PL_sublex_info.repl = NULL;
2367 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2368 = SvPVX(PL_linestr);
2369 PL_bufend += SvCUR(PL_linestr);
2370 PL_last_lop = PL_last_uni = NULL;
2371 SAVEFREESV(PL_linestr);
2372 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2374 PL_lex_dojoin = FALSE;
2375 PL_lex_brackets = PL_lex_formbrack = 0;
2376 PL_lex_allbrackets = 0;
2377 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2378 Newx(PL_lex_brackstack, 120, char);
2379 Newx(PL_lex_casestack, 12, char);
2380 PL_lex_casemods = 0;
2381 *PL_lex_casestack = '\0';
2383 PL_lex_state = LEX_INTERPCONCAT;
2385 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2386 PL_copline = NOLINE;
2388 Newxz(shared, 1, LEXSHARED);
2389 shared->ls_prev = PL_parser->lex_shared;
2390 PL_parser->lex_shared = shared;
2392 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2393 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2394 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2395 PL_lex_inpat = PL_sublex_info.sub_op;
2397 PL_lex_inpat = NULL;
2399 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2400 PL_in_eval &= ~EVAL_RE_REPARSING;
2407 * Restores lexer state after a S_sublex_push.
2413 if (!PL_lex_starts++) {
2414 SV * const sv = newSVpvs("");
2415 if (SvUTF8(PL_linestr))
2417 PL_expect = XOPERATOR;
2418 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2422 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2423 PL_lex_state = LEX_INTERPCASEMOD;
2427 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2428 assert(PL_lex_inwhat != OP_TRANSR);
2430 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2431 PL_linestr = PL_lex_repl;
2433 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2434 PL_bufend += SvCUR(PL_linestr);
2435 PL_last_lop = PL_last_uni = NULL;
2436 PL_lex_dojoin = FALSE;
2437 PL_lex_brackets = 0;
2438 PL_lex_allbrackets = 0;
2439 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2440 PL_lex_casemods = 0;
2441 *PL_lex_casestack = '\0';
2443 if (SvEVALED(PL_lex_repl)) {
2444 PL_lex_state = LEX_INTERPNORMAL;
2446 /* we don't clear PL_lex_repl here, so that we can check later
2447 whether this is an evalled subst; that means we rely on the
2448 logic to ensure sublex_done() is called again only via the
2449 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2452 PL_lex_state = LEX_INTERPCONCAT;
2455 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2456 CopLINE(PL_curcop) +=
2457 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2458 + PL_parser->herelines;
2459 PL_parser->herelines = 0;
2464 const line_t l = CopLINE(PL_curcop);
2466 if (PL_multi_close == '<')
2467 PL_parser->herelines += l - PL_multi_end;
2468 PL_bufend = SvPVX(PL_linestr);
2469 PL_bufend += SvCUR(PL_linestr);
2470 PL_expect = XOPERATOR;
2471 PL_sublex_info.sub_inwhat = 0;
2476 PERL_STATIC_INLINE SV*
2477 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2479 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2480 * interior, hence to the "}". Finds what the name resolves to, returning
2481 * an SV* containing it; NULL if no valid one found */
2483 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2490 const U8* first_bad_char_loc;
2491 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2493 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2495 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2497 &first_bad_char_loc))
2499 /* If warnings are on, this will print a more detailed analysis of what
2500 * is wrong than the error message below */
2501 utf8n_to_uvchr(first_bad_char_loc,
2502 e - ((char *) first_bad_char_loc),
2505 /* We deliberately don't try to print the malformed character, which
2506 * might not print very well; it also may be just the first of many
2507 * malformations, so don't print what comes after it */
2508 yyerror(Perl_form(aTHX_
2509 "Malformed UTF-8 character immediately after '%.*s'",
2510 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2514 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2515 /* include the <}> */
2516 e - backslash_ptr + 1);
2518 SvREFCNT_dec_NN(res);
2522 /* See if the charnames handler is the Perl core's, and if so, we can skip
2523 * the validation needed for a user-supplied one, as Perl's does its own
2525 table = GvHV(PL_hintgv); /* ^H */
2526 cvp = hv_fetchs(table, "charnames", FALSE);
2527 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2528 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2530 const char * const name = HvNAME(stash);
2531 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2532 && strEQ(name, "_charnames")) {
2537 /* Here, it isn't Perl's charname handler. We can't rely on a
2538 * user-supplied handler to validate the input name. For non-ut8 input,
2539 * look to see that the first character is legal. Then loop through the
2540 * rest checking that each is a continuation */
2542 /* This code makes the reasonable assumption that the only Latin1-range
2543 * characters that begin a character name alias are alphabetic, otherwise
2544 * would have to create a isCHARNAME_BEGIN macro */
2547 if (! isALPHAU(*s)) {
2552 if (! isCHARNAME_CONT(*s)) {
2555 if (*s == ' ' && *(s-1) == ' ') {
2558 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2559 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2560 "NO-BREAK SPACE in a charnames "
2561 "alias definition is deprecated");
2567 /* Similarly for utf8. For invariants can check directly; for other
2568 * Latin1, can calculate their code point and check; otherwise use a
2570 if (UTF8_IS_INVARIANT(*s)) {
2571 if (! isALPHAU(*s)) {
2575 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2576 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2582 if (! PL_utf8_charname_begin) {
2583 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2584 PL_utf8_charname_begin = _core_swash_init("utf8",
2585 "_Perl_Charname_Begin",
2587 1, 0, NULL, &flags);
2589 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2596 if (UTF8_IS_INVARIANT(*s)) {
2597 if (! isCHARNAME_CONT(*s)) {
2600 if (*s == ' ' && *(s-1) == ' ') {
2605 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2606 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2610 if (*s == *NBSP_UTF8
2611 && *(s+1) == *(NBSP_UTF8+1)
2612 && ckWARN_d(WARN_DEPRECATED))
2614 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2615 "NO-BREAK SPACE in a charnames "
2616 "alias definition is deprecated");
2621 if (! PL_utf8_charname_continue) {
2622 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2623 PL_utf8_charname_continue = _core_swash_init("utf8",
2624 "_Perl_Charname_Continue",
2626 1, 0, NULL, &flags);
2628 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2635 if (*(s-1) == ' ') {
2638 "charnames alias definitions may not contain trailing "
2639 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2640 (int)(s - backslash_ptr + 1), backslash_ptr,
2641 (int)(e - s + 1), s + 1
2643 UTF ? SVf_UTF8 : 0);
2647 if (SvUTF8(res)) { /* Don't accept malformed input */
2648 const U8* first_bad_char_loc;
2650 const char* const str = SvPV_const(res, len);
2651 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2652 /* If warnings are on, this will print a more detailed analysis of
2653 * what is wrong than the error message below */
2654 utf8n_to_uvchr(first_bad_char_loc,
2655 (char *) first_bad_char_loc - str,
2658 /* We deliberately don't try to print the malformed character,
2659 * which might not print very well; it also may be just the first
2660 * of many malformations, so don't print what comes after it */
2663 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2664 (int) (e - backslash_ptr + 1), backslash_ptr,
2665 (int) ((char *) first_bad_char_loc - str), str
2676 /* The final %.*s makes sure that should the trailing NUL be missing
2677 * that this print won't run off the end of the string */
2680 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2681 (int)(s - backslash_ptr + 1), backslash_ptr,
2682 (int)(e - s + 1), s + 1
2684 UTF ? SVf_UTF8 : 0);
2691 "charnames alias definitions may not contain a sequence of "
2692 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2693 (int)(s - backslash_ptr + 1), backslash_ptr,
2694 (int)(e - s + 1), s + 1
2696 UTF ? SVf_UTF8 : 0);
2703 Extracts the next constant part of a pattern, double-quoted string,
2704 or transliteration. This is terrifying code.
2706 For example, in parsing the double-quoted string "ab\x63$d", it would
2707 stop at the '$' and return an OP_CONST containing 'abc'.
2709 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2710 processing a pattern (PL_lex_inpat is true), a transliteration
2711 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2713 Returns a pointer to the character scanned up to. If this is
2714 advanced from the start pointer supplied (i.e. if anything was
2715 successfully parsed), will leave an OP_CONST for the substring scanned
2716 in pl_yylval. Caller must intuit reason for not parsing further
2717 by looking at the next characters herself.
2721 \N{FOO} => \N{U+hex_for_character_FOO}
2722 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2725 all other \-char, including \N and \N{ apart from \N{ABC}
2728 @ and $ where it appears to be a var, but not for $ as tail anchor
2733 In transliterations:
2734 characters are VERY literal, except for - not at the start or end
2735 of the string, which indicates a range. If the range is in bytes,
2736 scan_const expands the range to the full set of intermediate
2737 characters. If the range is in utf8, the hyphen is replaced with
2738 a certain range mark which will be handled by pmtrans() in op.c.
2740 In double-quoted strings:
2742 double-quoted style: \r and \n
2743 constants: \x31, etc.
2744 deprecated backrefs: \1 (in substitution replacements)
2745 case and quoting: \U \Q \E
2748 scan_const does *not* construct ops to handle interpolated strings.
2749 It stops processing as soon as it finds an embedded $ or @ variable
2750 and leaves it to the caller to work out what's going on.
2752 embedded arrays (whether in pattern or not) could be:
2753 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2755 $ in double-quoted strings must be the symbol of an embedded scalar.
2757 $ in pattern could be $foo or could be tail anchor. Assumption:
2758 it's a tail anchor if $ is the last thing in the string, or if it's
2759 followed by one of "()| \r\n\t"
2761 \1 (backreferences) are turned into $1 in substitutions
2763 The structure of the code is
2764 while (there's a character to process) {
2765 handle transliteration ranges
2766 skip regexp comments /(?#comment)/ and codes /(?{code})/
2767 skip #-initiated comments in //x patterns
2768 check for embedded arrays
2769 check for embedded scalars
2771 deprecate \1 in substitution replacements
2772 handle string-changing backslashes \l \U \Q \E, etc.
2773 switch (what was escaped) {
2774 handle \- in a transliteration (becomes a literal -)
2775 if a pattern and not \N{, go treat as regular character
2776 handle \132 (octal characters)
2777 handle \x15 and \x{1234} (hex characters)
2778 handle \N{name} (named characters, also \N{3,5} in a pattern)
2779 handle \cV (control characters)
2780 handle printf-style backslashes (\f, \r, \n, etc)
2783 } (end if backslash)
2784 handle regular character
2785 } (end while character to read)
2790 S_scan_const(pTHX_ char *start)
2792 char *send = PL_bufend; /* end of the constant */
2793 SV *sv = newSV(send - start); /* sv for the constant. See note below
2795 char *s = start; /* start of the constant */
2796 char *d = SvPVX(sv); /* destination for copies */
2797 bool dorange = FALSE; /* are we in a translit range? */
2798 bool didrange = FALSE; /* did we just finish a range? */
2799 bool in_charclass = FALSE; /* within /[...]/ */
2800 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2801 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2802 UTF8? But, this can show as true
2803 when the source isn't utf8, as for
2804 example when it is entirely composed
2806 SV *res; /* result from charnames */
2808 /* Note on sizing: The scanned constant is placed into sv, which is
2809 * initialized by newSV() assuming one byte of output for every byte of
2810 * input. This routine expects newSV() to allocate an extra byte for a
2811 * trailing NUL, which this routine will append if it gets to the end of
2812 * the input. There may be more bytes of input than output (eg., \N{LATIN
2813 * CAPITAL LETTER A}), or more output than input if the constant ends up
2814 * recoded to utf8, but each time a construct is found that might increase
2815 * the needed size, SvGROW() is called. Its size parameter each time is
2816 * based on the best guess estimate at the time, namely the length used so
2817 * far, plus the length the current construct will occupy, plus room for
2818 * the trailing NUL, plus one byte for every input byte still unscanned */
2820 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2823 UV literal_endpoint = 0;
2824 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2827 PERL_ARGS_ASSERT_SCAN_CONST;
2829 assert(PL_lex_inwhat != OP_TRANSR);
2830 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2831 /* If we are doing a trans and we know we want UTF8 set expectation */
2832 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2833 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2836 /* Protect sv from errors and fatal warnings. */
2837 ENTER_with_name("scan_const");
2840 while (s < send || dorange) {
2842 /* get transliterations out of the way (they're most literal) */
2843 if (PL_lex_inwhat == OP_TRANS) {
2844 /* expand a range A-Z to the full set of characters. AIE! */
2846 I32 i; /* current expanded character */
2847 I32 min; /* first character in range */
2848 I32 max; /* last character in range */
2859 char * const c = (char*)utf8_hop((U8*)d, -1);
2863 *c = (char) ILLEGAL_UTF8_BYTE;
2864 /* mark the range as done, and continue */
2870 i = d - SvPVX_const(sv); /* remember current offset */
2873 SvLEN(sv) + ((has_utf8)
2874 ? (512 - UTF_CONTINUATION_MARK
2877 /* How many two-byte within 0..255: 128 in UTF-8,
2878 * 96 in UTF-8-mod. */
2880 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2882 d = SvPVX(sv) + i; /* refresh d after realloc */
2886 for (j = 0; j <= 1; j++) {
2887 char * const c = (char*)utf8_hop((U8*)d, -1);
2888 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2894 max = (U8)0xff; /* only to \xff */
2895 uvmax = uv; /* \x{100} to uvmax */
2897 d = c; /* eat endpoint chars */
2902 d -= 2; /* eat the first char and the - */
2903 min = (U8)*d; /* first char in range */
2904 max = (U8)d[1]; /* last char in range */
2911 "Invalid range \"%c-%c\" in transliteration operator",
2912 (char)min, (char)max);
2916 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2917 * any subsets of these ranges into individual characters */
2918 if (literal_endpoint == 2 &&
2919 ((isLOWER_A(min) && isLOWER_A(max)) ||
2920 (isUPPER_A(min) && isUPPER_A(max))))
2922 for (i = min; i <= max; i++) {
2929 for (i = min; i <= max; i++)
2932 append_utf8_from_native_byte(i, &d);
2940 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2942 *d++ = (char) ILLEGAL_UTF8_BYTE;
2944 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2948 /* mark the range as done, and continue */
2952 literal_endpoint = 0;
2957 /* range begins (ignore - as first or last char) */
2958 else if (*s == '-' && s+1 < send && s != start) {
2960 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2967 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2977 literal_endpoint = 0;
2978 native_range = TRUE;
2983 /* if we get here, we're not doing a transliteration */
2985 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2988 while (s1 >= start && *s1-- == '\\')
2991 in_charclass = TRUE;
2994 else if (*s == ']' && PL_lex_inpat && in_charclass) {
2997 while (s1 >= start && *s1-- == '\\')
3000 in_charclass = FALSE;
3003 /* skip for regexp comments /(?#comment)/, except for the last
3004 * char, which will be done separately.
3005 * Stop on (?{..}) and friends */
3007 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3009 while (s+1 < send && *s != ')')
3012 else if (!PL_lex_casemods &&
3013 ( s[2] == '{' /* This should match regcomp.c */
3014 || (s[2] == '?' && s[3] == '{')))
3020 /* likewise skip #-initiated comments in //x patterns */
3021 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3022 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3023 while (s+1 < send && *s != '\n')
3027 /* no further processing of single-quoted regex */
3028 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3029 goto default_action;
3031 /* check for embedded arrays
3032 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3034 else if (*s == '@' && s[1]) {
3035 if (isWORDCHAR_lazy_if(s+1,UTF))
3037 if (strchr(":'{$", s[1]))
3039 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3040 break; /* in regexp, neither @+ nor @- are interpolated */
3043 /* check for embedded scalars. only stop if we're sure it's a
3046 else if (*s == '$') {
3047 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3049 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3051 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3052 "Possible unintended interpolation of $\\ in regex");
3054 break; /* in regexp, $ might be tail anchor */
3058 /* End of else if chain - OP_TRANS rejoin rest */
3061 if (*s == '\\' && s+1 < send) {
3062 char* e; /* Can be used for ending '}', etc. */
3066 /* warn on \1 - \9 in substitution replacements, but note that \11
3067 * is an octal; and \19 is \1 followed by '9' */
3068 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3069 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3071 /* diag_listed_as: \%d better written as $%d */
3072 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3077 /* string-change backslash escapes */
3078 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3082 /* In a pattern, process \N, but skip any other backslash escapes.
3083 * This is because we don't want to translate an escape sequence
3084 * into a meta symbol and have the regex compiler use the meta
3085 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3086 * in spite of this, we do have to process \N here while the proper
3087 * 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(sv,
3193 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3194 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3195 d = SvPVX(sv) + SvCUR(sv);
3200 d = (char*)uvchr_to_utf8((U8*)d, uv);
3201 if (PL_lex_inwhat == OP_TRANS &&
3202 PL_sublex_info.sub_op) {
3203 PL_sublex_info.sub_op->op_private |=
3204 (PL_lex_repl ? OPpTRANS_FROM_UTF
3208 if (uv > 255 && !dorange)
3209 native_range = FALSE;
3222 /* In a non-pattern \N must be a named character, like \N{LATIN
3223 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3224 * mean to match a non-newline. For non-patterns, named
3225 * characters are converted to their string equivalents. In
3226 * patterns, named characters are not converted to their
3227 * ultimate forms for the same reasons that other escapes
3228 * aren't. Instead, they are converted to the \N{U+...} form
3229 * to get the value from the charnames that is in effect right
3230 * now, while preserving the fact that it was a named character
3231 * so that the regex compiler knows this */
3233 /* The structure of this section of code (besides checking for
3234 * errors and upgrading to utf8) is:
3235 * Further disambiguate between the two meanings of \N, and if
3236 * not a charname, go process it elsewhere
3237 * If of form \N{U+...}, pass it through if a pattern;
3238 * otherwise convert to utf8
3239 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3240 * pattern; otherwise convert to utf8 */
3242 /* Here, s points to the 'N'; the test below is guaranteed to
3243 * succeed if we are being called on a pattern as we already
3244 * know from a test above that the next character is a '{'.
3245 * On a non-pattern \N must mean 'named sequence, which
3246 * requires braces */
3249 yyerror("Missing braces on \\N{}");
3254 /* If there is no matching '}', it is an error. */
3255 if (! (e = strchr(s, '}'))) {
3256 if (! PL_lex_inpat) {
3257 yyerror("Missing right brace on \\N{}");
3259 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3264 /* Here it looks like a named character */
3266 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3267 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3268 | PERL_SCAN_DISALLOW_PREFIX;
3271 /* For \N{U+...}, the '...' is a unicode value even on
3272 * EBCDIC machines */
3273 s += 2; /* Skip to next char after the 'U+' */
3275 uv = grok_hex(s, &len, &flags, NULL);
3276 if (len == 0 || len != (STRLEN)(e - s)) {
3277 yyerror("Invalid hexadecimal number in \\N{U+...}");
3284 /* On non-EBCDIC platforms, pass through to the regex
3285 * compiler unchanged. The reason we evaluated the
3286 * number above is to make sure there wasn't a syntax
3287 * error. But on EBCDIC we convert to native so
3288 * downstream code can continue to assume it's native
3290 s -= 5; /* Include the '\N{U+' */
3292 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3295 (unsigned int) UNI_TO_NATIVE(uv));
3297 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3301 else { /* Not a pattern: convert the hex to string */
3303 /* If destination is not in utf8, unconditionally
3304 * recode it to be so. This is because \N{} implies
3305 * Unicode semantics, and scalars have to be in utf8
3306 * to guarantee those semantics */
3308 SvCUR_set(sv, d - SvPVX_const(sv));
3311 /* See Note on sizing above. */
3312 sv_utf8_upgrade_flags_grow(
3314 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3315 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3316 d = SvPVX(sv) + SvCUR(sv);
3320 /* Add the (Unicode) code point to the output. */
3321 if (UNI_IS_INVARIANT(uv)) {
3322 *d++ = (char) LATIN1_TO_NATIVE(uv);
3325 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3329 else /* Here is \N{NAME} but not \N{U+...}. */
3330 if ((res = get_and_check_backslash_N_name(s, e)))
3333 const char *str = SvPV_const(res, len);
3336 if (! len) { /* The name resolved to an empty string */
3337 Copy("\\N{}", d, 4, char);
3341 /* In order to not lose information for the regex
3342 * compiler, pass the result in the specially made
3343 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3344 * the code points in hex of each character
3345 * returned by charnames */
3347 const char *str_end = str + len;
3348 const STRLEN off = d - SvPVX_const(sv);
3350 if (! SvUTF8(res)) {
3351 /* For the non-UTF-8 case, we can determine the
3352 * exact length needed without having to parse
3353 * through the string. Each character takes up
3354 * 2 hex digits plus either a trailing dot or
3356 d = off + SvGROW(sv, off
3358 + 6 /* For the "\N{U+", and
3360 + (STRLEN)(send - e));
3361 Copy("\\N{U+", d, 5, char);
3363 while (str < str_end) {
3366 my_snprintf(hex_string,
3368 "%02X.", (U8) *str);
3369 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3370 Copy(hex_string, d, 3, char);
3374 d--; /* We will overwrite below the final
3375 dot with a right brace */
3378 STRLEN char_length; /* cur char's byte length */
3380 /* and the number of bytes after this is
3381 * translated into hex digits */
3382 STRLEN output_length;
3384 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3385 * for max('U+', '.'); and 1 for NUL */
3386 char hex_string[2 * UTF8_MAXBYTES + 5];
3388 /* Get the first character of the result. */
3389 U32 uv = utf8n_to_uvchr((U8 *) str,
3393 /* Convert first code point to hex, including
3394 * the boiler plate before it. */
3396 my_snprintf(hex_string, sizeof(hex_string),
3400 /* Make sure there is enough space to hold it */
3401 d = off + SvGROW(sv, off
3403 + (STRLEN)(send - e)
3404 + 2); /* '}' + NUL */
3406 Copy(hex_string, d, output_length, char);
3409 /* For each subsequent character, append dot and
3410 * its ordinal in hex */
3411 while ((str += char_length) < str_end) {
3412 const STRLEN off = d - SvPVX_const(sv);
3413 U32 uv = utf8n_to_uvchr((U8 *) str,
3418 my_snprintf(hex_string,
3423 d = off + SvGROW(sv, off
3425 + (STRLEN)(send - e)
3426 + 2); /* '}' + NUL */
3427 Copy(hex_string, d, output_length, char);
3432 *d++ = '}'; /* Done. Add the trailing brace */
3435 else { /* Here, not in a pattern. Convert the name to a
3438 /* If destination is not in utf8, unconditionally
3439 * recode it to be so. This is because \N{} implies
3440 * Unicode semantics, and scalars have to be in utf8
3441 * to guarantee those semantics */
3443 SvCUR_set(sv, d - SvPVX_const(sv));
3446 /* See Note on sizing above. */
3447 sv_utf8_upgrade_flags_grow(sv,
3448 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3449 len + (STRLEN)(send - s) + 1);
3450 d = SvPVX(sv) + SvCUR(sv);
3452 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3454 /* See Note on sizing above. (NOTE: SvCUR() is not
3455 * set correctly here). */
3456 const STRLEN off = d - SvPVX_const(sv);
3457 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3459 if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
3460 sv_utf8_upgrade(res);
3461 str = SvPV_const(res, len);
3463 Copy(str, d, len, char);
3469 } /* End \N{NAME} */
3472 native_range = FALSE; /* \N{} is defined to be Unicode */
3474 s = e + 1; /* Point to just after the '}' */
3477 /* \c is a control character */
3481 *d++ = grok_bslash_c(*s++, 1);
3484 yyerror("Missing control char name in \\c");
3488 /* printf-style backslashes, formfeeds, newlines, etc */
3514 } /* end if (backslash) */
3521 /* If we started with encoded form, or already know we want it,
3522 then encode the next character */
3523 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3527 /* One might think that it is wasted effort in the case of the
3528 * source being utf8 (this_utf8 == TRUE) to take the next character
3529 * in the source, convert it to an unsigned value, and then convert
3530 * it back again. But the source has not been validated here. The
3531 * routine that does the conversion checks for errors like
3534 const UV nextuv = (this_utf8)
3535 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3537 const STRLEN need = UNISKIP(nextuv);
3539 SvCUR_set(sv, d - SvPVX_const(sv));
3542 /* See Note on sizing above. */
3543 sv_utf8_upgrade_flags_grow(sv,
3544 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3545 need + (STRLEN)(send - s) + 1);
3546 d = SvPVX(sv) + SvCUR(sv);
3548 } else if (need > len) {
3549 /* encoded value larger than old, may need extra space (NOTE:
3550 * SvCUR() is not set correctly here). See Note on sizing
3552 const STRLEN off = d - SvPVX_const(sv);
3553 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3557 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3559 if (uv > 255 && !dorange)
3560 native_range = FALSE;
3566 } /* while loop to process each character */
3568 /* terminate the string and set up the sv */
3570 SvCUR_set(sv, d - SvPVX_const(sv));
3571 if (SvCUR(sv) >= SvLEN(sv))
3572 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3573 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3576 if (PL_encoding && !has_utf8) {
3577 sv_recode_to_utf8(sv, PL_encoding);
3583 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3584 PL_sublex_info.sub_op->op_private |=
3585 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3589 /* shrink the sv if we allocated more than we used */
3590 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3591 SvPV_shrink_to_cur(sv);
3594 /* return the substring (via pl_yylval) only if we parsed anything */
3597 for (; s2 < s; s2++) {
3599 COPLINE_INC_WITH_HERELINES;
3601 SvREFCNT_inc_simple_void_NN(sv);
3602 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3603 && ! PL_parser->lex_re_reparsing)
3605 const char *const key = PL_lex_inpat ? "qr" : "q";
3606 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3610 if (PL_lex_inwhat == OP_TRANS) {
3613 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3616 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3624 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3627 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3629 LEAVE_with_name("scan_const");
3634 * Returns TRUE if there's more to the expression (e.g., a subscript),
3637 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3639 * ->[ and ->{ return TRUE
3640 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3641 * { and [ outside a pattern are always subscripts, so return TRUE
3642 * if we're outside a pattern and it's not { or [, then return FALSE
3643 * if we're in a pattern and the first char is a {
3644 * {4,5} (any digits around the comma) returns FALSE
3645 * if we're in a pattern and the first char is a [
3647 * [SOMETHING] has a funky algorithm to decide whether it's a
3648 * character class or not. It has to deal with things like
3649 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3650 * anything else returns TRUE
3653 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3656 S_intuit_more(pTHX_ char *s)
3658 PERL_ARGS_ASSERT_INTUIT_MORE;
3660 if (PL_lex_brackets)
3662 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3664 if (*s == '-' && s[1] == '>'
3665 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3666 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3667 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3669 if (*s != '{' && *s != '[')
3674 /* In a pattern, so maybe we have {n,m}. */
3682 /* On the other hand, maybe we have a character class */
3685 if (*s == ']' || *s == '^')
3688 /* this is terrifying, and it works */
3691 const char * const send = strchr(s,']');
3692 unsigned char un_char, last_un_char;
3693 char tmpbuf[sizeof PL_tokenbuf * 4];
3695 if (!send) /* has to be an expression */
3697 weight = 2; /* let's weigh the evidence */
3701 else if (isDIGIT(*s)) {
3703 if (isDIGIT(s[1]) && s[2] == ']')
3709 Zero(seen,256,char);
3711 for (; s < send; s++) {
3712 last_un_char = un_char;
3713 un_char = (unsigned char)*s;
3718 weight -= seen[un_char] * 10;
3719 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3721 char *tmp = PL_bufend;
3722 PL_bufend = (char*)send;
3723 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3725 len = (int)strlen(tmpbuf);
3726 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3727 UTF ? SVf_UTF8 : 0, SVt_PV))
3732 else if (*s == '$' && s[1] &&
3733 strchr("[#!%*<>()-=",s[1])) {
3734 if (/*{*/ strchr("])} =",s[2]))
3743 if (strchr("wds]",s[1]))
3745 else if (seen[(U8)'\''] || seen[(U8)'"'])
3747 else if (strchr("rnftbxcav",s[1]))
3749 else if (isDIGIT(s[1])) {
3751 while (s[1] && isDIGIT(s[1]))
3761 if (strchr("aA01! ",last_un_char))
3763 if (strchr("zZ79~",s[1]))
3765 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3766 weight -= 5; /* cope with negative subscript */
3769 if (!isWORDCHAR(last_un_char)
3770 && !(last_un_char == '$' || last_un_char == '@'
3771 || last_un_char == '&')
3772 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3777 if (keyword(tmpbuf, d - tmpbuf, 0))
3780 if (un_char == last_un_char + 1)
3782 weight -= seen[un_char];
3787 if (weight >= 0) /* probably a character class */
3797 * Does all the checking to disambiguate
3799 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3800 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3802 * First argument is the stuff after the first token, e.g. "bar".
3804 * Not a method if foo is a filehandle.
3805 * Not a method if foo is a subroutine prototyped to take a filehandle.
3806 * Not a method if it's really "Foo $bar"
3807 * Method if it's "foo $bar"
3808 * Not a method if it's really "print foo $bar"
3809 * Method if it's really "foo package::" (interpreted as package->foo)
3810 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3811 * Not a method if bar is a filehandle or package, but is quoted with
3816 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3818 char *s = start + (*start == '$');
3819 char tmpbuf[sizeof PL_tokenbuf];
3822 /* Mustn't actually add anything to a symbol table.
3823 But also don't want to "initialise" any placeholder
3824 constants that might already be there into full
3825 blown PVGVs with attached PVCV. */
3827 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3829 PERL_ARGS_ASSERT_INTUIT_METHOD;
3831 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3833 if (cv && SvPOK(cv)) {
3834 const char *proto = CvPROTO(cv);
3836 while (*proto && (isSPACE(*proto) || *proto == ';'))
3843 if (*start == '$') {
3844 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3845 isUPPER(*PL_tokenbuf))
3850 return *s == '(' ? FUNCMETH : METHOD;
3853 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3854 /* start is the beginning of the possible filehandle/object,
3855 * and s is the end of it
3856 * tmpbuf is a copy of it (but with single quotes as double colons)
3859 if (!keyword(tmpbuf, len, 0)) {
3860 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3865 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3866 if (indirgv && GvCVu(indirgv))
3868 /* filehandle or package name makes it a method */
3869 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3871 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3872 return 0; /* no assumptions -- "=>" quotes bareword */
3874 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3875 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3876 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3880 return *s == '(' ? FUNCMETH : METHOD;
3886 /* Encoded script support. filter_add() effectively inserts a
3887 * 'pre-processing' function into the current source input stream.
3888 * Note that the filter function only applies to the current source file
3889 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3891 * The datasv parameter (which may be NULL) can be used to pass
3892 * private data to this instance of the filter. The filter function
3893 * can recover the SV using the FILTER_DATA macro and use it to
3894 * store private buffers and state information.
3896 * The supplied datasv parameter is upgraded to a PVIO type
3897 * and the IoDIRP/IoANY field is used to store the function pointer,
3898 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3899 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3900 * private use must be set using malloc'd pointers.
3904 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3912 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3913 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3915 if (!PL_rsfp_filters)
3916 PL_rsfp_filters = newAV();
3919 SvUPGRADE(datasv, SVt_PVIO);
3920 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3921 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3922 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3923 FPTR2DPTR(void *, IoANY(datasv)),
3924 SvPV_nolen(datasv)));
3925 av_unshift(PL_rsfp_filters, 1);
3926 av_store(PL_rsfp_filters, 0, datasv) ;
3928 !PL_parser->filtered
3929 && PL_parser->lex_flags & LEX_EVALBYTES
3930 && PL_bufptr < PL_bufend
3932 const char *s = PL_bufptr;
3933 while (s < PL_bufend) {
3935 SV *linestr = PL_parser->linestr;
3936 char *buf = SvPVX(linestr);
3937 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3938 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3939 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3940 STRLEN const linestart_pos = PL_parser->linestart - buf;
3941 STRLEN const last_uni_pos =
3942 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3943 STRLEN const last_lop_pos =
3944 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3945 av_push(PL_rsfp_filters, linestr);
3946 PL_parser->linestr =
3947 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3948 buf = SvPVX(PL_parser->linestr);
3949 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3950 PL_parser->bufptr = buf + bufptr_pos;
3951 PL_parser->oldbufptr = buf + oldbufptr_pos;
3952 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3953 PL_parser->linestart = buf + linestart_pos;
3954 if (PL_parser->last_uni)
3955 PL_parser->last_uni = buf + last_uni_pos;
3956 if (PL_parser->last_lop)
3957 PL_parser->last_lop = buf + last_lop_pos;
3958 SvLEN(linestr) = SvCUR(linestr);
3959 SvCUR(linestr) = s-SvPVX(linestr);
3960 PL_parser->filtered = 1;
3970 /* Delete most recently added instance of this filter function. */
3972 Perl_filter_del(pTHX_ filter_t funcp)
3976 PERL_ARGS_ASSERT_FILTER_DEL;
3979 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3980 FPTR2DPTR(void*, funcp)));
3982 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3984 /* if filter is on top of stack (usual case) just pop it off */
3985 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3986 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3987 sv_free(av_pop(PL_rsfp_filters));
3991 /* we need to search for the correct entry and clear it */
3992 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3996 /* Invoke the idxth filter function for the current rsfp. */
3997 /* maxlen 0 = read one text line */
3999 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4003 /* This API is bad. It should have been using unsigned int for maxlen.
4004 Not sure if we want to change the API, but if not we should sanity
4005 check the value here. */
4006 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4008 PERL_ARGS_ASSERT_FILTER_READ;
4010 if (!PL_parser || !PL_rsfp_filters)
4012 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4013 /* Provide a default input filter to make life easy. */
4014 /* Note that we append to the line. This is handy. */
4015 DEBUG_P(PerlIO_printf(Perl_debug_log,
4016 "filter_read %d: from rsfp\n", idx));
4017 if (correct_length) {
4020 const int old_len = SvCUR(buf_sv);
4022 /* ensure buf_sv is large enough */
4023 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4024 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4025 correct_length)) <= 0) {
4026 if (PerlIO_error(PL_rsfp))
4027 return -1; /* error */
4029 return 0 ; /* end of file */
4031 SvCUR_set(buf_sv, old_len + len) ;
4032 SvPVX(buf_sv)[old_len + len] = '\0';
4035 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4036 if (PerlIO_error(PL_rsfp))
4037 return -1; /* error */
4039 return 0 ; /* end of file */
4042 return SvCUR(buf_sv);
4044 /* Skip this filter slot if filter has been deleted */
4045 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4046 DEBUG_P(PerlIO_printf(Perl_debug_log,
4047 "filter_read %d: skipped (filter deleted)\n",
4049 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4051 if (SvTYPE(datasv) != SVt_PVIO) {
4052 if (correct_length) {
4054 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4055 if (!remainder) return 0; /* eof */
4056 if (correct_length > remainder) correct_length = remainder;
4057 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4058 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4061 const char *s = SvEND(datasv);
4062 const char *send = SvPVX(datasv) + SvLEN(datasv);
4070 if (s == send) return 0; /* eof */
4071 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4072 SvCUR_set(datasv, s-SvPVX(datasv));
4074 return SvCUR(buf_sv);
4076 /* Get function pointer hidden within datasv */
4077 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4078 DEBUG_P(PerlIO_printf(Perl_debug_log,
4079 "filter_read %d: via function %p (%s)\n",
4080 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4081 /* Call function. The function is expected to */
4082 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4083 /* Return: <0:error, =0:eof, >0:not eof */
4084 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4088 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4090 PERL_ARGS_ASSERT_FILTER_GETS;
4092 #ifdef PERL_CR_FILTER
4093 if (!PL_rsfp_filters) {
4094 filter_add(S_cr_textfilter,NULL);
4097 if (PL_rsfp_filters) {
4099 SvCUR_set(sv, 0); /* start with empty line */
4100 if (FILTER_READ(0, sv, 0) > 0)
4101 return ( SvPVX(sv) ) ;
4106 return (sv_gets(sv, PL_rsfp, append));
4110 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4114 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4116 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4120 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4121 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4123 return GvHV(gv); /* Foo:: */
4126 /* use constant CLASS => 'MyClass' */
4127 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4128 if (gv && GvCV(gv)) {
4129 SV * const sv = cv_const_sv(GvCV(gv));
4131 return gv_stashsv(sv, 0);
4134 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4139 S_tokenize_use(pTHX_ int is_use, char *s) {
4140 PERL_ARGS_ASSERT_TOKENIZE_USE;
4142 if (PL_expect != XSTATE)
4143 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4144 is_use ? "use" : "no"));
4147 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4148 s = force_version(s, TRUE);
4149 if (*s == ';' || *s == '}'
4150 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4151 NEXTVAL_NEXTTOKE.opval = NULL;
4154 else if (*s == 'v') {
4155 s = force_word(s,WORD,FALSE,TRUE);
4156 s = force_version(s, FALSE);
4160 s = force_word(s,WORD,FALSE,TRUE);
4161 s = force_version(s, FALSE);
4163 pl_yylval.ival = is_use;
4167 static const char* const exp_name[] =
4168 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4169 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4174 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4176 S_word_takes_any_delimeter(char *p, STRLEN len)
4178 return (len == 1 && strchr("msyq", p[0])) ||
4180 (p[0] == 't' && p[1] == 'r') ||
4181 (p[0] == 'q' && strchr("qwxr", p[1]))));
4185 S_check_scalar_slice(pTHX_ char *s)
4188 while (*s == ' ' || *s == '\t') s++;
4189 if (*s == 'q' && s[1] == 'w'
4190 && !isWORDCHAR_lazy_if(s+2,UTF))
4192 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4193 s += UTF ? UTF8SKIP(s) : 1;
4194 if (*s == '}' || *s == ']')
4195 pl_yylval.ival = OPpSLICEWARNING;
4201 Works out what to call the token just pulled out of the input
4202 stream. The yacc parser takes care of taking the ops we return and
4203 stitching them into a tree.
4206 The type of the next token
4209 Switch based on the current state:
4210 - if we already built the token before, use it
4211 - if we have a case modifier in a string, deal with that
4212 - handle other cases of interpolation inside a string
4213 - scan the next line if we are inside a format
4214 In the normal state switch on the next character:
4216 if alphabetic, go to key lookup
4217 unrecoginized character - croak
4218 - 0/4/26: handle end-of-line or EOF
4219 - cases for whitespace
4220 - \n and #: handle comments and line numbers
4221 - various operators, brackets and sigils
4224 - 'v': vstrings (or go to key lookup)
4225 - 'x' repetition operator (or go to key lookup)
4226 - other ASCII alphanumerics (key lookup begins here):
4229 scan built-in keyword (but do nothing with it yet)
4230 check for statement label
4231 check for lexical subs
4232 goto just_a_word if there is one
4233 see whether built-in keyword is overridden
4234 switch on keyword number:
4235 - default: just_a_word:
4236 not a built-in keyword; handle bareword lookup
4237 disambiguate between method and sub call
4238 fall back to bareword
4239 - cases for built-in keywords
4247 char *s = PL_bufptr;
4251 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4255 /* orig_keyword, gvp, and gv are initialized here because
4256 * jump to the label just_a_word_zero can bypass their
4257 * initialization later. */
4258 I32 orig_keyword = 0;
4263 SV* tmp = newSVpvs("");
4264 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4265 (IV)CopLINE(PL_curcop),
4266 lex_state_names[PL_lex_state],
4267 exp_name[PL_expect],
4268 pv_display(tmp, s, strlen(s), 0, 60));
4272 switch (PL_lex_state) {
4274 case LEX_INTERPNORMAL:
4277 /* when we've already built the next token, just pull it out of the queue */
4280 pl_yylval = PL_nextval[PL_nexttoke];
4282 PL_lex_state = PL_lex_defer;
4283 PL_lex_defer = LEX_NORMAL;
4287 next_type = PL_nexttype[PL_nexttoke];
4288 if (next_type & (7<<24)) {
4289 if (next_type & (1<<24)) {
4290 if (PL_lex_brackets > 100)
4291 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4292 PL_lex_brackstack[PL_lex_brackets++] =
4293 (char) ((next_type >> 16) & 0xff);
4295 if (next_type & (2<<24))
4296 PL_lex_allbrackets++;
4297 if (next_type & (4<<24))
4298 PL_lex_allbrackets--;
4299 next_type &= 0xffff;
4301 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4304 /* interpolated case modifiers like \L \U, including \Q and \E.
4305 when we get here, PL_bufptr is at the \
4307 case LEX_INTERPCASEMOD:
4309 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4311 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4312 PL_bufptr, PL_bufend, *PL_bufptr);
4314 /* handle \E or end of string */
4315 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4317 if (PL_lex_casemods) {
4318 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4319 PL_lex_casestack[PL_lex_casemods] = '\0';
4321 if (PL_bufptr != PL_bufend
4322 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4323 || oldmod == 'F')) {
4325 PL_lex_state = LEX_INTERPCONCAT;
4327 PL_lex_allbrackets--;
4330 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4331 /* Got an unpaired \E */
4332 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4333 "Useless use of \\E");
4335 if (PL_bufptr != PL_bufend)
4337 PL_lex_state = LEX_INTERPCONCAT;
4341 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4342 "### Saw case modifier\n"); });
4344 if (s[1] == '\\' && s[2] == 'E') {
4346 PL_lex_state = LEX_INTERPCONCAT;
4351 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4352 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4353 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4354 (strchr(PL_lex_casestack, 'L')
4355 || strchr(PL_lex_casestack, 'U')
4356 || strchr(PL_lex_casestack, 'F'))) {
4357 PL_lex_casestack[--PL_lex_casemods] = '\0';
4358 PL_lex_allbrackets--;
4361 if (PL_lex_casemods > 10)
4362 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4363 PL_lex_casestack[PL_lex_casemods++] = *s;
4364 PL_lex_casestack[PL_lex_casemods] = '\0';
4365 PL_lex_state = LEX_INTERPCONCAT;
4366 NEXTVAL_NEXTTOKE.ival = 0;
4367 force_next((2<<24)|'(');
4369 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4371 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4373 NEXTVAL_NEXTTOKE.ival = OP_LC;
4375 NEXTVAL_NEXTTOKE.ival = OP_UC;
4377 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4379 NEXTVAL_NEXTTOKE.ival = OP_FC;
4381 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4385 if (PL_lex_starts) {
4388 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4389 if (PL_lex_casemods == 1 && PL_lex_inpat)
4392 AopNOASSIGN(OP_CONCAT);
4398 case LEX_INTERPPUSH:
4399 return REPORT(sublex_push());
4401 case LEX_INTERPSTART:
4402 if (PL_bufptr == PL_bufend)
4403 return REPORT(sublex_done());
4404 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4405 "### Interpolated variable\n"); });
4407 /* for /@a/, we leave the joining for the regex engine to do
4408 * (unless we're within \Q etc) */
4409 PL_lex_dojoin = (*PL_bufptr == '@'
4410 && (!PL_lex_inpat || PL_lex_casemods));
4411 PL_lex_state = LEX_INTERPNORMAL;
4412 if (PL_lex_dojoin) {
4413 NEXTVAL_NEXTTOKE.ival = 0;
4415 force_ident("\"", '$');
4416 NEXTVAL_NEXTTOKE.ival = 0;
4418 NEXTVAL_NEXTTOKE.ival = 0;
4419 force_next((2<<24)|'(');
4420 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4423 /* Convert (?{...}) and friends to 'do {...}' */
4424 if (PL_lex_inpat && *PL_bufptr == '(') {
4425 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4427 if (*PL_bufptr != '{')
4429 PL_expect = XTERMBLOCK;
4433 if (PL_lex_starts++) {
4435 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4436 if (!PL_lex_casemods && PL_lex_inpat)
4439 AopNOASSIGN(OP_CONCAT);
4443 case LEX_INTERPENDMAYBE:
4444 if (intuit_more(PL_bufptr)) {
4445 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4451 if (PL_lex_dojoin) {
4452 const U8 dojoin_was = PL_lex_dojoin;
4453 PL_lex_dojoin = FALSE;
4454 PL_lex_state = LEX_INTERPCONCAT;
4455 PL_lex_allbrackets--;
4456 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4458 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4459 && SvEVALED(PL_lex_repl))
4461 if (PL_bufptr != PL_bufend)
4462 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4465 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4466 re_eval_str. If the here-doc body’s length equals the previous
4467 value of re_eval_start, re_eval_start will now be null. So
4468 check re_eval_str as well. */
4469 if (PL_parser->lex_shared->re_eval_start
4470 || PL_parser->lex_shared->re_eval_str) {
4472 if (*PL_bufptr != ')')
4473 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4475 /* having compiled a (?{..}) expression, return the original
4476 * text too, as a const */
4477 if (PL_parser->lex_shared->re_eval_str) {
4478 sv = PL_parser->lex_shared->re_eval_str;
4479 PL_parser->lex_shared->re_eval_str = NULL;
4481 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4482 SvPV_shrink_to_cur(sv);
4484 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4485 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4486 NEXTVAL_NEXTTOKE.opval =
4487 (OP*)newSVOP(OP_CONST, 0,
4490 PL_parser->lex_shared->re_eval_start = NULL;
4496 case LEX_INTERPCONCAT:
4498 if (PL_lex_brackets)
4499 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4500 (long) PL_lex_brackets);
4502 if (PL_bufptr == PL_bufend)
4503 return REPORT(sublex_done());
4505 /* m'foo' still needs to be parsed for possible (?{...}) */
4506 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4507 SV *sv = newSVsv(PL_linestr);
4509 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4513 s = scan_const(PL_bufptr);
4515 PL_lex_state = LEX_INTERPCASEMOD;
4517 PL_lex_state = LEX_INTERPSTART;
4520 if (s != PL_bufptr) {
4521 NEXTVAL_NEXTTOKE = pl_yylval;
4524 if (PL_lex_starts++) {
4525 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4526 if (!PL_lex_casemods && PL_lex_inpat)
4529 AopNOASSIGN(OP_CONCAT);
4539 s = scan_formline(PL_bufptr);
4540 if (!PL_lex_formbrack)
4549 /* We really do *not* want PL_linestr ever becoming a COW. */
4550 assert (!SvIsCOW(PL_linestr));
4552 PL_oldoldbufptr = PL_oldbufptr;
4554 PL_parser->saw_infix_sigil = 0;
4559 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4562 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4563 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4565 SVs_TEMP | SVf_UTF8),
4566 10, UNI_DISPLAY_ISPRINT)
4567 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4568 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4569 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4570 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4574 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4575 UTF8fARG(UTF, (s - d), d),
4580 goto fake_eof; /* emulate EOF on ^D or ^Z */
4582 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4585 if (PL_lex_brackets &&
4586 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4587 yyerror((const char *)
4589 ? "Format not terminated"
4590 : "Missing right curly or square bracket"));
4592 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4593 "### Tokener got EOF\n");
4597 if (s++ < PL_bufend)
4598 goto retry; /* ignore stray nulls */
4601 if (!PL_in_eval && !PL_preambled) {
4602 PL_preambled = TRUE;
4604 /* Generate a string of Perl code to load the debugger.
4605 * If PERL5DB is set, it will return the contents of that,
4606 * otherwise a compile-time require of perl5db.pl. */
4608 const char * const pdb = PerlEnv_getenv("PERL5DB");
4611 sv_setpv(PL_linestr, pdb);
4612 sv_catpvs(PL_linestr,";");
4614 SETERRNO(0,SS_NORMAL);
4615 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4617 PL_parser->preambling = CopLINE(PL_curcop);
4619 sv_setpvs(PL_linestr,"");
4620 if (PL_preambleav) {
4621 SV **svp = AvARRAY(PL_preambleav);
4622 SV **const end = svp + AvFILLp(PL_preambleav);
4624 sv_catsv(PL_linestr, *svp);
4626 sv_catpvs(PL_linestr, ";");
4628 sv_free(MUTABLE_SV(PL_preambleav));
4629 PL_preambleav = NULL;
4632 sv_catpvs(PL_linestr,
4633 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4634 if (PL_minus_n || PL_minus_p) {
4635 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4637 sv_catpvs(PL_linestr,"chomp;");
4640 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4641 || *PL_splitstr == '"')
4642 && strchr(PL_splitstr + 1, *PL_splitstr))
4643 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4645 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4646 bytes can be used as quoting characters. :-) */
4647 const char *splits = PL_splitstr;
4648 sv_catpvs(PL_linestr, "our @F=split(q\0");
4651 if (*splits == '\\')
4652 sv_catpvn(PL_linestr, splits, 1);
4653 sv_catpvn(PL_linestr, splits, 1);
4654 } while (*splits++);
4655 /* This loop will embed the trailing NUL of
4656 PL_linestr as the last thing it does before
4658 sv_catpvs(PL_linestr, ");");
4662 sv_catpvs(PL_linestr,"our @F=split(' ');");
4665 sv_catpvs(PL_linestr, "\n");
4666 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4667 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4668 PL_last_lop = PL_last_uni = NULL;
4669 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4670 update_debugger_info(PL_linestr, NULL, 0);
4675 bof = PL_rsfp ? TRUE : FALSE;
4678 fake_eof = LEX_FAKE_EOF;
4680 PL_bufptr = PL_bufend;
4681 COPLINE_INC_WITH_HERELINES;
4682 if (!lex_next_chunk(fake_eof)) {
4683 CopLINE_dec(PL_curcop);
4685 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4687 CopLINE_dec(PL_curcop);
4689 /* If it looks like the start of a BOM or raw UTF-16,
4690 * check if it in fact is. */
4691 if (bof && PL_rsfp &&
4693 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4696 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4697 bof = (offset == (Off_t)SvCUR(PL_linestr));
4698 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4699 /* offset may include swallowed CR */
4701 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4704 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4705 s = swallow_bom((U8*)s);
4708 if (PL_parser->in_pod) {
4709 /* Incest with pod. */
4710 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4711 sv_setpvs(PL_linestr, "");
4712 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4713 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4714 PL_last_lop = PL_last_uni = NULL;
4715 PL_parser->in_pod = 0;
4718 if (PL_rsfp || PL_parser->filtered)
4720 } while (PL_parser->in_pod);
4721 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4722 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4723 PL_last_lop = PL_last_uni = NULL;
4724 if (CopLINE(PL_curcop) == 1) {
4725 while (s < PL_bufend && isSPACE(*s))
4727 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4731 if (*s == '#' && *(s+1) == '!')
4733 #ifdef ALTERNATE_SHEBANG
4735 static char const as[] = ALTERNATE_SHEBANG;
4736 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4737 d = s + (sizeof(as) - 1);
4739 #endif /* ALTERNATE_SHEBANG */
4748 while (*d && !isSPACE(*d))
4752 #ifdef ARG_ZERO_IS_SCRIPT
4753 if (ipathend > ipath) {
4755 * HP-UX (at least) sets argv[0] to the script name,
4756 * which makes $^X incorrect. And Digital UNIX and Linux,
4757 * at least, set argv[0] to the basename of the Perl
4758 * interpreter. So, having found "#!", we'll set it right.
4760 SV* copfilesv = CopFILESV(PL_curcop);
4763 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4765 assert(SvPOK(x) || SvGMAGICAL(x));
4766 if (sv_eq(x, copfilesv)) {
4767 sv_setpvn(x, ipath, ipathend - ipath);
4773 const char *bstart = SvPV_const(copfilesv, blen);
4774 const char * const lstart = SvPV_const(x, llen);
4776 bstart += blen - llen;
4777 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4778 sv_setpvn(x, ipath, ipathend - ipath);
4785 /* Anything to do if no copfilesv? */
4787 TAINT_NOT; /* $^X is always tainted, but that's OK */
4789 #endif /* ARG_ZERO_IS_SCRIPT */
4794 d = instr(s,"perl -");
4796 d = instr(s,"perl");
4798 /* avoid getting into infinite loops when shebang
4799 * line contains "Perl" rather than "perl" */
4801 for (d = ipathend-4; d >= ipath; --d) {
4802 if (isALPHA_FOLD_EQ(*d, 'p')
4803 && !ibcmp(d, "perl", 4))
4813 #ifdef ALTERNATE_SHEBANG
4815 * If the ALTERNATE_SHEBANG on this system starts with a
4816 * character that can be part of a Perl expression, then if
4817 * we see it but not "perl", we're probably looking at the
4818 * start of Perl code, not a request to hand off to some
4819 * other interpreter. Similarly, if "perl" is there, but
4820 * not in the first 'word' of the line, we assume the line
4821 * contains the start of the Perl program.
4823 if (d && *s != '#') {
4824 const char *c = ipath;
4825 while (*c && !strchr("; \t\r\n\f\v#", *c))
4828 d = NULL; /* "perl" not in first word; ignore */
4830 *s = '#'; /* Don't try to parse shebang line */
4832 #endif /* ALTERNATE_SHEBANG */
4837 !instr(s,"indir") &&
4838 instr(PL_origargv[0],"perl"))
4845 while (s < PL_bufend && isSPACE(*s))
4847 if (s < PL_bufend) {
4848 Newx(newargv,PL_origargc+3,char*);
4850 while (s < PL_bufend && !isSPACE(*s))
4853 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4856 newargv = PL_origargv;
4859 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4861 Perl_croak(aTHX_ "Can't exec %s", ipath);
4864 while (*d && !isSPACE(*d))
4866 while (SPACE_OR_TAB(*d))
4870 const bool switches_done = PL_doswitches;
4871 const U32 oldpdb = PL_perldb;
4872 const bool oldn = PL_minus_n;
4873 const bool oldp = PL_minus_p;
4877 bool baduni = FALSE;
4879 const char *d2 = d1 + 1;
4880 if (parse_unicode_opts((const char **)&d2)
4884 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4885 const char * const m = d1;
4886 while (*d1 && !isSPACE(*d1))
4888 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4891 d1 = moreswitches(d1);
4893 if (PL_doswitches && !switches_done) {
4894 int argc = PL_origargc;
4895 char **argv = PL_origargv;
4898 } while (argc && argv[0][0] == '-' && argv[0][1]);
4899 init_argv_symbols(argc,argv);
4901 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4902 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4903 /* if we have already added "LINE: while (<>) {",
4904 we must not do it again */
4906 sv_setpvs(PL_linestr, "");
4907 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4908 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4909 PL_last_lop = PL_last_uni = NULL;
4910 PL_preambled = FALSE;
4911 if (PERLDB_LINE || PERLDB_SAVESRC)
4912 (void)gv_fetchfile(PL_origfilename);
4919 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4920 PL_lex_state = LEX_FORMLINE;
4921 NEXTVAL_NEXTTOKE.ival = 0;
4922 force_next(FORMRBRACK);
4927 #ifdef PERL_STRICT_CR
4928 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4930 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4932 case ' ': case '\t': case '\f': case 013:
4937 if (PL_lex_state != LEX_NORMAL ||
4938 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
4939 const bool in_comment = *s == '#';
4940 if (*s == '#' && s == PL_linestart && PL_in_eval
4941 && !PL_rsfp && !PL_parser->filtered) {
4942 /* handle eval qq[#line 1 "foo"\n ...] */
4943 CopLINE_dec(PL_curcop);
4947 while (d < PL_bufend && *d != '\n')
4951 else if (d > PL_bufend)
4952 /* Found by Ilya: feed random input to Perl. */
4953 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
4956 if (in_comment && d == PL_bufend
4957 && PL_lex_state == LEX_INTERPNORMAL
4958 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
4959 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
4962 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4963 PL_lex_state = LEX_FORMLINE;
4964 NEXTVAL_NEXTTOKE.ival = 0;
4965 force_next(FORMRBRACK);
4970 while (s < PL_bufend && *s != '\n')
4978 else if (s > PL_bufend)
4979 /* Found by Ilya: feed random input to Perl. */
4980 Perl_croak(aTHX_ "panic: input overflow");
4984 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
4992 while (s < PL_bufend && SPACE_OR_TAB(*s))
4995 if (strnEQ(s,"=>",2)) {
4996 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
4997 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4998 OPERATOR('-'); /* unary minus */
5001 case 'r': ftst = OP_FTEREAD; break;
5002 case 'w': ftst = OP_FTEWRITE; break;
5003 case 'x': ftst = OP_FTEEXEC; break;
5004 case 'o': ftst = OP_FTEOWNED; break;
5005 case 'R': ftst = OP_FTRREAD; break;
5006 case 'W': ftst = OP_FTRWRITE; break;
5007 case 'X': ftst = OP_FTREXEC; break;
5008 case 'O': ftst = OP_FTROWNED; break;
5009 case 'e': ftst = OP_FTIS; break;
5010 case 'z': ftst = OP_FTZERO; break;
5011 case 's': ftst = OP_FTSIZE; break;
5012 case 'f': ftst = OP_FTFILE; break;
5013 case 'd': ftst = OP_FTDIR; break;
5014 case 'l': ftst = OP_FTLINK; break;
5015 case 'p': ftst = OP_FTPIPE; break;
5016 case 'S': ftst = OP_FTSOCK; break;
5017 case 'u': ftst = OP_FTSUID; break;
5018 case 'g': ftst = OP_FTSGID; break;
5019 case 'k': ftst = OP_FTSVTX; break;
5020 case 'b': ftst = OP_FTBLK; break;
5021 case 'c': ftst = OP_FTCHR; break;
5022 case 't': ftst = OP_FTTTY; break;
5023 case 'T': ftst = OP_FTTEXT; break;
5024 case 'B': ftst = OP_FTBINARY; break;
5025 case 'M': case 'A': case 'C':
5026 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5028 case 'M': ftst = OP_FTMTIME; break;
5029 case 'A': ftst = OP_FTATIME; break;
5030 case 'C': ftst = OP_FTCTIME; break;
5038 PL_last_uni = PL_oldbufptr;
5039 PL_last_lop_op = (OPCODE)ftst;
5040 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5041 "### Saw file test %c\n", (int)tmp);
5046 /* Assume it was a minus followed by a one-letter named
5047 * subroutine call (or a -bareword), then. */
5048 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5049 "### '-%c' looked like a file test but was not\n",
5056 const char tmp = *s++;
5059 if (PL_expect == XOPERATOR)
5064 else if (*s == '>') {
5067 if (FEATURE_POSTDEREF_IS_ENABLED && (
5068 ((*s == '$' || *s == '&') && s[1] == '*')
5069 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5070 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5071 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5074 Perl_ck_warner_d(aTHX_
5075 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5076 "Postfix dereference is experimental"
5078 PL_expect = XPOSTDEREF;
5081 if (isIDFIRST_lazy_if(s,UTF)) {
5082 s = force_word(s,METHOD,FALSE,TRUE);
5090 if (PL_expect == XOPERATOR) {
5091 if (*s == '=' && !PL_lex_allbrackets &&
5092 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5099 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5101 OPERATOR('-'); /* unary minus */
5107 const char tmp = *s++;
5110 if (PL_expect == XOPERATOR)
5115 if (PL_expect == XOPERATOR) {
5116 if (*s == '=' && !PL_lex_allbrackets &&
5117 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5124 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5131 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5132 if (PL_expect != XOPERATOR) {
5133 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5134 PL_expect = XOPERATOR;
5135 force_ident(PL_tokenbuf, '*');
5143 if (*s == '=' && !PL_lex_allbrackets &&
5144 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5150 if (*s == '=' && !PL_lex_allbrackets &&
5151 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5155 PL_parser->saw_infix_sigil = 1;
5160 if (PL_expect == XOPERATOR) {
5161 if (s[1] == '=' && !PL_lex_allbrackets &&
5162 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5165 PL_parser->saw_infix_sigil = 1;
5168 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5169 PL_tokenbuf[0] = '%';
5170 s = scan_ident(s, PL_tokenbuf + 1,
5171 sizeof PL_tokenbuf - 1, FALSE);
5173 if (!PL_tokenbuf[1]) {
5176 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5178 PL_tokenbuf[0] = '@';
5180 PL_expect = XOPERATOR;
5181 force_ident_maybe_lex('%');
5185 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5186 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5191 if (PL_lex_brackets > 100)
5192 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5193 PL_lex_brackstack[PL_lex_brackets++] = 0;
5194 PL_lex_allbrackets++;
5196 const char tmp = *s++;
5201 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5203 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5206 Perl_ck_warner_d(aTHX_
5207 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5208 "Smartmatch is experimental");
5214 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5221 goto just_a_word_zero_gv;
5227 switch (PL_expect) {
5229 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5231 PL_bufptr = s; /* update in case we back off */
5234 "Use of := for an empty attribute list is not allowed");
5241 PL_expect = XTERMBLOCK;
5245 while (isIDFIRST_lazy_if(s,UTF)) {
5248 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5249 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5250 if (tmp < 0) tmp = -tmp;
5265 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5267 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5268 COPLINE_SET_FROM_MULTI_END;
5270 /* MUST advance bufptr here to avoid bogus
5271 "at end of line" context messages from yyerror().
5273 PL_bufptr = s + len;
5274 yyerror("Unterminated attribute parameter in attribute list");
5278 return REPORT(0); /* EOF indicator */
5282 sv_catsv(sv, PL_lex_stuff);
5283 attrs = op_append_elem(OP_LIST, attrs,
5284 newSVOP(OP_CONST, 0, sv));
5285 SvREFCNT_dec(PL_lex_stuff);
5286 PL_lex_stuff = NULL;
5289 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5291 if (PL_in_my == KEY_our) {
5292 deprecate(":unique");
5295 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5298 /* NOTE: any CV attrs applied here need to be part of
5299 the CVf_BUILTIN_ATTRS define in cv.h! */
5300 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5302 CvLVALUE_on(PL_compcv);
5304 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5306 deprecate(":locked");
5308 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5310 CvMETHOD_on(PL_compcv);
5312 /* After we've set the flags, it could be argued that
5313 we don't need to do the attributes.pm-based setting
5314 process, and shouldn't bother appending recognized
5315 flags. To experiment with that, uncomment the
5316 following "else". (Note that's already been
5317 uncommented. That keeps the above-applied built-in
5318 attributes from being intercepted (and possibly
5319 rejected) by a package's attribute routines, but is
5320 justified by the performance win for the common case
5321 of applying only built-in attributes.) */
5323 attrs = op_append_elem(OP_LIST, attrs,
5324 newSVOP(OP_CONST, 0,
5328 if (*s == ':' && s[1] != ':')
5331 break; /* require real whitespace or :'s */
5332 /* XXX losing whitespace on sequential attributes here */
5335 if (*s != ';' && *s != '}' &&
5336 !(PL_expect == XOPERATOR
5337 ? (*s == '=' || *s == ')')
5338 : (*s == '{' || *s == '('))) {
5339 const char q = ((*s == '\'') ? '"' : '\'');
5340 /* If here for an expression, and parsed no attrs, back
5342 if (PL_expect == XOPERATOR && !attrs) {
5346 /* MUST advance bufptr here to avoid bogus "at end of line"
5347 context messages from yyerror().
5350 yyerror( (const char *)
5352 ? Perl_form(aTHX_ "Invalid separator character "
5353 "%c%c%c in attribute list", q, *s, q)
5354 : "Unterminated attribute list" ) );
5362 NEXTVAL_NEXTTOKE.opval = attrs;
5368 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5372 PL_lex_allbrackets--;
5376 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5377 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5381 PL_lex_allbrackets++;
5384 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5391 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5394 PL_lex_allbrackets--;
5400 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5403 if (PL_lex_brackets <= 0)
5404 /* diag_listed_as: Unmatched right %s bracket */
5405 yyerror("Unmatched right square bracket");
5408 PL_lex_allbrackets--;
5409 if (PL_lex_state == LEX_INTERPNORMAL) {
5410 if (PL_lex_brackets == 0) {
5411 if (*s == '-' && s[1] == '>')
5412 PL_lex_state = LEX_INTERPENDMAYBE;
5413 else if (*s != '[' && *s != '{')
5414 PL_lex_state = LEX_INTERPEND;
5421 if (PL_lex_brackets > 100) {
5422 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5424 switch (PL_expect) {
5426 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5427 PL_lex_allbrackets++;
5428 OPERATOR(HASHBRACK);
5430 while (s < PL_bufend && SPACE_OR_TAB(*s))
5433 PL_tokenbuf[0] = '\0';
5434 if (d < PL_bufend && *d == '-') {
5435 PL_tokenbuf[0] = '-';
5437 while (d < PL_bufend && SPACE_OR_TAB(*d))
5440 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5441 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5443 while (d < PL_bufend && SPACE_OR_TAB(*d))
5446 const char minus = (PL_tokenbuf[0] == '-');
5447 s = force_word(s + minus, WORD, FALSE, TRUE);
5455 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5456 PL_lex_allbrackets++;
5461 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5462 PL_lex_allbrackets++;
5466 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5467 PL_lex_allbrackets++;
5472 if (PL_oldoldbufptr == PL_last_lop)
5473 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5475 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5476 PL_lex_allbrackets++;
5479 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5481 /* This hack is to get the ${} in the message. */
5483 yyerror("syntax error");
5486 OPERATOR(HASHBRACK);
5488 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5489 /* ${...} or @{...} etc., but not print {...} */
5493 /* This hack serves to disambiguate a pair of curlies
5494 * as being a block or an anon hash. Normally, expectation
5495 * determines that, but in cases where we're not in a
5496 * position to expect anything in particular (like inside
5497 * eval"") we have to resolve the ambiguity. This code
5498 * covers the case where the first term in the curlies is a
5499 * quoted string. Most other cases need to be explicitly
5500 * disambiguated by prepending a "+" before the opening
5501 * curly in order to force resolution as an anon hash.
5503 * XXX should probably propagate the outer expectation
5504 * into eval"" to rely less on this hack, but that could
5505 * potentially break current behavior of eval"".
5509 if (*s == '\'' || *s == '"' || *s == '`') {
5510 /* common case: get past first string, handling escapes */
5511 for (t++; t < PL_bufend && *t != *s;)
5516 else if (*s == 'q') {
5519 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5520 && !isWORDCHAR(*t))))
5522 /* skip q//-like construct */
5524 char open, close, term;
5527 while (t < PL_bufend && isSPACE(*t))
5529 /* check for q => */
5530 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5531 OPERATOR(HASHBRACK);
5535 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5539 for (t++; t < PL_bufend; t++) {
5540 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5542 else if (*t == open)
5546 for (t++; t < PL_bufend; t++) {
5547 if (*t == '\\' && t+1 < PL_bufend)
5549 else if (*t == close && --brackets <= 0)
5551 else if (*t == open)
5558 /* skip plain q word */
5559 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5562 else if (isWORDCHAR_lazy_if(t,UTF)) {
5564 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5567 while (t < PL_bufend && isSPACE(*t))
5569 /* if comma follows first term, call it an anon hash */
5570 /* XXX it could be a comma expression with loop modifiers */
5571 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5572 || (*t == '=' && t[1] == '>')))
5573 OPERATOR(HASHBRACK);
5574 if (PL_expect == XREF)
5577 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5583 pl_yylval.ival = CopLINE(PL_curcop);
5584 if (isSPACE(*s) || *s == '#')
5585 PL_copline = NOLINE; /* invalidate current command line number */
5586 TOKEN(formbrack ? '=' : '{');
5588 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5592 if (PL_lex_brackets <= 0)
5593 /* diag_listed_as: Unmatched right %s bracket */
5594 yyerror("Unmatched right curly bracket");
5596 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5597 PL_lex_allbrackets--;
5598 if (PL_lex_state == LEX_INTERPNORMAL) {
5599 if (PL_lex_brackets == 0) {
5600 if (PL_expect & XFAKEBRACK) {
5601 PL_expect &= XENUMMASK;
5602 PL_lex_state = LEX_INTERPEND;
5604 return yylex(); /* ignore fake brackets */
5606 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5607 && SvEVALED(PL_lex_repl))
5608 PL_lex_state = LEX_INTERPEND;
5609 else if (*s == '-' && s[1] == '>')
5610 PL_lex_state = LEX_INTERPENDMAYBE;
5611 else if (*s != '[' && *s != '{')
5612 PL_lex_state = LEX_INTERPEND;
5615 if (PL_expect & XFAKEBRACK) {
5616 PL_expect &= XENUMMASK;
5618 return yylex(); /* ignore fake brackets */
5620 force_next(formbrack ? '.' : '}');
5621 if (formbrack) LEAVE;
5622 if (formbrack == 2) { /* means . where arguments were expected */
5628 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5631 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5632 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5639 if (PL_expect == XOPERATOR) {
5640 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5641 && isIDFIRST_lazy_if(s,UTF))
5643 CopLINE_dec(PL_curcop);
5644 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5645 CopLINE_inc(PL_curcop);
5647 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5648 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5652 PL_parser->saw_infix_sigil = 1;
5656 PL_tokenbuf[0] = '&';
5657 s = scan_ident(s - 1, PL_tokenbuf + 1,
5658 sizeof PL_tokenbuf - 1, TRUE);
5659 if (PL_tokenbuf[1]) {
5660 PL_expect = XOPERATOR;
5661 force_ident_maybe_lex('&');
5665 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5671 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5672 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5679 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5680 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5688 const char tmp = *s++;
5690 if (!PL_lex_allbrackets &&
5691 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5698 if (!PL_lex_allbrackets &&
5699 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5707 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5708 && strchr("+-*/%.^&|<",tmp))
5709 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5710 "Reversed %c= operator",(int)tmp);
5712 if (PL_expect == XSTATE && isALPHA(tmp) &&
5713 (s == PL_linestart+1 || s[-2] == '\n') )
5715 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5716 || PL_lex_state != LEX_NORMAL) {
5721 if (strnEQ(s,"=cut",4)) {
5735 PL_parser->in_pod = 1;
5739 if (PL_expect == XBLOCK) {
5741 #ifdef PERL_STRICT_CR
5742 while (SPACE_OR_TAB(*t))
5744 while (SPACE_OR_TAB(*t) || *t == '\r')
5747 if (*t == '\n' || *t == '#') {
5750 SAVEI8(PL_parser->form_lex_state);
5751 SAVEI32(PL_lex_formbrack);
5752 PL_parser->form_lex_state = PL_lex_state;
5753 PL_lex_formbrack = PL_lex_brackets + 1;
5757 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5766 const char tmp = *s++;
5768 /* was this !=~ where !~ was meant?
5769 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5771 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5772 const char *t = s+1;
5774 while (t < PL_bufend && isSPACE(*t))
5777 if (*t == '/' || *t == '?' ||
5778 ((*t == 'm' || *t == 's' || *t == 'y')
5779 && !isWORDCHAR(t[1])) ||
5780 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5781 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5782 "!=~ should be !~");
5784 if (!PL_lex_allbrackets &&
5785 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5797 if (PL_expect != XOPERATOR) {
5798 if (s[1] != '<' && !strchr(s,'>'))
5801 s = scan_heredoc(s);
5803 s = scan_inputsymbol(s);
5804 PL_expect = XOPERATOR;
5805 TOKEN(sublex_start());
5811 if (*s == '=' && !PL_lex_allbrackets &&
5812 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5816 SHop(OP_LEFT_SHIFT);
5821 if (!PL_lex_allbrackets &&
5822 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5829 if (!PL_lex_allbrackets &&
5830 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5838 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5846 const char tmp = *s++;
5848 if (*s == '=' && !PL_lex_allbrackets &&
5849 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5853 SHop(OP_RIGHT_SHIFT);
5855 else if (tmp == '=') {
5856 if (!PL_lex_allbrackets &&
5857 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5865 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5874 if (PL_expect == XOPERATOR) {
5875 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5876 return deprecate_commaless_var_list();
5879 else if (PL_expect == XPOSTDEREF) {
5882 POSTDEREF(DOLSHARP);
5887 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
5888 PL_tokenbuf[0] = '@';
5889 s = scan_ident(s + 1, PL_tokenbuf + 1,
5890 sizeof PL_tokenbuf - 1, FALSE);
5891 if (PL_expect == XOPERATOR)
5892 no_op("Array length", s);
5893 if (!PL_tokenbuf[1])
5895 PL_expect = XOPERATOR;
5896 force_ident_maybe_lex('#');
5900 PL_tokenbuf[0] = '$';
5901 s = scan_ident(s, PL_tokenbuf + 1,
5902 sizeof PL_tokenbuf - 1, FALSE);
5903 if (PL_expect == XOPERATOR)
5905 if (!PL_tokenbuf[1]) {
5907 yyerror("Final $ should be \\$ or $name");
5913 const char tmp = *s;
5914 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5917 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5918 && intuit_more(s)) {
5920 PL_tokenbuf[0] = '@';
5921 if (ckWARN(WARN_SYNTAX)) {
5924 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
5927 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
5928 while (t < PL_bufend && *t != ']')
5930 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5931 "Multidimensional syntax %.*s not supported",
5932 (int)((t - PL_bufptr) + 1), PL_bufptr);
5936 else if (*s == '{') {
5938 PL_tokenbuf[0] = '%';
5939 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
5940 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
5942 char tmpbuf[sizeof PL_tokenbuf];
5945 } while (isSPACE(*t));
5946 if (isIDFIRST_lazy_if(t,UTF)) {
5948 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5953 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
5954 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5955 "You need to quote \"%"UTF8f"\"",
5956 UTF8fARG(UTF, len, tmpbuf));
5962 PL_expect = XOPERATOR;
5963 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
5964 const bool islop = (PL_last_lop == PL_oldoldbufptr);
5965 if (!islop || PL_last_lop_op == OP_GREPSTART)
5966 PL_expect = XOPERATOR;
5967 else if (strchr("$@\"'`q", *s))
5968 PL_expect = XTERM; /* e.g. print $fh "foo" */
5969 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
5970 PL_expect = XTERM; /* e.g. print $fh &sub */
5971 else if (isIDFIRST_lazy_if(s,UTF)) {
5972 char tmpbuf[sizeof PL_tokenbuf];
5974 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5975 if ((t2 = keyword(tmpbuf, len, 0))) {
5976 /* binary operators exclude handle interpretations */
5988 PL_expect = XTERM; /* e.g. print $fh length() */
5993 PL_expect = XTERM; /* e.g. print $fh subr() */
5996 else if (isDIGIT(*s))
5997 PL_expect = XTERM; /* e.g. print $fh 3 */
5998 else if (*s == '.' && isDIGIT(s[1]))
5999 PL_expect = XTERM; /* e.g. print $fh .3 */
6000 else if ((*s == '?' || *s == '-' || *s == '+')
6001 && !isSPACE(s[1]) && s[1] != '=')
6002 PL_expect = XTERM; /* e.g. print $fh -1 */
6003 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6005 PL_expect = XTERM; /* e.g. print $fh /.../
6006 XXX except DORDOR operator
6008 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6010 PL_expect = XTERM; /* print $fh <<"EOF" */
6013 force_ident_maybe_lex('$');
6017 if (PL_expect == XOPERATOR)
6019 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6020 PL_tokenbuf[0] = '@';
6021 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6023 if (!PL_tokenbuf[1]) {
6026 if (PL_lex_state == LEX_NORMAL)
6028 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6030 PL_tokenbuf[0] = '%';
6032 /* Warn about @ where they meant $. */
6033 if (*s == '[' || *s == '{') {
6034 if (ckWARN(WARN_SYNTAX)) {
6035 S_check_scalar_slice(aTHX_ s);
6039 PL_expect = XOPERATOR;
6040 force_ident_maybe_lex('@');
6043 case '/': /* may be division, defined-or, or pattern */
6044 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6045 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6046 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6051 else if (PL_expect == XOPERATOR) {
6053 if (*s == '=' && !PL_lex_allbrackets &&
6054 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6061 /* Disable warning on "study /blah/" */
6062 if (PL_oldoldbufptr == PL_last_uni
6063 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6064 || memNE(PL_last_uni, "study", 5)
6065 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6068 s = scan_pat(s,OP_MATCH);
6069 TERM(sublex_start());
6072 case '?': /* conditional */
6074 if (!PL_lex_allbrackets &&
6075 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6079 PL_lex_allbrackets++;
6083 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6084 #ifdef PERL_STRICT_CR
6087 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6089 && (s == PL_linestart || s[-1] == '\n') )
6092 formbrack = 2; /* dot seen where arguments expected */
6095 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6099 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6102 if (!PL_lex_allbrackets &&
6103 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6110 pl_yylval.ival = OPf_SPECIAL;
6116 if (*s == '=' && !PL_lex_allbrackets &&
6117 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6124 case '0': case '1': case '2': case '3': case '4':
6125 case '5': case '6': case '7': case '8': case '9':
6126 s = scan_num(s, &pl_yylval);
6127 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6128 if (PL_expect == XOPERATOR)
6133 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6136 COPLINE_SET_FROM_MULTI_END;
6137 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6138 if (PL_expect == XOPERATOR) {
6139 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6140 return deprecate_commaless_var_list();
6145 pl_yylval.ival = OP_CONST;
6146 TERM(sublex_start());
6149 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6152 printbuf("### Saw string before %s\n", s);
6154 PerlIO_printf(Perl_debug_log,
6155 "### Saw unterminated string\n");
6157 if (PL_expect == XOPERATOR) {
6158 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6159 return deprecate_commaless_var_list();
6166 pl_yylval.ival = OP_CONST;
6167 /* FIXME. I think that this can be const if char *d is replaced by
6168 more localised variables. */
6169 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6170 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6171 pl_yylval.ival = OP_STRINGIFY;
6175 if (pl_yylval.ival == OP_CONST)
6176 COPLINE_SET_FROM_MULTI_END;
6177 TERM(sublex_start());
6180 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6181 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6182 if (PL_expect == XOPERATOR)
6183 no_op("Backticks",s);
6186 pl_yylval.ival = OP_BACKTICK;
6187 TERM(sublex_start());
6191 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6193 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6195 if (PL_expect == XOPERATOR)
6196 no_op("Backslash",s);
6200 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6201 char *start = s + 2;
6202 while (isDIGIT(*start) || *start == '_')
6204 if (*start == '.' && isDIGIT(start[1])) {
6205 s = scan_num(s, &pl_yylval);
6208 else if ((*start == ':' && start[1] == ':')
6209 || (PL_expect == XSTATE && *start == ':'))
6211 else if (PL_expect == XSTATE) {
6213 while (d < PL_bufend && isSPACE(*d)) d++;
6214 if (*d == ':') goto keylookup;
6216 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6217 if (!isALPHA(*start) && (PL_expect == XTERM
6218 || PL_expect == XREF || PL_expect == XSTATE
6219 || PL_expect == XTERMORDORDOR)) {
6220 GV *const gv = gv_fetchpvn_flags(s, start - s,
6221 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6223 s = scan_num(s, &pl_yylval);
6230 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6283 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6285 /* Some keywords can be followed by any delimiter, including ':' */
6286 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6288 /* x::* is just a word, unless x is "CORE" */
6289 if (!anydelim && *s == ':' && s[1] == ':') {
6290 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6295 while (d < PL_bufend && isSPACE(*d))
6296 d++; /* no comments skipped here, or s### is misparsed */
6298 /* Is this a word before a => operator? */
6299 if (*d == '=' && d[1] == '>') {
6303 = (OP*)newSVOP(OP_CONST, 0,
6304 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6305 pl_yylval.opval->op_private = OPpCONST_BARE;
6309 /* Check for plugged-in keyword */
6313 char *saved_bufptr = PL_bufptr;
6315 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6317 if (result == KEYWORD_PLUGIN_DECLINE) {
6318 /* not a plugged-in keyword */
6319 PL_bufptr = saved_bufptr;
6320 } else if (result == KEYWORD_PLUGIN_STMT) {
6321 pl_yylval.opval = o;
6323 if (!PL_nexttoke) PL_expect = XSTATE;
6324 return REPORT(PLUGSTMT);
6325 } else if (result == KEYWORD_PLUGIN_EXPR) {
6326 pl_yylval.opval = o;
6328 if (!PL_nexttoke) PL_expect = XOPERATOR;
6329 return REPORT(PLUGEXPR);
6331 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6336 /* Check for built-in keyword */
6337 tmp = keyword(PL_tokenbuf, len, 0);
6339 /* Is this a label? */
6340 if (!anydelim && PL_expect == XSTATE
6341 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6343 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6344 pl_yylval.pval[len] = '\0';
6345 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6350 /* Check for lexical sub */
6351 if (PL_expect != XOPERATOR) {
6352 char tmpbuf[sizeof PL_tokenbuf + 1];
6354 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6355 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
6356 if (off != NOT_IN_PAD) {
6357 assert(off); /* we assume this is boolean-true below */
6358 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6359 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6360 HEK * const stashname = HvNAME_HEK(stash);
6361 sv = newSVhek(stashname);
6362 sv_catpvs(sv, "::");
6363 sv_catpvn_flags(sv, PL_tokenbuf, len,
6364 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6365 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6375 rv2cv_op = newOP(OP_PADANY, 0);
6376 rv2cv_op->op_targ = off;
6377 cv = find_lexical_cv(off);
6385 if (tmp < 0) { /* second-class keyword? */
6386 GV *ogv = NULL; /* override (winner) */
6387 GV *hgv = NULL; /* hidden (loser) */
6388 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6390 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6391 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6395 if (GvIMPORTED_CV(gv))
6397 else if (! CvMETHOD(cv))
6401 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6405 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6406 : SvPCS_IMPORTED(gv)
6407 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6416 tmp = 0; /* overridden by import or by GLOBAL */
6419 && -tmp==KEY_lock /* XXX generalizable kludge */
6422 tmp = 0; /* any sub overrides "weak" keyword */
6424 else { /* no override */
6426 if (tmp == KEY_dump) {
6427 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6428 "dump() better written as CORE::dump()");
6432 if (hgv && tmp != KEY_x) /* never ambiguous */
6433 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6434 "Ambiguous call resolved as CORE::%s(), "
6435 "qualify as such or use &",
6440 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6441 && (!anydelim || *s != '#')) {
6442 /* no override, and not s### either; skipspace is safe here
6443 * check for => on following line */
6445 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6446 STRLEN soff = s - SvPVX(PL_linestr);
6447 s = skipspace_flags(s, LEX_NO_INCLINE);
6448 arrow = *s == '=' && s[1] == '>';
6449 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6450 s = SvPVX(PL_linestr) + soff;
6458 default: /* not a keyword */
6459 /* Trade off - by using this evil construction we can pull the
6460 variable gv into the block labelled keylookup. If not, then
6461 we have to give it function scope so that the goto from the
6462 earlier ':' case doesn't bypass the initialisation. */
6464 just_a_word_zero_gv:
6476 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6480 /* Get the rest if it looks like a package qualifier */
6482 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6484 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6487 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6488 UTF8fARG(UTF, len, PL_tokenbuf),
6489 *s == '\'' ? "'" : "::");
6494 if (PL_expect == XOPERATOR) {
6495 if (PL_bufptr == PL_linestart) {
6496 CopLINE_dec(PL_curcop);
6497 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6498 CopLINE_inc(PL_curcop);
6501 no_op("Bareword",s);
6504 /* See if the name is "Foo::",
6505 in which case Foo is a bareword
6506 (and a package name). */
6509 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6511 if (ckWARN(WARN_BAREWORD)
6512 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6513 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6514 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6515 UTF8fARG(UTF, len, PL_tokenbuf));
6517 PL_tokenbuf[len] = '\0';
6526 /* if we saw a global override before, get the right name */
6529 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6532 SV * const tmp_sv = sv;
6533 sv = newSVpvs("CORE::GLOBAL::");
6534 sv_catsv(sv, tmp_sv);
6535 SvREFCNT_dec(tmp_sv);
6539 /* Presume this is going to be a bareword of some sort. */
6541 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6542 pl_yylval.opval->op_private = OPpCONST_BARE;
6544 /* And if "Foo::", then that's what it certainly is. */
6550 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6551 const_op->op_private = OPpCONST_BARE;
6553 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6555 ? isGV(gv) ? GvCV(gv) : (CV *)gv
6556 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6559 /* Use this var to track whether intuit_method has been
6560 called. intuit_method returns 0 or > 255. */
6563 /* See if it's the indirect object for a list operator. */
6565 if (PL_oldoldbufptr &&
6566 PL_oldoldbufptr < PL_bufptr &&
6567 (PL_oldoldbufptr == PL_last_lop
6568 || PL_oldoldbufptr == PL_last_uni) &&
6569 /* NO SKIPSPACE BEFORE HERE! */
6570 (PL_expect == XREF ||
6571 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6573 bool immediate_paren = *s == '(';
6575 /* (Now we can afford to cross potential line boundary.) */
6578 /* Two barewords in a row may indicate method call. */
6580 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6581 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6585 /* If not a declared subroutine, it's an indirect object. */
6586 /* (But it's an indir obj regardless for sort.) */
6587 /* Also, if "_" follows a filetest operator, it's a bareword */
6590 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6592 (PL_last_lop_op != OP_MAPSTART &&
6593 PL_last_lop_op != OP_GREPSTART))))
6594 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6595 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6598 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6603 PL_expect = XOPERATOR;
6606 /* Is this a word before a => operator? */
6607 if (*s == '=' && s[1] == '>' && !pkgname) {
6610 if (gvp || (lex && !off)) {
6611 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6612 /* This is our own scalar, created a few lines
6613 above, so this is safe. */
6615 sv_setpv(sv, PL_tokenbuf);
6616 if (UTF && !IN_BYTES
6617 && is_utf8_string((U8*)PL_tokenbuf, len))
6624 /* If followed by a paren, it's certainly a subroutine. */
6629 while (SPACE_OR_TAB(*d))
6631 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6636 NEXTVAL_NEXTTOKE.opval =
6637 off ? rv2cv_op : pl_yylval.opval;
6639 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6640 else op_free(rv2cv_op), force_next(WORD);
6645 /* If followed by var or block, call it a method (unless sub) */
6647 if ((*s == '$' || *s == '{') && !cv) {
6649 PL_last_lop = PL_oldbufptr;
6650 PL_last_lop_op = OP_METHOD;
6651 if (!PL_lex_allbrackets &&
6652 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6653 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6654 PL_expect = XBLOCKTERM;
6656 return REPORT(METHOD);
6659 /* If followed by a bareword, see if it looks like indir obj. */
6661 if (tmp == 1 && !orig_keyword
6662 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6663 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6666 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6668 sv_setpvn(sv, PL_tokenbuf, len);
6669 if (UTF && !IN_BYTES
6670 && is_utf8_string((U8*)PL_tokenbuf, len))
6672 else SvUTF8_off(sv);
6675 if (tmp == METHOD && !PL_lex_allbrackets &&
6676 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6677 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6681 /* Not a method, so call it a subroutine (if defined) */
6685 /* Check for a constant sub */
6686 if ((sv = cv_const_sv_or_av(cv))) {
6689 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6690 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6691 if (SvTYPE(sv) == SVt_PVAV)
6692 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6695 pl_yylval.opval->op_private = 0;
6696 pl_yylval.opval->op_folded = 1;
6697 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6702 /* Resolve to GV now if this is a placeholder. */
6703 if (!off && (gvop = cUNOPx(rv2cv_op)->op_first)
6704 && gvop->op_type == OP_GV) {
6705 GV *gv2 = cGVOPx_gv(gvop);
6706 if (gv2 && !isGV(gv2)) {
6707 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
6708 assert (SvTYPE(gv) == SVt_PVGV);
6709 /* cv must have been some sort of placeholder,
6710 so now needs replacing with a real code
6716 op_free(pl_yylval.opval);
6718 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6719 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6720 PL_last_lop = PL_oldbufptr;
6721 PL_last_lop_op = OP_ENTERSUB;
6722 /* Is there a prototype? */
6726 STRLEN protolen = CvPROTOLEN(cv);
6727 const char *proto = CvPROTO(cv);
6729 proto = S_strip_spaces(aTHX_ proto, &protolen);
6732 if ((optional = *proto == ';'))
6735 while (*proto == ';');
6739 *proto == '$' || *proto == '_'
6740 || *proto == '*' || *proto == '+'
6745 *proto == '\\' && proto[1] && proto[2] == '\0'
6748 UNIPROTO(UNIOPSUB,optional);
6749 if (*proto == '\\' && proto[1] == '[') {
6750 const char *p = proto + 2;
6751 while(*p && *p != ']')
6753 if(*p == ']' && !p[1])
6754 UNIPROTO(UNIOPSUB,optional);
6756 if (*proto == '&' && *s == '{') {
6758 sv_setpvs(PL_subname, "__ANON__");
6760 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6761 if (!PL_lex_allbrackets &&
6762 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6763 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6767 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6769 force_next(off ? PRIVATEREF : WORD);
6770 if (!PL_lex_allbrackets &&
6771 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6772 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6776 /* Call it a bare word */
6778 if (PL_hints & HINT_STRICT_SUBS)
6779 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6782 /* after "print" and similar functions (corresponding to
6783 * "F? L" in opcode.pl), whatever wasn't already parsed as
6784 * a filehandle should be subject to "strict subs".
6785 * Likewise for the optional indirect-object argument to system
6786 * or exec, which can't be a bareword */
6787 if ((PL_last_lop_op == OP_PRINT
6788 || PL_last_lop_op == OP_PRTF
6789 || PL_last_lop_op == OP_SAY
6790 || PL_last_lop_op == OP_SYSTEM
6791 || PL_last_lop_op == OP_EXEC)
6792 && (PL_hints & HINT_STRICT_SUBS))
6793 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6794 if (lastchar != '-') {
6795 if (ckWARN(WARN_RESERVED)) {
6799 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6801 /* PL_warn_reserved is constant */
6802 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6803 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6813 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6814 && saw_infix_sigil) {
6815 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6816 "Operator or semicolon missing before %c%"UTF8f,
6818 UTF8fARG(UTF, strlen(PL_tokenbuf),
6820 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6821 "Ambiguous use of %c resolved as operator %c",
6822 lastchar, lastchar);
6829 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6834 (OP*)newSVOP(OP_CONST, 0,
6835 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6838 case KEY___PACKAGE__:
6840 (OP*)newSVOP(OP_CONST, 0,
6842 ? newSVhek(HvNAME_HEK(PL_curstash))
6849 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6850 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6853 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6855 gv_init(gv,stash,"DATA",4,0);
6858 GvIOp(gv) = newIO();
6859 IoIFP(GvIOp(gv)) = PL_rsfp;
6860 #if defined(HAS_FCNTL) && defined(F_SETFD)
6862 const int fd = PerlIO_fileno(PL_rsfp);
6863 fcntl(fd,F_SETFD,fd >= 3);
6866 /* Mark this internal pseudo-handle as clean */
6867 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6868 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6869 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6871 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6872 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6873 /* if the script was opened in binmode, we need to revert
6874 * it to text mode for compatibility; but only iff it has CRs
6875 * XXX this is a questionable hack at best. */
6876 if (PL_bufend-PL_bufptr > 2
6877 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6880 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6881 loc = PerlIO_tell(PL_rsfp);
6882 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6885 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6887 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6888 #endif /* NETWARE */
6890 PerlIO_seek(PL_rsfp, loc, 0);
6894 #ifdef PERLIO_LAYERS
6897 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6898 else if (PL_encoding) {
6904 XPUSHs(PL_encoding);
6906 call_method("name", G_SCALAR);
6910 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
6911 Perl_form(aTHX_ ":encoding(%"SVf")",
6924 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
6933 if (PL_expect == XSTATE) {
6944 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6945 if ((*s == ':' && s[1] == ':')
6946 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
6950 Copy(PL_bufptr, PL_tokenbuf, olen, char);
6954 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
6955 UTF8fARG(UTF, len, PL_tokenbuf));
6958 else if (tmp == KEY_require || tmp == KEY_do
6960 /* that's a way to remember we saw "CORE::" */
6972 LOP(OP_ACCEPT,XTERM);
6975 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
6980 LOP(OP_ATAN2,XTERM);
6986 LOP(OP_BINMODE,XTERM);
6989 LOP(OP_BLESS,XTERM);
6998 /* We have to disambiguate the two senses of
6999 "continue". If the next token is a '{' then
7000 treat it as the start of a continue block;
7001 otherwise treat it as a control operator.
7011 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7021 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7030 if (!PL_cryptseen) {
7031 PL_cryptseen = TRUE;
7035 LOP(OP_CRYPT,XTERM);
7038 LOP(OP_CHMOD,XTERM);
7041 LOP(OP_CHOWN,XTERM);
7044 LOP(OP_CONNECT,XTERM);
7064 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7066 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7067 && !keyword(PL_tokenbuf + 1, len, 0)) {
7070 force_ident_maybe_lex('&');
7075 if (orig_keyword == KEY_do) {
7084 PL_hints |= HINT_BLOCK_SCOPE;
7094 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7095 STR_WITH_LEN("NDBM_File::"),
7096 STR_WITH_LEN("DB_File::"),
7097 STR_WITH_LEN("GDBM_File::"),
7098 STR_WITH_LEN("SDBM_File::"),
7099 STR_WITH_LEN("ODBM_File::"),
7101 LOP(OP_DBMOPEN,XTERM);
7113 pl_yylval.ival = CopLINE(PL_curcop);
7117 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7129 if (*s == '{') { /* block eval */
7130 PL_expect = XTERMBLOCK;
7131 UNIBRACK(OP_ENTERTRY);
7133 else { /* string eval */
7135 UNIBRACK(OP_ENTEREVAL);
7140 UNIBRACK(-OP_ENTEREVAL);
7154 case KEY_endhostent:
7160 case KEY_endservent:
7163 case KEY_endprotoent:
7174 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7176 pl_yylval.ival = CopLINE(PL_curcop);
7178 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7181 if ((PL_bufend - p) >= 3 &&
7182 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7184 else if ((PL_bufend - p) >= 4 &&
7185 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7188 /* skip optional package name, as in "for my abc $x (..)" */
7189 if (isIDFIRST_lazy_if(p,UTF)) {
7190 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7194 Perl_croak(aTHX_ "Missing $ on loop variable");
7199 LOP(OP_FORMLINE,XTERM);
7208 LOP(OP_FCNTL,XTERM);
7214 LOP(OP_FLOCK,XTERM);
7217 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7222 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7227 LOP(OP_GREPSTART, XREF);
7244 case KEY_getpriority:
7245 LOP(OP_GETPRIORITY,XTERM);
7247 case KEY_getprotobyname:
7250 case KEY_getprotobynumber:
7251 LOP(OP_GPBYNUMBER,XTERM);
7253 case KEY_getprotoent:
7265 case KEY_getpeername:
7266 UNI(OP_GETPEERNAME);
7268 case KEY_gethostbyname:
7271 case KEY_gethostbyaddr:
7272 LOP(OP_GHBYADDR,XTERM);
7274 case KEY_gethostent:
7277 case KEY_getnetbyname:
7280 case KEY_getnetbyaddr:
7281 LOP(OP_GNBYADDR,XTERM);
7286 case KEY_getservbyname:
7287 LOP(OP_GSBYNAME,XTERM);
7289 case KEY_getservbyport:
7290 LOP(OP_GSBYPORT,XTERM);
7292 case KEY_getservent:
7295 case KEY_getsockname:
7296 UNI(OP_GETSOCKNAME);
7298 case KEY_getsockopt:
7299 LOP(OP_GSOCKOPT,XTERM);
7314 pl_yylval.ival = CopLINE(PL_curcop);
7315 Perl_ck_warner_d(aTHX_
7316 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7317 "given is experimental");
7322 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7330 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7332 pl_yylval.ival = CopLINE(PL_curcop);
7336 LOP(OP_INDEX,XTERM);
7342 LOP(OP_IOCTL,XTERM);
7370 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7375 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7389 LOP(OP_LISTEN,XTERM);
7398 s = scan_pat(s,OP_MATCH);
7399 TERM(sublex_start());
7402 LOP(OP_MAPSTART, XREF);
7405 LOP(OP_MKDIR,XTERM);
7408 LOP(OP_MSGCTL,XTERM);
7411 LOP(OP_MSGGET,XTERM);
7414 LOP(OP_MSGRCV,XTERM);
7417 LOP(OP_MSGSND,XTERM);
7422 PL_in_my = (U16)tmp;
7424 if (isIDFIRST_lazy_if(s,UTF)) {
7425 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7426 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7428 if (!FEATURE_LEXSUBS_IS_ENABLED)
7430 "Experimental \"%s\" subs not enabled",
7431 tmp == KEY_my ? "my" :
7432 tmp == KEY_state ? "state" : "our");
7433 Perl_ck_warner_d(aTHX_
7434 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7435 "The lexical_subs feature is experimental");
7438 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7439 if (!PL_in_my_stash) {
7443 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7444 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7445 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7455 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7460 s = tokenize_use(0, s);
7464 if (*s == '(' || (s = skipspace(s), *s == '('))
7467 if (!PL_lex_allbrackets &&
7468 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7469 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7475 if (isIDFIRST_lazy_if(s,UTF)) {
7477 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7479 for (t=d; isSPACE(*t);)
7481 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7483 && !(t[0] == '=' && t[1] == '>')
7484 && !(t[0] == ':' && t[1] == ':')
7485 && !keyword(s, d-s, 0)
7487 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7488 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7489 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7495 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7497 pl_yylval.ival = OP_OR;
7507 LOP(OP_OPEN_DIR,XTERM);
7510 checkcomma(s,PL_tokenbuf,"filehandle");
7514 checkcomma(s,PL_tokenbuf,"filehandle");
7533 s = force_word(s,WORD,FALSE,TRUE);
7535 s = force_strict_version(s);
7539 LOP(OP_PIPE_OP,XTERM);
7542 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7545 COPLINE_SET_FROM_MULTI_END;
7546 pl_yylval.ival = OP_CONST;
7547 TERM(sublex_start());
7554 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7557 COPLINE_SET_FROM_MULTI_END;
7558 PL_expect = XOPERATOR;
7559 if (SvCUR(PL_lex_stuff)) {
7560 int warned_comma = !ckWARN(WARN_QW);
7561 int warned_comment = warned_comma;
7562 d = SvPV_force(PL_lex_stuff, len);
7564 for (; isSPACE(*d) && len; --len, ++d)
7569 if (!warned_comma || !warned_comment) {
7570 for (; !isSPACE(*d) && len; --len, ++d) {
7571 if (!warned_comma && *d == ',') {
7572 Perl_warner(aTHX_ packWARN(WARN_QW),
7573 "Possible attempt to separate words with commas");
7576 else if (!warned_comment && *d == '#') {
7577 Perl_warner(aTHX_ packWARN(WARN_QW),
7578 "Possible attempt to put comments in qw() list");
7584 for (; !isSPACE(*d) && len; --len, ++d)
7587 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7588 words = op_append_elem(OP_LIST, words,
7589 newSVOP(OP_CONST, 0, tokeq(sv)));
7594 words = newNULLLIST();
7596 SvREFCNT_dec(PL_lex_stuff);
7597 PL_lex_stuff = NULL;
7599 PL_expect = XOPERATOR;
7600 pl_yylval.opval = sawparens(words);
7605 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7608 pl_yylval.ival = OP_STRINGIFY;
7609 if (SvIVX(PL_lex_stuff) == '\'')
7610 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7611 TERM(sublex_start());
7614 s = scan_pat(s,OP_QR);
7615 TERM(sublex_start());
7618 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7621 pl_yylval.ival = OP_BACKTICK;
7622 TERM(sublex_start());
7630 s = force_version(s, FALSE);
7632 else if (*s != 'v' || !isDIGIT(s[1])
7633 || (s = force_version(s, TRUE), *s == 'v'))
7635 *PL_tokenbuf = '\0';
7636 s = force_word(s,WORD,TRUE,TRUE);
7637 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7638 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7639 GV_ADD | (UTF ? SVf_UTF8 : 0));
7641 yyerror("<> at require-statement should be quotes");
7643 if (orig_keyword == KEY_require) {
7649 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7651 PL_last_uni = PL_oldbufptr;
7652 PL_last_lop_op = OP_REQUIRE;
7654 return REPORT( (int)REQUIRE );
7663 LOP(OP_RENAME,XTERM);
7672 LOP(OP_RINDEX,XTERM);
7681 UNIDOR(OP_READLINE);
7684 UNIDOR(OP_BACKTICK);
7693 LOP(OP_REVERSE,XTERM);
7696 UNIDOR(OP_READLINK);
7703 if (pl_yylval.opval)
7704 TERM(sublex_start());
7706 TOKEN(1); /* force error */
7709 checkcomma(s,PL_tokenbuf,"filehandle");
7719 LOP(OP_SELECT,XTERM);
7725 LOP(OP_SEMCTL,XTERM);
7728 LOP(OP_SEMGET,XTERM);
7731 LOP(OP_SEMOP,XTERM);
7737 LOP(OP_SETPGRP,XTERM);
7739 case KEY_setpriority:
7740 LOP(OP_SETPRIORITY,XTERM);
7742 case KEY_sethostent:
7748 case KEY_setservent:
7751 case KEY_setprotoent:
7761 LOP(OP_SEEKDIR,XTERM);
7763 case KEY_setsockopt:
7764 LOP(OP_SSOCKOPT,XTERM);
7770 LOP(OP_SHMCTL,XTERM);
7773 LOP(OP_SHMGET,XTERM);
7776 LOP(OP_SHMREAD,XTERM);
7779 LOP(OP_SHMWRITE,XTERM);
7782 LOP(OP_SHUTDOWN,XTERM);
7791 LOP(OP_SOCKET,XTERM);
7793 case KEY_socketpair:
7794 LOP(OP_SOCKPAIR,XTERM);
7797 checkcomma(s,PL_tokenbuf,"subroutine name");
7800 s = force_word(s,WORD,TRUE,TRUE);
7804 LOP(OP_SPLIT,XTERM);
7807 LOP(OP_SPRINTF,XTERM);
7810 LOP(OP_SPLICE,XTERM);
7825 LOP(OP_SUBSTR,XTERM);
7831 char * const tmpbuf = PL_tokenbuf + 1;
7832 expectation attrful;
7833 bool have_name, have_proto;
7834 const int key = tmp;
7835 SV *format_name = NULL;
7840 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7841 (*s == ':' && s[1] == ':'))
7845 attrful = XATTRBLOCK;
7846 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7848 if (key == KEY_format)
7849 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7851 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7853 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
7855 sv_setpvn(PL_subname, tmpbuf, len);
7857 sv_setsv(PL_subname,PL_curstname);
7858 sv_catpvs(PL_subname,"::");
7859 sv_catpvn(PL_subname,tmpbuf,len);
7861 if (SvUTF8(PL_linestr))
7862 SvUTF8_on(PL_subname);
7869 if (key == KEY_my || key == KEY_our || key==KEY_state)
7872 /* diag_listed_as: Missing name in "%s sub" */
7874 "Missing name in \"%s\"", PL_bufptr);
7876 PL_expect = XTERMBLOCK;
7877 attrful = XATTRTERM;
7878 sv_setpvs(PL_subname,"?");
7882 if (key == KEY_format) {
7884 NEXTVAL_NEXTTOKE.opval
7885 = (OP*)newSVOP(OP_CONST,0, format_name);
7886 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
7892 /* Look for a prototype */
7893 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
7894 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7895 COPLINE_SET_FROM_MULTI_END;
7897 Perl_croak(aTHX_ "Prototype not terminated");
7898 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
7906 if (*s == ':' && s[1] != ':')
7907 PL_expect = attrful;
7908 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
7910 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
7911 else if (*s != ';' && *s != '}')
7912 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
7916 NEXTVAL_NEXTTOKE.opval =
7917 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
7918 PL_lex_stuff = NULL;
7923 sv_setpvs(PL_subname, "__ANON__");
7925 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7928 force_ident_maybe_lex('&');
7933 LOP(OP_SYSTEM,XREF);
7936 LOP(OP_SYMLINK,XTERM);
7939 LOP(OP_SYSCALL,XTERM);
7942 LOP(OP_SYSOPEN,XTERM);
7945 LOP(OP_SYSSEEK,XTERM);
7948 LOP(OP_SYSREAD,XTERM);
7951 LOP(OP_SYSWRITE,XTERM);
7956 TERM(sublex_start());
7977 LOP(OP_TRUNCATE,XTERM);
7989 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7991 pl_yylval.ival = CopLINE(PL_curcop);
7995 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7997 pl_yylval.ival = CopLINE(PL_curcop);
8001 LOP(OP_UNLINK,XTERM);
8007 LOP(OP_UNPACK,XTERM);
8010 LOP(OP_UTIME,XTERM);
8016 LOP(OP_UNSHIFT,XTERM);
8019 s = tokenize_use(1, s);
8029 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8031 pl_yylval.ival = CopLINE(PL_curcop);
8032 Perl_ck_warner_d(aTHX_
8033 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8034 "when is experimental");
8038 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8040 pl_yylval.ival = CopLINE(PL_curcop);
8044 PL_hints |= HINT_BLOCK_SCOPE;
8051 LOP(OP_WAITPID,XTERM);
8057 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8058 * we use the same number on EBCDIC */
8059 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8063 if (PL_expect == XOPERATOR) {
8064 if (*s == '=' && !PL_lex_allbrackets &&
8065 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8073 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8075 pl_yylval.ival = OP_XOR;
8084 Looks up an identifier in the pad or in a package
8087 PRIVATEREF if this is a lexical name.
8088 WORD if this belongs to a package.
8091 if we're in a my declaration
8092 croak if they tried to say my($foo::bar)
8093 build the ops for a my() declaration
8094 if it's an access to a my() variable
8095 build ops for access to a my() variable
8096 if in a dq string, and they've said @foo and we can't find @foo
8098 build ops for a bareword
8102 S_pending_ident(pTHX)
8105 const char pit = (char)pl_yylval.ival;
8106 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8107 /* All routes through this function want to know if there is a colon. */
8108 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8110 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8111 "### Pending identifier '%s'\n", PL_tokenbuf); });
8113 /* if we're in a my(), we can't allow dynamics here.
8114 $foo'bar has already been turned into $foo::bar, so
8115 just check for colons.
8117 if it's a legal name, the OP is a PADANY.
8120 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8122 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8123 "variable %s in \"our\"",
8124 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8125 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8129 /* PL_no_myglob is constant */
8130 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8131 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8132 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8133 UTF ? SVf_UTF8 : 0);
8137 pl_yylval.opval = newOP(OP_PADANY, 0);
8138 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8139 UTF ? SVf_UTF8 : 0);
8145 build the ops for accesses to a my() variable.
8150 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8151 UTF ? SVf_UTF8 : 0);
8152 if (tmp != NOT_IN_PAD) {
8153 /* might be an "our" variable" */
8154 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8155 /* build ops for a bareword */
8156 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8157 HEK * const stashname = HvNAME_HEK(stash);
8158 SV * const sym = newSVhek(stashname);
8159 sv_catpvs(sym, "::");
8160 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8161 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8162 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8166 ((PL_tokenbuf[0] == '$') ? SVt_PV
8167 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8172 pl_yylval.opval = newOP(OP_PADANY, 0);
8173 pl_yylval.opval->op_targ = tmp;
8179 Whine if they've said @foo in a doublequoted string,
8180 and @foo isn't a variable we can find in the symbol
8183 if (ckWARN(WARN_AMBIGUOUS) &&
8184 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8185 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8186 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8187 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8188 /* DO NOT warn for @- and @+ */
8189 && !( PL_tokenbuf[2] == '\0' &&
8190 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8193 /* Downgraded from fatal to warning 20000522 mjd */
8194 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8195 "Possible unintended interpolation of %"UTF8f
8197 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8201 /* build ops for a bareword */
8202 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8203 newSVpvn_flags(PL_tokenbuf + 1,
8205 UTF ? SVf_UTF8 : 0 ));
8206 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8208 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8209 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8210 | ( UTF ? SVf_UTF8 : 0 ),
8211 ((PL_tokenbuf[0] == '$') ? SVt_PV
8212 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8218 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8220 PERL_ARGS_ASSERT_CHECKCOMMA;
8222 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8223 if (ckWARN(WARN_SYNTAX)) {
8226 for (w = s+2; *w && level; w++) {
8234 /* the list of chars below is for end of statements or
8235 * block / parens, boolean operators (&&, ||, //) and branch
8236 * constructs (or, and, if, until, unless, while, err, for).
8237 * Not a very solid hack... */
8238 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8239 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8240 "%s (...) interpreted as function",name);
8243 while (s < PL_bufend && isSPACE(*s))
8247 while (s < PL_bufend && isSPACE(*s))
8249 if (isIDFIRST_lazy_if(s,UTF)) {
8250 const char * const w = s;
8251 s += UTF ? UTF8SKIP(s) : 1;
8252 while (isWORDCHAR_lazy_if(s,UTF))
8253 s += UTF ? UTF8SKIP(s) : 1;
8254 while (s < PL_bufend && isSPACE(*s))
8258 if (keyword(w, s - w, 0))
8261 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8262 if (gv && GvCVu(gv))
8264 Perl_croak(aTHX_ "No comma allowed after %s", what);
8269 /* S_new_constant(): do any overload::constant lookup.
8271 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8272 Best used as sv=new_constant(..., sv, ...).
8273 If s, pv are NULL, calls subroutine with one argument,
8274 and <type> is used with error messages only.
8275 <type> is assumed to be well formed UTF-8 */
8278 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8279 SV *sv, SV *pv, const char *type, STRLEN typelen)
8282 HV * table = GvHV(PL_hintgv); /* ^H */
8287 const char *why1 = "", *why2 = "", *why3 = "";
8289 PERL_ARGS_ASSERT_NEW_CONSTANT;
8290 /* We assume that this is true: */
8291 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8294 /* charnames doesn't work well if there have been errors found */
8295 if (PL_error_count > 0 && *key == 'c')
8297 SvREFCNT_dec_NN(sv);
8298 return &PL_sv_undef;
8301 sv_2mortal(sv); /* Parent created it permanently */
8303 || ! (PL_hints & HINT_LOCALIZE_HH)
8304 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8309 /* Here haven't found what we're looking for. If it is charnames,
8310 * perhaps it needs to be loaded. Try doing that before giving up */
8312 Perl_load_module(aTHX_
8314 newSVpvs("_charnames"),
8315 /* version parameter; no need to specify it, as if
8316 * we get too early a version, will fail anyway,
8317 * not being able to find '_charnames' */
8322 assert(sp == PL_stack_sp);
8323 table = GvHV(PL_hintgv);
8325 && (PL_hints & HINT_LOCALIZE_HH)
8326 && (cvp = hv_fetch(table, key, keylen, FALSE))
8332 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8333 msg = Perl_form(aTHX_
8334 "Constant(%.*s) unknown",
8335 (int)(type ? typelen : len),
8341 why3 = "} is not defined";
8344 msg = Perl_form(aTHX_
8345 /* The +3 is for '\N{'; -4 for that, plus '}' */
8346 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8350 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8351 (int)(type ? typelen : len),
8352 (type ? type: s), why1, why2, why3);
8355 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8356 return SvREFCNT_inc_simple_NN(sv);
8361 pv = newSVpvn_flags(s, len, SVs_TEMP);
8363 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8365 typesv = &PL_sv_undef;
8367 PUSHSTACKi(PERLSI_OVERLOAD);
8379 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8383 /* Check the eval first */
8384 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8386 const char * errstr;
8387 sv_catpvs(errsv, "Propagated");
8388 errstr = SvPV_const(errsv, errlen);
8389 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8391 res = SvREFCNT_inc_simple_NN(sv);
8395 SvREFCNT_inc_simple_void_NN(res);
8404 why1 = "Call to &{$^H{";
8406 why3 = "}} did not return a defined value";
8408 (void)sv_2mortal(sv);
8415 PERL_STATIC_INLINE void
8416 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8417 PERL_ARGS_ASSERT_PARSE_IDENT;
8421 Perl_croak(aTHX_ "%s", ident_too_long);
8422 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8423 /* The UTF-8 case must come first, otherwise things
8424 * like c\N{COMBINING TILDE} would start failing, as the
8425 * isWORDCHAR_A case below would gobble the 'c' up.
8428 char *t = *s + UTF8SKIP(*s);
8429 while (isIDCONT_utf8((U8*)t))
8431 if (*d + (t - *s) > e)
8432 Perl_croak(aTHX_ "%s", ident_too_long);
8433 Copy(*s, *d, t - *s, char);
8437 else if ( isWORDCHAR_A(**s) ) {
8440 } while (isWORDCHAR_A(**s) && *d < e);
8442 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8447 else if (allow_package && **s == ':' && (*s)[1] == ':'
8448 /* Disallow things like Foo::$bar. For the curious, this is
8449 * the code path that triggers the "Bad name after" warning
8450 * when looking for barewords.
8452 && (*s)[2] != '$') {
8462 /* Returns a NUL terminated string, with the length of the string written to
8466 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8469 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8470 bool is_utf8 = cBOOL(UTF);
8472 PERL_ARGS_ASSERT_SCAN_WORD;
8474 parse_ident(&s, &d, e, allow_package, is_utf8);
8481 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8483 I32 herelines = PL_parser->herelines;
8484 SSize_t bracket = -1;
8487 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8488 bool is_utf8 = cBOOL(UTF);
8489 I32 orig_copline = 0, tmp_copline = 0;
8491 PERL_ARGS_ASSERT_SCAN_IDENT;
8496 while (isDIGIT(*s)) {
8498 Perl_croak(aTHX_ "%s", ident_too_long);
8503 parse_ident(&s, &d, e, 1, is_utf8);
8508 /* Either a digit variable, or parse_ident() found an identifier
8509 (anything valid as a bareword), so job done and return. */
8510 if (PL_lex_state != LEX_NORMAL)
8511 PL_lex_state = LEX_INTERPENDMAYBE;
8514 if (*s == '$' && s[1] &&
8515 (isIDFIRST_lazy_if(s+1,is_utf8)
8516 || isDIGIT_A((U8)s[1])
8519 || strnEQ(s+1,"::",2)) )
8521 /* Dereferencing a value in a scalar variable.
8522 The alternatives are different syntaxes for a scalar variable.
8523 Using ' as a leading package separator isn't allowed. :: is. */
8526 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8528 bracket = s - SvPVX(PL_linestr);
8530 orig_copline = CopLINE(PL_curcop);
8531 if (s < PL_bufend && isSPACE(*s)) {
8536 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8537 * iff Unicode semantics are to be used. The legal ones are any of:
8539 * b) ASCII punctuation
8540 * c) When not under Unicode rules, any upper Latin1 character
8541 * d) \c?, \c\, \c^, \c_, and \cA..\cZ, minus the ones that have traditionally
8542 * been matched by \s on ASCII platforms. That is: \c?, plus 1-32, minus
8544 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
8545 || isDIGIT_A((U8)(d)) \
8546 || (!(u) && !isASCII((U8)(d))) \
8547 || ((((U8)(d)) < 32) \
8548 && (((((U8)(d)) >= 14) \
8549 || (((U8)(d)) <= 8 && (d) != 0) \
8550 || (((U8)(d)) == 13)))) \
8551 || (((U8)(d)) == toCTRL('?')))
8553 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
8555 if ( isCNTRL_A((U8)*s) ) {
8556 deprecate("literal control characters in variable names");
8560 const STRLEN skip = UTF8SKIP(s);
8563 for ( i = 0; i < skip; i++ )
8571 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8572 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8576 /* Warn about ambiguous code after unary operators if {...} notation isn't
8577 used. There's no difference in ambiguity; it's merely a heuristic
8578 about when not to warn. */
8579 else if (ck_uni && bracket == -1)
8581 if (bracket != -1) {
8582 /* If we were processing {...} notation then... */
8583 if (isIDFIRST_lazy_if(d,is_utf8)) {
8584 /* if it starts as a valid identifier, assume that it is one.
8585 (the later check for } being at the expected point will trap
8586 cases where this doesn't pan out.) */
8587 d += is_utf8 ? UTF8SKIP(d) : 1;
8588 parse_ident(&s, &d, e, 1, is_utf8);
8590 tmp_copline = CopLINE(PL_curcop);
8591 if (s < PL_bufend && isSPACE(*s)) {
8594 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8595 /* ${foo[0]} and ${foo{bar}} notation. */
8596 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8597 const char * const brack =
8599 ((*s == '[') ? "[...]" : "{...}");
8600 orig_copline = CopLINE(PL_curcop);
8601 CopLINE_set(PL_curcop, tmp_copline);
8602 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8603 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8604 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8605 funny, dest, brack, funny, dest, brack);
8606 CopLINE_set(PL_curcop, orig_copline);
8609 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8610 PL_lex_allbrackets++;
8614 /* Handle extended ${^Foo} variables
8615 * 1999-02-27 mjd-perl-patch@plover.com */
8616 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8620 while (isWORDCHAR(*s) && d < e) {
8624 Perl_croak(aTHX_ "%s", ident_too_long);
8629 tmp_copline = CopLINE(PL_curcop);
8630 if (s < PL_bufend && isSPACE(*s)) {
8634 /* Expect to find a closing } after consuming any trailing whitespace.
8638 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8639 PL_lex_state = LEX_INTERPEND;
8642 if (PL_lex_state == LEX_NORMAL) {
8643 if (ckWARN(WARN_AMBIGUOUS) &&
8644 (keyword(dest, d - dest, 0)
8645 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8647 SV *tmp = newSVpvn_flags( dest, d - dest,
8648 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8651 orig_copline = CopLINE(PL_curcop);
8652 CopLINE_set(PL_curcop, tmp_copline);
8653 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8654 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8655 funny, SVfARG(tmp), funny, SVfARG(tmp));
8656 CopLINE_set(PL_curcop, orig_copline);
8661 /* Didn't find the closing } at the point we expected, so restore
8662 state such that the next thing to process is the opening { and */
8663 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8664 CopLINE_set(PL_curcop, orig_copline);
8665 PL_parser->herelines = herelines;
8669 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8670 PL_lex_state = LEX_INTERPEND;
8675 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8677 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8678 * the parse starting at 's', based on the subset that are valid in this
8679 * context input to this routine in 'valid_flags'. Advances s. Returns
8680 * TRUE if the input should be treated as a valid flag, so the next char
8681 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
8682 * first call on the current regex. This routine will set it to any
8683 * charset modifier found. The caller shouldn't change it. This way,
8684 * another charset modifier encountered in the parse can be detected as an
8685 * error, as we have decided to allow only one */
8688 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8690 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8691 if (isWORDCHAR_lazy_if(*s, UTF)) {
8692 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8693 UTF ? SVf_UTF8 : 0);
8695 /* Pretend that it worked, so will continue processing before
8704 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8705 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8706 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8707 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8708 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8709 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8710 case LOCALE_PAT_MOD:
8712 goto multiple_charsets;
8714 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8717 case UNICODE_PAT_MOD:
8719 goto multiple_charsets;
8721 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8724 case ASCII_RESTRICT_PAT_MOD:
8726 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8730 /* Error if previous modifier wasn't an 'a', but if it was, see
8731 * if, and accept, a second occurrence (only) */
8733 || get_regex_charset(*pmfl)
8734 != REGEX_ASCII_RESTRICTED_CHARSET)
8736 goto multiple_charsets;
8738 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8742 case DEPENDS_PAT_MOD:
8744 goto multiple_charsets;
8746 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8755 if (*charset != c) {
8756 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8758 else if (c == 'a') {
8759 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8760 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8763 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8766 /* Pretend that it worked, so will continue processing before dieing */
8772 S_scan_pat(pTHX_ char *start, I32 type)
8776 const char * const valid_flags =
8777 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8778 char charset = '\0'; /* character set modifier */
8780 PERL_ARGS_ASSERT_SCAN_PAT;
8782 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8784 Perl_croak(aTHX_ "Search pattern not terminated");
8786 pm = (PMOP*)newPMOP(type, 0);
8787 if (PL_multi_open == '?') {
8788 /* This is the only point in the code that sets PMf_ONCE: */
8789 pm->op_pmflags |= PMf_ONCE;
8791 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8792 allows us to restrict the list needed by reset to just the ??
8794 assert(type != OP_TRANS);
8796 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8799 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8802 elements = mg->mg_len / sizeof(PMOP**);
8803 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8804 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8805 mg->mg_len = elements * sizeof(PMOP**);
8806 PmopSTASH_set(pm,PL_curstash);
8810 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8811 * anon CV. False positives like qr/[(?{]/ are harmless */
8813 if (type == OP_QR) {
8815 char *e, *p = SvPV(PL_lex_stuff, len);
8817 for (; p < e; p++) {
8818 if (p[0] == '(' && p[1] == '?'
8819 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8821 pm->op_pmflags |= PMf_HAS_CV;
8825 pm->op_pmflags |= PMf_IS_QR;
8828 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
8829 /* issue a warning if /c is specified,but /g is not */
8830 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8832 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8833 "Use of /c modifier is meaningless without /g" );
8836 PL_lex_op = (OP*)pm;
8837 pl_yylval.ival = OP_MATCH;
8842 S_scan_subst(pTHX_ char *start)
8849 char charset = '\0'; /* character set modifier */
8852 PERL_ARGS_ASSERT_SCAN_SUBST;
8854 pl_yylval.ival = OP_NULL;
8856 s = scan_str(start, TRUE, FALSE, FALSE, &t);
8859 Perl_croak(aTHX_ "Substitution pattern not terminated");
8863 first_start = PL_multi_start;
8864 first_line = CopLINE(PL_curcop);
8865 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8868 SvREFCNT_dec(PL_lex_stuff);
8869 PL_lex_stuff = NULL;
8871 Perl_croak(aTHX_ "Substitution replacement not terminated");
8873 PL_multi_start = first_start; /* so whole substitution is taken together */
8875 pm = (PMOP*)newPMOP(OP_SUBST, 0);
8879 if (*s == EXEC_PAT_MOD) {
8883 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
8889 if ((pm->op_pmflags & PMf_CONTINUE)) {
8890 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
8894 SV * const repl = newSVpvs("");
8897 pm->op_pmflags |= PMf_EVAL;
8900 sv_catpvs(repl, "eval ");
8902 sv_catpvs(repl, "do ");
8904 sv_catpvs(repl, "{");
8905 sv_catsv(repl, PL_sublex_info.repl);
8906 sv_catpvs(repl, "}");
8908 SvREFCNT_dec(PL_sublex_info.repl);
8909 PL_sublex_info.repl = repl;
8911 if (CopLINE(PL_curcop) != first_line) {
8912 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
8913 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
8914 CopLINE(PL_curcop) - first_line;
8915 CopLINE_set(PL_curcop, first_line);
8918 PL_lex_op = (OP*)pm;
8919 pl_yylval.ival = OP_SUBST;
8924 S_scan_trans(pTHX_ char *start)
8931 bool nondestruct = 0;
8934 PERL_ARGS_ASSERT_SCAN_TRANS;
8936 pl_yylval.ival = OP_NULL;
8938 s = scan_str(start,FALSE,FALSE,FALSE,&t);
8940 Perl_croak(aTHX_ "Transliteration pattern not terminated");
8944 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8947 SvREFCNT_dec(PL_lex_stuff);
8948 PL_lex_stuff = NULL;
8950 Perl_croak(aTHX_ "Transliteration replacement not terminated");
8953 complement = del = squash = 0;
8957 complement = OPpTRANS_COMPLEMENT;
8960 del = OPpTRANS_DELETE;
8963 squash = OPpTRANS_SQUASH;
8975 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
8976 o->op_private &= ~OPpTRANS_ALL;
8977 o->op_private |= del|squash|complement|
8978 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
8979 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
8982 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
8989 Takes a pointer to the first < in <<FOO.
8990 Returns a pointer to the byte following <<FOO.
8992 This function scans a heredoc, which involves different methods
8993 depending on whether we are in a string eval, quoted construct, etc.
8994 This is because PL_linestr could containing a single line of input, or
8995 a whole string being evalled, or the contents of the current quote-
8998 The two basic methods are:
8999 - Steal lines from the input stream
9000 - Scan the heredoc in PL_linestr and remove it therefrom
9002 In a file scope or filtered eval, the first method is used; in a
9003 string eval, the second.
9005 In a quote-like operator, we have to choose between the two,
9006 depending on where we can find a newline. We peek into outer lex-
9007 ing scopes until we find one with a newline in it. If we reach the
9008 outermost lexing scope and it is a file, we use the stream method.
9009 Otherwise it is treated as an eval.
9013 S_scan_heredoc(pTHX_ char *s)
9015 I32 op_type = OP_SCALAR;
9022 const bool infile = PL_rsfp || PL_parser->filtered;
9023 const line_t origline = CopLINE(PL_curcop);
9024 LEXSHARED *shared = PL_parser->lex_shared;
9026 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9029 d = PL_tokenbuf + 1;
9030 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9031 *PL_tokenbuf = '\n';
9033 while (SPACE_OR_TAB(*peek))
9035 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9038 s = delimcpy(d, e, s, PL_bufend, term, &len);
9040 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9046 /* <<\FOO is equivalent to <<'FOO' */
9050 if (!isWORDCHAR_lazy_if(s,UTF))
9051 deprecate("bare << to mean <<\"\"");
9052 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9057 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9058 Perl_croak(aTHX_ "Delimiter for here document is too long");
9061 len = d - PL_tokenbuf;
9063 #ifndef PERL_STRICT_CR
9064 d = strchr(s, '\r');
9066 char * const olds = s;
9068 while (s < PL_bufend) {
9074 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9083 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9088 tmpstr = newSV_type(SVt_PVIV);
9092 SvIV_set(tmpstr, -1);
9094 else if (term == '`') {
9095 op_type = OP_BACKTICK;
9096 SvIV_set(tmpstr, '\\');
9099 PL_multi_start = origline + 1 + PL_parser->herelines;
9100 PL_multi_open = PL_multi_close = '<';
9101 /* inside a string eval or quote-like operator */
9102 if (!infile || PL_lex_inwhat) {
9105 char * const olds = s;
9106 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9107 /* These two fields are not set until an inner lexing scope is
9108 entered. But we need them set here. */
9109 shared->ls_bufptr = s;
9110 shared->ls_linestr = PL_linestr;
9112 /* Look for a newline. If the current buffer does not have one,
9113 peek into the line buffer of the parent lexing scope, going
9114 up as many levels as necessary to find one with a newline
9117 while (!(s = (char *)memchr(
9118 (void *)shared->ls_bufptr, '\n',
9119 SvEND(shared->ls_linestr)-shared->ls_bufptr
9121 shared = shared->ls_prev;
9122 /* shared is only null if we have gone beyond the outermost
9123 lexing scope. In a file, we will have broken out of the
9124 loop in the previous iteration. In an eval, the string buf-
9125 fer ends with "\n;", so the while condition above will have
9126 evaluated to false. So shared can never be null. */
9128 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9129 most lexing scope. In a file, shared->ls_linestr at that
9130 level is just one line, so there is no body to steal. */
9131 if (infile && !shared->ls_prev) {
9137 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9140 linestr = shared->ls_linestr;
9141 bufend = SvEND(linestr);
9143 while (s < bufend - len + 1 &&
9144 memNE(s,PL_tokenbuf,len) ) {
9146 ++PL_parser->herelines;
9148 if (s >= bufend - len + 1) {
9151 sv_setpvn(tmpstr,d+1,s-d);
9153 /* the preceding stmt passes a newline */
9154 PL_parser->herelines++;
9156 /* s now points to the newline after the heredoc terminator.
9157 d points to the newline before the body of the heredoc.
9160 /* We are going to modify linestr in place here, so set
9161 aside copies of the string if necessary for re-evals or
9163 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9164 check shared->re_eval_str. */
9165 if (shared->re_eval_start || shared->re_eval_str) {
9166 /* Set aside the rest of the regexp */
9167 if (!shared->re_eval_str)
9168 shared->re_eval_str =
9169 newSVpvn(shared->re_eval_start,
9170 bufend - shared->re_eval_start);
9171 shared->re_eval_start -= s-d;
9173 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9174 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9175 cx->blk_eval.cur_text == linestr)
9177 cx->blk_eval.cur_text = newSVsv(linestr);
9178 SvSCREAM_on(cx->blk_eval.cur_text);
9180 /* Copy everything from s onwards back to d. */
9181 Move(s,d,bufend-s + 1,char);
9182 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9183 /* Setting PL_bufend only applies when we have not dug deeper
9184 into other scopes, because sublex_done sets PL_bufend to
9185 SvEND(PL_linestr). */
9186 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9193 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9194 term = PL_tokenbuf[1];
9196 linestr_save = PL_linestr; /* must restore this afterwards */
9197 d = s; /* and this */
9198 PL_linestr = newSVpvs("");
9199 PL_bufend = SvPVX(PL_linestr);
9201 PL_bufptr = PL_bufend;
9202 CopLINE_set(PL_curcop,
9203 origline + 1 + PL_parser->herelines);
9204 if (!lex_next_chunk(LEX_NO_TERM)
9205 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9206 SvREFCNT_dec(linestr_save);
9209 CopLINE_set(PL_curcop, origline);
9210 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9211 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9212 /* ^That should be enough to avoid this needing to grow: */
9213 sv_catpvs(PL_linestr, "\n\0");
9214 assert(s == SvPVX(PL_linestr));
9215 PL_bufend = SvEND(PL_linestr);
9218 PL_parser->herelines++;
9219 PL_last_lop = PL_last_uni = NULL;
9220 #ifndef PERL_STRICT_CR
9221 if (PL_bufend - PL_linestart >= 2) {
9222 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9223 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9225 PL_bufend[-2] = '\n';
9227 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9229 else if (PL_bufend[-1] == '\r')
9230 PL_bufend[-1] = '\n';
9232 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9233 PL_bufend[-1] = '\n';
9235 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
9236 SvREFCNT_dec(PL_linestr);
9237 PL_linestr = linestr_save;
9238 PL_linestart = SvPVX(linestr_save);
9239 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9244 sv_catsv(tmpstr,PL_linestr);
9248 PL_multi_end = origline + PL_parser->herelines;
9249 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9250 SvPV_shrink_to_cur(tmpstr);
9253 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9255 else if (PL_encoding)
9256 sv_recode_to_utf8(tmpstr, PL_encoding);
9258 PL_lex_stuff = tmpstr;
9259 pl_yylval.ival = op_type;
9263 SvREFCNT_dec(tmpstr);
9264 CopLINE_set(PL_curcop, origline);
9265 missingterm(PL_tokenbuf + 1);
9269 takes: current position in input buffer
9270 returns: new position in input buffer
9271 side-effects: pl_yylval and lex_op are set.
9276 <FH> read from filehandle
9277 <pkg::FH> read from package qualified filehandle
9278 <pkg'FH> read from package qualified filehandle
9279 <$fh> read from filehandle in $fh
9285 S_scan_inputsymbol(pTHX_ char *start)
9287 char *s = start; /* current position in buffer */
9290 char *d = PL_tokenbuf; /* start of temp holding space */
9291 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9293 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9295 end = strchr(s, '\n');
9298 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9300 /* die if we didn't have space for the contents of the <>,
9301 or if it didn't end, or if we see a newline
9304 if (len >= (I32)sizeof PL_tokenbuf)
9305 Perl_croak(aTHX_ "Excessively long <> operator");
9307 Perl_croak(aTHX_ "Unterminated <> operator");
9312 Remember, only scalar variables are interpreted as filehandles by
9313 this code. Anything more complex (e.g., <$fh{$num}>) will be
9314 treated as a glob() call.
9315 This code makes use of the fact that except for the $ at the front,
9316 a scalar variable and a filehandle look the same.
9318 if (*d == '$' && d[1]) d++;
9320 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9321 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9322 d += UTF ? UTF8SKIP(d) : 1;
9324 /* If we've tried to read what we allow filehandles to look like, and
9325 there's still text left, then it must be a glob() and not a getline.
9326 Use scan_str to pull out the stuff between the <> and treat it
9327 as nothing more than a string.
9330 if (d - PL_tokenbuf != len) {
9331 pl_yylval.ival = OP_GLOB;
9332 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9334 Perl_croak(aTHX_ "Glob not terminated");
9338 bool readline_overriden = FALSE;
9340 /* we're in a filehandle read situation */
9343 /* turn <> into <ARGV> */
9345 Copy("ARGV",d,5,char);
9347 /* Check whether readline() is overriden */
9348 if ((gv_readline = gv_override("readline",8)))
9349 readline_overriden = TRUE;
9351 /* if <$fh>, create the ops to turn the variable into a
9355 /* try to find it in the pad for this block, otherwise find
9356 add symbol table ops
9358 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9359 if (tmp != NOT_IN_PAD) {
9360 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9361 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9362 HEK * const stashname = HvNAME_HEK(stash);
9363 SV * const sym = sv_2mortal(newSVhek(stashname));
9364 sv_catpvs(sym, "::");
9370 OP * const o = newOP(OP_PADSV, 0);
9372 PL_lex_op = readline_overriden
9373 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9374 op_append_elem(OP_LIST, o,
9375 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9376 : (OP*)newUNOP(OP_READLINE, 0, o);
9384 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9386 PL_lex_op = readline_overriden
9387 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9388 op_append_elem(OP_LIST,
9389 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9390 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9391 : (OP*)newUNOP(OP_READLINE, 0,
9392 newUNOP(OP_RV2SV, 0,
9393 newGVOP(OP_GV, 0, gv)));
9395 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9396 pl_yylval.ival = OP_NULL;
9399 /* If it's none of the above, it must be a literal filehandle
9400 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9402 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9403 PL_lex_op = readline_overriden
9404 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9405 op_append_elem(OP_LIST,
9406 newGVOP(OP_GV, 0, gv),
9407 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9408 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9409 pl_yylval.ival = OP_NULL;
9419 start position in buffer
9420 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9421 only if they are of the open/close form
9422 keep_delims preserve the delimiters around the string
9423 re_reparse compiling a run-time /(?{})/:
9424 collapse // to /, and skip encoding src
9425 delimp if non-null, this is set to the position of
9426 the closing delimiter, or just after it if
9427 the closing and opening delimiters differ
9428 (i.e., the opening delimiter of a substitu-
9430 returns: position to continue reading from buffer
9431 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9432 updates the read buffer.
9434 This subroutine pulls a string out of the input. It is called for:
9435 q single quotes q(literal text)
9436 ' single quotes 'literal text'
9437 qq double quotes qq(interpolate $here please)
9438 " double quotes "interpolate $here please"
9439 qx backticks qx(/bin/ls -l)
9440 ` backticks `/bin/ls -l`
9441 qw quote words @EXPORT_OK = qw( func() $spam )
9442 m// regexp match m/this/
9443 s/// regexp substitute s/this/that/
9444 tr/// string transliterate tr/this/that/
9445 y/// string transliterate y/this/that/
9446 ($*@) sub prototypes sub foo ($)
9447 (stuff) sub attr parameters sub foo : attr(stuff)
9448 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9450 In most of these cases (all but <>, patterns and transliterate)
9451 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9452 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9453 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9456 It skips whitespace before the string starts, and treats the first
9457 character as the delimiter. If the delimiter is one of ([{< then
9458 the corresponding "close" character )]}> is used as the closing
9459 delimiter. It allows quoting of delimiters, and if the string has
9460 balanced delimiters ([{<>}]) it allows nesting.
9462 On success, the SV with the resulting string is put into lex_stuff or,
9463 if that is already non-NULL, into lex_repl. The second case occurs only
9464 when parsing the RHS of the special constructs s/// and tr/// (y///).
9465 For convenience, the terminating delimiter character is stuffed into
9470 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9474 SV *sv; /* scalar value: string */
9475 const char *tmps; /* temp string, used for delimiter matching */
9476 char *s = start; /* current position in the buffer */
9477 char term; /* terminating character */
9478 char *to; /* current position in the sv's data */
9479 I32 brackets = 1; /* bracket nesting level */
9480 bool has_utf8 = FALSE; /* is there any utf8 content? */
9481 I32 termcode; /* terminating char. code */
9482 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9483 STRLEN termlen; /* length of terminating string */
9484 int last_off = 0; /* last position for nesting bracket */
9487 PERL_ARGS_ASSERT_SCAN_STR;
9489 /* skip space before the delimiter */
9494 /* mark where we are, in case we need to report errors */
9497 /* after skipping whitespace, the next character is the terminator */
9500 termcode = termstr[0] = term;
9504 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9505 Copy(s, termstr, termlen, U8);
9506 if (!UTF8_IS_INVARIANT(term))
9510 /* mark where we are */
9511 PL_multi_start = CopLINE(PL_curcop);
9512 PL_multi_open = term;
9513 herelines = PL_parser->herelines;
9515 /* find corresponding closing delimiter */
9516 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9517 termcode = termstr[0] = term = tmps[5];
9519 PL_multi_close = term;
9521 if (PL_multi_open == PL_multi_close) {
9522 keep_bracketed_quoted = FALSE;
9525 /* create a new SV to hold the contents. 79 is the SV's initial length.
9526 What a random number. */
9527 sv = newSV_type(SVt_PVIV);
9529 SvIV_set(sv, termcode);
9530 (void)SvPOK_only(sv); /* validate pointer */
9532 /* move past delimiter and try to read a complete string */
9534 sv_catpvn(sv, s, termlen);
9537 if (PL_encoding && !UTF && !re_reparse) {
9541 int offset = s - SvPVX_const(PL_linestr);
9542 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9543 &offset, (char*)termstr, termlen);
9547 if (SvIsCOW(PL_linestr)) {
9548 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9549 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9550 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9551 char *buf = SvPVX(PL_linestr);
9552 bufend_pos = PL_parser->bufend - buf;
9553 bufptr_pos = PL_parser->bufptr - buf;
9554 oldbufptr_pos = PL_parser->oldbufptr - buf;
9555 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9556 linestart_pos = PL_parser->linestart - buf;
9557 last_uni_pos = PL_parser->last_uni
9558 ? PL_parser->last_uni - buf
9560 last_lop_pos = PL_parser->last_lop
9561 ? PL_parser->last_lop - buf
9564 PL_parser->lex_shared->re_eval_start ?
9565 PL_parser->lex_shared->re_eval_start - buf : 0;
9568 sv_force_normal(PL_linestr);
9570 buf = SvPVX(PL_linestr);
9571 PL_parser->bufend = buf + bufend_pos;
9572 PL_parser->bufptr = buf + bufptr_pos;
9573 PL_parser->oldbufptr = buf + oldbufptr_pos;
9574 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9575 PL_parser->linestart = buf + linestart_pos;
9576 if (PL_parser->last_uni)
9577 PL_parser->last_uni = buf + last_uni_pos;
9578 if (PL_parser->last_lop)
9579 PL_parser->last_lop = buf + last_lop_pos;
9580 if (PL_parser->lex_shared->re_eval_start)
9581 PL_parser->lex_shared->re_eval_start =
9582 buf + re_eval_start_pos;
9585 ns = SvPVX_const(PL_linestr) + offset;
9586 svlast = SvEND(sv) - 1;
9588 for (; s < ns; s++) {
9589 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9590 COPLINE_INC_WITH_HERELINES;
9593 goto read_more_line;
9595 /* handle quoted delimiters */
9596 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9598 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9600 if ((svlast-1 - t) % 2) {
9601 if (!keep_bracketed_quoted) {
9604 SvCUR_set(sv, SvCUR(sv) - 1);
9609 if (PL_multi_open == PL_multi_close) {
9615 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9616 /* At here, all closes are "was quoted" one,
9617 so we don't check PL_multi_close. */
9619 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9624 else if (*t == PL_multi_open)
9632 SvCUR_set(sv, w - SvPVX_const(sv));
9634 last_off = w - SvPVX(sv);
9635 if (--brackets <= 0)
9641 SvCUR_set(sv, SvCUR(sv) - 1);
9647 /* extend sv if need be */
9648 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9649 /* set 'to' to the next character in the sv's string */
9650 to = SvPVX(sv)+SvCUR(sv);
9652 /* if open delimiter is the close delimiter read unbridle */
9653 if (PL_multi_open == PL_multi_close) {
9654 for (; s < PL_bufend; s++,to++) {
9655 /* embedded newlines increment the current line number */
9656 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9657 COPLINE_INC_WITH_HERELINES;
9658 /* handle quoted delimiters */
9659 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9660 if (!keep_bracketed_quoted
9662 || (re_reparse && s[1] == '\\'))
9665 else /* any other quotes are simply copied straight through */
9668 /* terminate when run out of buffer (the for() condition), or
9669 have found the terminator */
9670 else if (*s == term) {
9673 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9676 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9682 /* if the terminator isn't the same as the start character (e.g.,
9683 matched brackets), we have to allow more in the quoting, and
9684 be prepared for nested brackets.
9687 /* read until we run out of string, or we find the terminator */
9688 for (; s < PL_bufend; s++,to++) {
9689 /* embedded newlines increment the line count */
9690 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9691 COPLINE_INC_WITH_HERELINES;
9692 /* backslashes can escape the open or closing characters */
9693 if (*s == '\\' && s+1 < PL_bufend) {
9694 if (!keep_bracketed_quoted &&
9695 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9702 /* allow nested opens and closes */
9703 else if (*s == PL_multi_close && --brackets <= 0)
9705 else if (*s == PL_multi_open)
9707 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9712 /* terminate the copied string and update the sv's end-of-string */
9714 SvCUR_set(sv, to - SvPVX_const(sv));
9717 * this next chunk reads more into the buffer if we're not done yet
9721 break; /* handle case where we are done yet :-) */
9723 #ifndef PERL_STRICT_CR
9724 if (to - SvPVX_const(sv) >= 2) {
9725 if ((to[-2] == '\r' && to[-1] == '\n') ||
9726 (to[-2] == '\n' && to[-1] == '\r'))
9730 SvCUR_set(sv, to - SvPVX_const(sv));
9732 else if (to[-1] == '\r')
9735 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9740 /* if we're out of file, or a read fails, bail and reset the current
9741 line marker so we can report where the unterminated string began
9743 COPLINE_INC_WITH_HERELINES;
9744 PL_bufptr = PL_bufend;
9745 if (!lex_next_chunk(0)) {
9747 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9753 /* at this point, we have successfully read the delimited string */
9755 if (!PL_encoding || UTF || re_reparse) {
9758 sv_catpvn(sv, s, termlen);
9761 if (has_utf8 || (PL_encoding && !re_reparse))
9764 PL_multi_end = CopLINE(PL_curcop);
9765 CopLINE_set(PL_curcop, PL_multi_start);
9766 PL_parser->herelines = herelines;
9768 /* if we allocated too much space, give some back */
9769 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9770 SvLEN_set(sv, SvCUR(sv) + 1);
9771 SvPV_renew(sv, SvLEN(sv));
9774 /* decide whether this is the first or second quoted string we've read
9779 PL_sublex_info.repl = sv;
9782 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9788 takes: pointer to position in buffer
9789 returns: pointer to new position in buffer
9790 side-effects: builds ops for the constant in pl_yylval.op
9792 Read a number in any of the formats that Perl accepts:
9794 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9795 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9796 0b[01](_?[01])* binary integers
9797 0[0-7](_?[0-7])* octal integers
9798 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9799 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9801 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9804 If it reads a number without a decimal point or an exponent, it will
9805 try converting the number to an integer and see if it can do so
9806 without loss of precision.
9810 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9812 const char *s = start; /* current position in buffer */
9813 char *d; /* destination in temp buffer */
9814 char *e; /* end of temp buffer */
9815 NV nv; /* number read, as a double */
9816 SV *sv = NULL; /* place to put the converted number */
9817 bool floatit; /* boolean: int or float? */
9818 const char *lastub = NULL; /* position of last underbar */
9819 static const char* const number_too_long = "Number too long";
9820 /* Hexadecimal floating point.
9822 * In many places (where we have quads and NV is IEEE 754 double)
9823 * we can fit the mantissa bits of a NV into an unsigned quad.
9824 * (Note that UVs might not be quads even when we have quads.)
9825 * This will not work everywhere, though (either no quads, or
9826 * using long doubles), in which case we have to resort to NV,
9827 * which will probably mean horrible loss of precision due to
9828 * multiple fp operations. */
9831 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
9832 # define HEXFP_UQUAD
9833 Uquad_t hexfp_uquad = 0;
9834 int hexfp_frac_bits = 0;
9839 NV hexfp_mult = 1.0;
9840 UV high_non_zero = 0; /* highest digit */
9842 PERL_ARGS_ASSERT_SCAN_NUM;
9844 /* We use the first character to decide what type of number this is */
9848 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
9850 /* if it starts with a 0, it could be an octal number, a decimal in
9851 0.13 disguise, or a hexadecimal number, or a binary number. */
9855 u holds the "number so far"
9856 shift the power of 2 of the base
9857 (hex == 4, octal == 3, binary == 1)
9858 overflowed was the number more than we can hold?
9860 Shift is used when we add a digit. It also serves as an "are
9861 we in octal/hex/binary?" indicator to disallow hex characters
9867 bool overflowed = FALSE;
9868 bool just_zero = TRUE; /* just plain 0 or binary number? */
9869 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
9870 static const char* const bases[5] =
9871 { "", "binary", "", "octal", "hexadecimal" };
9872 static const char* const Bases[5] =
9873 { "", "Binary", "", "Octal", "Hexadecimal" };
9874 static const char* const maxima[5] =
9876 "0b11111111111111111111111111111111",
9880 const char *base, *Base, *max;
9883 if (isALPHA_FOLD_EQ(s[1], 'x')) {
9887 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
9892 /* check for a decimal in disguise */
9893 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
9895 /* so it must be octal */
9902 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9903 "Misplaced _ in number");
9907 base = bases[shift];
9908 Base = Bases[shift];
9909 max = maxima[shift];
9911 /* read the rest of the number */
9913 /* x is used in the overflow test,
9914 b is the digit we're adding on. */
9919 /* if we don't mention it, we're done */
9923 /* _ are ignored -- but warned about if consecutive */
9925 if (lastub && s == lastub + 1)
9926 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9927 "Misplaced _ in number");
9931 /* 8 and 9 are not octal */
9934 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
9938 case '2': case '3': case '4':
9939 case '5': case '6': case '7':
9941 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
9945 b = *s++ & 15; /* ASCII digit -> value of digit */
9949 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
9950 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
9951 /* make sure they said 0x */
9956 /* Prepare to put the digit we have onto the end
9957 of the number so far. We check for overflows.
9963 x = u << shift; /* make room for the digit */
9965 total_bits += shift;
9967 if ((x >> shift) != u
9968 && !(PL_hints & HINT_NEW_BINARY)) {
9971 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
9972 "Integer overflow in %s number",
9975 u = x | b; /* add the digit to the end */
9978 n *= nvshift[shift];
9979 /* If an NV has not enough bits in its
9980 * mantissa to represent an UV this summing of
9981 * small low-order numbers is a waste of time
9982 * (because the NV cannot preserve the
9983 * low-order bits anyway): we could just
9984 * remember when did we overflow and in the
9985 * end just multiply n by the right
9990 if (high_non_zero == 0 && b > 0)
9993 /* this could be hexfp, but peek ahead
9994 * to avoid matching ".." */
9995 if (UNLIKELY(HEXFP_PEEK(s))) {
10003 /* if we get here, we had success: make a scalar value from
10008 /* final misplaced underbar check */
10009 if (s[-1] == '_') {
10010 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10013 if (UNLIKELY(HEXFP_PEEK(s))) {
10014 /* Do sloppy (on the underbars) but quick detection
10015 * (and value construction) for hexfp, the decimal
10016 * detection will shortly be more thorough with the
10017 * underbar checks. */
10021 #else /* HEXFP_NV */
10026 NV mult = 1 / 16.0;
10029 while (isXDIGIT(*h) || *h == '_') {
10030 if (isXDIGIT(*h)) {
10031 U8 b = XDIGIT_VALUE(*h);
10032 total_bits += shift;
10034 hexfp_uquad <<= shift;
10036 hexfp_frac_bits += shift;
10037 #else /* HEXFP_NV */
10038 hexfp_nv += b * mult;
10046 if (total_bits >= 4) {
10047 if (high_non_zero < 0x8)
10049 if (high_non_zero < 0x4)
10051 if (high_non_zero < 0x2)
10055 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10056 bool negexp = FALSE;
10060 else if (*h == '-') {
10066 while (isDIGIT(*h) || *h == '_') {
10069 hexfp_exp += *h - '0';
10072 -hexfp_exp < NV_MIN_EXP - 1) {
10073 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10074 "Hexadecimal float: exponent underflow");
10081 hexfp_exp > NV_MAX_EXP - 1) {
10082 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10083 "Hexadecimal float: exponent overflow");
10092 hexfp_exp = -hexfp_exp;
10094 hexfp_exp -= hexfp_frac_bits;
10096 hexfp_mult = pow(2.0, hexfp_exp);
10104 if (n > 4294967295.0)
10105 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10106 "%s number > %s non-portable",
10112 if (u > 0xffffffff)
10113 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10114 "%s number > %s non-portable",
10119 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10120 sv = new_constant(start, s - start, "integer",
10121 sv, NULL, NULL, 0);
10122 else if (PL_hints & HINT_NEW_BINARY)
10123 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10128 handle decimal numbers.
10129 we're also sent here when we read a 0 as the first digit
10131 case '1': case '2': case '3': case '4': case '5':
10132 case '6': case '7': case '8': case '9': case '.':
10135 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10144 /* read next group of digits and _ and copy into d */
10145 while (isDIGIT(*s) || *s == '_' ||
10146 UNLIKELY(hexfp && isXDIGIT(*s))) {
10147 /* skip underscores, checking for misplaced ones
10151 if (lastub && s == lastub + 1)
10152 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10153 "Misplaced _ in number");
10157 /* check for end of fixed-length buffer */
10159 Perl_croak(aTHX_ "%s", number_too_long);
10160 /* if we're ok, copy the character */
10165 /* final misplaced underbar check */
10166 if (lastub && s == lastub + 1) {
10167 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10170 /* read a decimal portion if there is one. avoid
10171 3..5 being interpreted as the number 3. followed
10174 if (*s == '.' && s[1] != '.') {
10179 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10180 "Misplaced _ in number");
10184 /* copy, ignoring underbars, until we run out of digits.
10186 for (; isDIGIT(*s) || *s == '_' ||
10187 UNLIKELY(hexfp && isXDIGIT(*s));
10189 /* fixed length buffer check */
10191 Perl_croak(aTHX_ "%s", number_too_long);
10193 if (lastub && s == lastub + 1)
10194 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10195 "Misplaced _ in number");
10201 /* fractional part ending in underbar? */
10202 if (s[-1] == '_') {
10203 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10204 "Misplaced _ in number");
10206 if (*s == '.' && isDIGIT(s[1])) {
10207 /* oops, it's really a v-string, but without the "v" */
10213 /* read exponent part, if present */
10214 if ((isALPHA_FOLD_EQ(*s, 'e')
10215 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10216 && strchr("+-0123456789_", s[1]))
10220 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10221 ditto for p (hexfloats) */
10222 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10223 /* At least some Mach atof()s don't grok 'E' */
10226 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10233 /* stray preinitial _ */
10235 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10236 "Misplaced _ in number");
10240 /* allow positive or negative exponent */
10241 if (*s == '+' || *s == '-')
10244 /* stray initial _ */
10246 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10247 "Misplaced _ in number");
10251 /* read digits of exponent */
10252 while (isDIGIT(*s) || *s == '_') {
10255 Perl_croak(aTHX_ "%s", number_too_long);
10259 if (((lastub && s == lastub + 1) ||
10260 (!isDIGIT(s[1]) && s[1] != '_')))
10261 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10262 "Misplaced _ in number");
10270 We try to do an integer conversion first if no characters
10271 indicating "float" have been found.
10276 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10278 if (flags == IS_NUMBER_IN_UV) {
10280 sv = newSViv(uv); /* Prefer IVs over UVs. */
10283 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10284 if (uv <= (UV) IV_MIN)
10285 sv = newSViv(-(IV)uv);
10292 STORE_NUMERIC_LOCAL_SET_STANDARD();
10293 /* terminate the string */
10295 if (UNLIKELY(hexfp)) {
10296 # ifdef NV_MANT_DIG
10297 if (total_bits > NV_MANT_DIG)
10298 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10299 "Hexadecimal float: mantissa overflow");
10302 nv = hexfp_uquad * hexfp_mult;
10303 #else /* HEXFP_NV */
10304 nv = hexfp_nv * hexfp_mult;
10307 nv = Atof(PL_tokenbuf);
10309 RESTORE_NUMERIC_LOCAL();
10314 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10315 const char *const key = floatit ? "float" : "integer";
10316 const STRLEN keylen = floatit ? 5 : 7;
10317 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10318 key, keylen, sv, NULL, NULL, 0);
10322 /* if it starts with a v, it could be a v-string */
10325 sv = newSV(5); /* preallocate storage space */
10326 ENTER_with_name("scan_vstring");
10328 s = scan_vstring(s, PL_bufend, sv);
10329 SvREFCNT_inc_simple_void_NN(sv);
10330 LEAVE_with_name("scan_vstring");
10334 /* make the op for the constant and return */
10337 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10339 lvalp->opval = NULL;
10345 S_scan_formline(pTHX_ char *s)
10349 SV * const stuff = newSVpvs("");
10350 bool needargs = FALSE;
10351 bool eofmt = FALSE;
10353 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10355 while (!needargs) {
10358 #ifdef PERL_STRICT_CR
10359 while (SPACE_OR_TAB(*t))
10362 while (SPACE_OR_TAB(*t) || *t == '\r')
10365 if (*t == '\n' || t == PL_bufend) {
10370 eol = (char *) memchr(s,'\n',PL_bufend-s);
10374 for (t = s; t < eol; t++) {
10375 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10377 goto enough; /* ~~ must be first line in formline */
10379 if (*t == '@' || *t == '^')
10383 sv_catpvn(stuff, s, eol-s);
10384 #ifndef PERL_STRICT_CR
10385 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10386 char *end = SvPVX(stuff) + SvCUR(stuff);
10389 SvCUR_set(stuff, SvCUR(stuff) - 1);
10397 if ((PL_rsfp || PL_parser->filtered)
10398 && PL_parser->form_lex_state == LEX_NORMAL) {
10400 PL_bufptr = PL_bufend;
10401 COPLINE_INC_WITH_HERELINES;
10402 got_some = lex_next_chunk(0);
10403 CopLINE_dec(PL_curcop);
10411 if (!SvCUR(stuff) || needargs)
10412 PL_lex_state = PL_parser->form_lex_state;
10413 if (SvCUR(stuff)) {
10414 PL_expect = XSTATE;
10416 const char *s2 = s;
10417 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10421 PL_expect = XTERMBLOCK;
10422 NEXTVAL_NEXTTOKE.ival = 0;
10425 NEXTVAL_NEXTTOKE.ival = 0;
10426 force_next(FORMLBRACK);
10429 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10431 else if (PL_encoding)
10432 sv_recode_to_utf8(stuff, PL_encoding);
10434 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10438 SvREFCNT_dec(stuff);
10440 PL_lex_formbrack = 0;
10446 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10448 const I32 oldsavestack_ix = PL_savestack_ix;
10449 CV* const outsidecv = PL_compcv;
10451 SAVEI32(PL_subline);
10452 save_item(PL_subname);
10453 SAVESPTR(PL_compcv);
10455 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10456 CvFLAGS(PL_compcv) |= flags;
10458 PL_subline = CopLINE(PL_curcop);
10459 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10460 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10461 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10462 if (outsidecv && CvPADLIST(outsidecv))
10463 CvPADLIST(PL_compcv)->xpadl_outid =
10464 PadlistNAMES(CvPADLIST(outsidecv));
10466 return oldsavestack_ix;
10470 S_yywarn(pTHX_ const char *const s, U32 flags)
10472 PERL_ARGS_ASSERT_YYWARN;
10474 PL_in_eval |= EVAL_WARNONLY;
10475 yyerror_pv(s, flags);
10476 PL_in_eval &= ~EVAL_WARNONLY;
10481 Perl_yyerror(pTHX_ const char *const s)
10483 PERL_ARGS_ASSERT_YYERROR;
10484 return yyerror_pvn(s, strlen(s), 0);
10488 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10490 PERL_ARGS_ASSERT_YYERROR_PV;
10491 return yyerror_pvn(s, strlen(s), flags);
10495 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10497 const char *context = NULL;
10500 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10501 int yychar = PL_parser->yychar;
10503 PERL_ARGS_ASSERT_YYERROR_PVN;
10505 if (!yychar || (yychar == ';' && !PL_rsfp))
10506 sv_catpvs(where_sv, "at EOF");
10507 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10508 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10509 PL_oldbufptr != PL_bufptr) {
10512 The code below is removed for NetWare because it abends/crashes on NetWare
10513 when the script has error such as not having the closing quotes like:
10514 if ($var eq "value)
10515 Checking of white spaces is anyway done in NetWare code.
10518 while (isSPACE(*PL_oldoldbufptr))
10521 context = PL_oldoldbufptr;
10522 contlen = PL_bufptr - PL_oldoldbufptr;
10524 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10525 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10528 The code below is removed for NetWare because it abends/crashes on NetWare
10529 when the script has error such as not having the closing quotes like:
10530 if ($var eq "value)
10531 Checking of white spaces is anyway done in NetWare code.
10534 while (isSPACE(*PL_oldbufptr))
10537 context = PL_oldbufptr;
10538 contlen = PL_bufptr - PL_oldbufptr;
10540 else if (yychar > 255)
10541 sv_catpvs(where_sv, "next token ???");
10542 else if (yychar == -2) { /* YYEMPTY */
10543 if (PL_lex_state == LEX_NORMAL ||
10544 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10545 sv_catpvs(where_sv, "at end of line");
10546 else if (PL_lex_inpat)
10547 sv_catpvs(where_sv, "within pattern");
10549 sv_catpvs(where_sv, "within string");
10552 sv_catpvs(where_sv, "next char ");
10554 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10555 else if (isPRINT_LC(yychar)) {
10556 const char string = yychar;
10557 sv_catpvn(where_sv, &string, 1);
10560 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10562 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10563 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10564 OutCopFILE(PL_curcop),
10565 (IV)(PL_parser->preambling == NOLINE
10566 ? CopLINE(PL_curcop)
10567 : PL_parser->preambling));
10569 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10570 UTF8fARG(UTF, contlen, context));
10572 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10573 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10574 Perl_sv_catpvf(aTHX_ msg,
10575 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10576 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10579 if (PL_in_eval & EVAL_WARNONLY) {
10580 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10584 if (PL_error_count >= 10) {
10586 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10587 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10588 SVfARG(errsv), OutCopFILE(PL_curcop));
10590 Perl_croak(aTHX_ "%s has too many errors.\n",
10591 OutCopFILE(PL_curcop));
10594 PL_in_my_stash = NULL;
10599 S_swallow_bom(pTHX_ U8 *s)
10601 const STRLEN slen = SvCUR(PL_linestr);
10603 PERL_ARGS_ASSERT_SWALLOW_BOM;
10607 if (s[1] == 0xFE) {
10608 /* UTF-16 little-endian? (or UTF-32LE?) */
10609 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10610 /* diag_listed_as: Unsupported script encoding %s */
10611 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10612 #ifndef PERL_NO_UTF16_FILTER
10613 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10615 if (PL_bufend > (char*)s) {
10616 s = add_utf16_textfilter(s, TRUE);
10619 /* diag_listed_as: Unsupported script encoding %s */
10620 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10625 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10626 #ifndef PERL_NO_UTF16_FILTER
10627 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10629 if (PL_bufend > (char *)s) {
10630 s = add_utf16_textfilter(s, FALSE);
10633 /* diag_listed_as: Unsupported script encoding %s */
10634 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10638 case BOM_UTF8_FIRST_BYTE: {
10639 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10640 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10641 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10642 s += len + 1; /* UTF-8 */
10649 if (s[2] == 0xFE && s[3] == 0xFF) {
10650 /* UTF-32 big-endian */
10651 /* diag_listed_as: Unsupported script encoding %s */
10652 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10655 else if (s[2] == 0 && s[3] != 0) {
10658 * are a good indicator of UTF-16BE. */
10659 #ifndef PERL_NO_UTF16_FILTER
10660 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10661 s = add_utf16_textfilter(s, FALSE);
10663 /* diag_listed_as: Unsupported script encoding %s */
10664 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10671 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10674 * are a good indicator of UTF-16LE. */
10675 #ifndef PERL_NO_UTF16_FILTER
10676 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10677 s = add_utf16_textfilter(s, TRUE);
10679 /* diag_listed_as: Unsupported script encoding %s */
10680 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10688 #ifndef PERL_NO_UTF16_FILTER
10690 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10692 SV *const filter = FILTER_DATA(idx);
10693 /* We re-use this each time round, throwing the contents away before we
10695 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10696 SV *const utf8_buffer = filter;
10697 IV status = IoPAGE(filter);
10698 const bool reverse = cBOOL(IoLINES(filter));
10701 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10703 /* As we're automatically added, at the lowest level, and hence only called
10704 from this file, we can be sure that we're not called in block mode. Hence
10705 don't bother writing code to deal with block mode. */
10707 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10710 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10712 DEBUG_P(PerlIO_printf(Perl_debug_log,
10713 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10714 FPTR2DPTR(void *, S_utf16_textfilter),
10715 reverse ? 'l' : 'b', idx, maxlen, status,
10716 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10723 /* First, look in our buffer of existing UTF-8 data: */
10724 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10728 } else if (status == 0) {
10730 IoPAGE(filter) = 0;
10731 nl = SvEND(utf8_buffer);
10734 STRLEN got = nl - SvPVX(utf8_buffer);
10735 /* Did we have anything to append? */
10737 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10738 /* Everything else in this code works just fine if SVp_POK isn't
10739 set. This, however, needs it, and we need it to work, else
10740 we loop infinitely because the buffer is never consumed. */
10741 sv_chop(utf8_buffer, nl);
10745 /* OK, not a complete line there, so need to read some more UTF-16.
10746 Read an extra octect if the buffer currently has an odd number. */
10750 if (SvCUR(utf16_buffer) >= 2) {
10751 /* Location of the high octet of the last complete code point.
10752 Gosh, UTF-16 is a pain. All the benefits of variable length,
10753 *coupled* with all the benefits of partial reads and
10755 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10756 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10758 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10762 /* We have the first half of a surrogate. Read more. */
10763 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10766 status = FILTER_READ(idx + 1, utf16_buffer,
10767 160 + (SvCUR(utf16_buffer) & 1));
10768 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10769 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10772 IoPAGE(filter) = status;
10777 chars = SvCUR(utf16_buffer) >> 1;
10778 have = SvCUR(utf8_buffer);
10779 SvGROW(utf8_buffer, have + chars * 3 + 1);
10782 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10783 (U8*)SvPVX_const(utf8_buffer) + have,
10784 chars * 2, &newlen);
10786 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10787 (U8*)SvPVX_const(utf8_buffer) + have,
10788 chars * 2, &newlen);
10790 SvCUR_set(utf8_buffer, have + newlen);
10793 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10794 it's private to us, and utf16_to_utf8{,reversed} take a
10795 (pointer,length) pair, rather than a NUL-terminated string. */
10796 if(SvCUR(utf16_buffer) & 1) {
10797 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10798 SvCUR_set(utf16_buffer, 1);
10800 SvCUR_set(utf16_buffer, 0);
10803 DEBUG_P(PerlIO_printf(Perl_debug_log,
10804 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10806 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10807 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10812 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10814 SV *filter = filter_add(S_utf16_textfilter, NULL);
10816 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10818 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10819 sv_setpvs(filter, "");
10820 IoLINES(filter) = reversed;
10821 IoPAGE(filter) = 1; /* Not EOF */
10823 /* Sadly, we have to return a valid pointer, come what may, so we have to
10824 ignore any error return from this. */
10825 SvCUR_set(PL_linestr, 0);
10826 if (FILTER_READ(0, PL_linestr, 0)) {
10827 SvUTF8_on(PL_linestr);
10829 SvUTF8_on(PL_linestr);
10831 PL_bufend = SvEND(PL_linestr);
10832 return (U8*)SvPVX(PL_linestr);
10837 Returns a pointer to the next character after the parsed
10838 vstring, as well as updating the passed in sv.
10840 Function must be called like
10842 sv = sv_2mortal(newSV(5));
10843 s = scan_vstring(s,e,sv);
10845 where s and e are the start and end of the string.
10846 The sv should already be large enough to store the vstring
10847 passed in, for performance reasons.
10849 This function may croak if fatal warnings are enabled in the
10850 calling scope, hence the sv_2mortal in the example (to prevent
10851 a leak). Make sure to do SvREFCNT_inc afterwards if you use
10857 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10859 const char *pos = s;
10860 const char *start = s;
10862 PERL_ARGS_ASSERT_SCAN_VSTRING;
10864 if (*pos == 'v') pos++; /* get past 'v' */
10865 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10867 if ( *pos != '.') {
10868 /* this may not be a v-string if followed by => */
10869 const char *next = pos;
10870 while (next < e && isSPACE(*next))
10872 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10873 /* return string not v-string */
10874 sv_setpvn(sv,(char *)s,pos-s);
10875 return (char *)pos;
10879 if (!isALPHA(*pos)) {
10880 U8 tmpbuf[UTF8_MAXBYTES+1];
10883 s++; /* get past 'v' */
10888 /* this is atoi() that tolerates underscores */
10891 const char *end = pos;
10893 while (--end >= s) {
10895 const UV orev = rev;
10896 rev += (*end - '0') * mult;
10899 /* diag_listed_as: Integer overflow in %s number */
10900 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10901 "Integer overflow in decimal number");
10905 if (rev > 0x7FFFFFFF)
10906 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10908 /* Append native character for the rev point */
10909 tmpend = uvchr_to_utf8(tmpbuf, rev);
10910 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10911 if (!UVCHR_IS_INVARIANT(rev))
10913 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
10919 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10923 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
10930 Perl_keyword_plugin_standard(pTHX_
10931 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
10933 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
10934 PERL_UNUSED_CONTEXT;
10935 PERL_UNUSED_ARG(keyword_ptr);
10936 PERL_UNUSED_ARG(keyword_len);
10937 PERL_UNUSED_ARG(op_ptr);
10938 return KEYWORD_PLUGIN_DECLINE;
10941 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
10943 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
10945 SAVEI32(PL_lex_brackets);
10946 if (PL_lex_brackets > 100)
10947 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
10948 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
10949 SAVEI32(PL_lex_allbrackets);
10950 PL_lex_allbrackets = 0;
10951 SAVEI8(PL_lex_fakeeof);
10952 PL_lex_fakeeof = (U8)fakeeof;
10953 if(yyparse(gramtype) && !PL_parser->error_count)
10954 qerror(Perl_mess(aTHX_ "Parse error"));
10957 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
10959 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
10963 SAVEVPTR(PL_eval_root);
10964 PL_eval_root = NULL;
10965 parse_recdescent(gramtype, fakeeof);
10971 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
10973 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
10976 if (flags & ~PARSE_OPTIONAL)
10977 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
10978 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
10979 if (!exprop && !(flags & PARSE_OPTIONAL)) {
10980 if (!PL_parser->error_count)
10981 qerror(Perl_mess(aTHX_ "Parse error"));
10982 exprop = newOP(OP_NULL, 0);
10988 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
10990 Parse a Perl arithmetic expression. This may contain operators of precedence
10991 down to the bit shift operators. The expression must be followed (and thus
10992 terminated) either by a comparison or lower-precedence operator or by
10993 something that would normally terminate an expression such as semicolon.
10994 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
10995 otherwise it is mandatory. It is up to the caller to ensure that the
10996 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
10997 the source of the code to be parsed and the lexical context for the
11000 The op tree representing the expression is returned. If an optional
11001 expression is absent, a null pointer is returned, otherwise the pointer
11004 If an error occurs in parsing or compilation, in most cases a valid op
11005 tree is returned anyway. The error is reflected in the parser state,
11006 normally resulting in a single exception at the top level of parsing
11007 which covers all the compilation errors that occurred. Some compilation
11008 errors, however, will throw an exception immediately.
11014 Perl_parse_arithexpr(pTHX_ U32 flags)
11016 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11020 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11022 Parse a Perl term expression. This may contain operators of precedence
11023 down to the assignment operators. The expression must be followed (and thus
11024 terminated) either by a comma or lower-precedence operator or by
11025 something that would normally terminate an expression such as semicolon.
11026 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11027 otherwise it is mandatory. It is up to the caller to ensure that the
11028 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11029 the source of the code to be parsed and the lexical context for the
11032 The op tree representing the expression is returned. If an optional
11033 expression is absent, a null pointer is returned, otherwise the pointer
11036 If an error occurs in parsing or compilation, in most cases a valid op
11037 tree is returned anyway. The error is reflected in the parser state,
11038 normally resulting in a single exception at the top level of parsing
11039 which covers all the compilation errors that occurred. Some compilation
11040 errors, however, will throw an exception immediately.
11046 Perl_parse_termexpr(pTHX_ U32 flags)
11048 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11052 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11054 Parse a Perl list expression. This may contain operators of precedence
11055 down to the comma operator. The expression must be followed (and thus
11056 terminated) either by a low-precedence logic operator such as C<or> or by
11057 something that would normally terminate an expression such as semicolon.
11058 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11059 otherwise it is mandatory. It is up to the caller to ensure that the
11060 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11061 the source of the code to be parsed and the lexical context for the
11064 The op tree representing the expression is returned. If an optional
11065 expression is absent, a null pointer is returned, otherwise the pointer
11068 If an error occurs in parsing or compilation, in most cases a valid op
11069 tree is returned anyway. The error is reflected in the parser state,
11070 normally resulting in a single exception at the top level of parsing
11071 which covers all the compilation errors that occurred. Some compilation
11072 errors, however, will throw an exception immediately.
11078 Perl_parse_listexpr(pTHX_ U32 flags)
11080 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11084 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11086 Parse a single complete Perl expression. This allows the full
11087 expression grammar, including the lowest-precedence operators such
11088 as C<or>. The expression must be followed (and thus terminated) by a
11089 token that an expression would normally be terminated by: end-of-file,
11090 closing bracketing punctuation, semicolon, or one of the keywords that
11091 signals a postfix expression-statement modifier. If I<flags> includes
11092 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11093 mandatory. It is up to the caller to ensure that the dynamic parser
11094 state (L</PL_parser> et al) is correctly set to reflect the source of
11095 the code to be parsed and the lexical context for the expression.
11097 The op tree representing the expression is returned. If an optional
11098 expression is absent, a null pointer is returned, otherwise the pointer
11101 If an error occurs in parsing or compilation, in most cases a valid op
11102 tree is returned anyway. The error is reflected in the parser state,
11103 normally resulting in a single exception at the top level of parsing
11104 which covers all the compilation errors that occurred. Some compilation
11105 errors, however, will throw an exception immediately.
11111 Perl_parse_fullexpr(pTHX_ U32 flags)
11113 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11117 =for apidoc Amx|OP *|parse_block|U32 flags
11119 Parse a single complete Perl code block. This consists of an opening
11120 brace, a sequence of statements, and a closing brace. The block
11121 constitutes a lexical scope, so C<my> variables and various compile-time
11122 effects can be contained within it. It is up to the caller to ensure
11123 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11124 reflect the source of the code to be parsed and the lexical context for
11127 The op tree representing the code block is returned. This is always a
11128 real op, never a null pointer. It will normally be a C<lineseq> list,
11129 including C<nextstate> or equivalent ops. No ops to construct any kind
11130 of runtime scope are included by virtue of it being a block.
11132 If an error occurs in parsing or compilation, in most cases a valid op
11133 tree (most likely null) is returned anyway. The error is reflected in
11134 the parser state, normally resulting in a single exception at the top
11135 level of parsing which covers all the compilation errors that occurred.
11136 Some compilation errors, however, will throw an exception immediately.
11138 The I<flags> parameter is reserved for future use, and must always
11145 Perl_parse_block(pTHX_ U32 flags)
11148 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11149 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11153 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11155 Parse a single unadorned Perl statement. This may be a normal imperative
11156 statement or a declaration that has compile-time effect. It does not
11157 include any label or other affixture. It is up to the caller to ensure
11158 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11159 reflect the source of the code to be parsed and the lexical context for
11162 The op tree representing the statement is returned. This may be a
11163 null pointer if the statement is null, for example if it was actually
11164 a subroutine definition (which has compile-time side effects). If not
11165 null, it will be ops directly implementing the statement, suitable to
11166 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11167 equivalent op (except for those embedded in a scope contained entirely
11168 within the statement).
11170 If an error occurs in parsing or compilation, in most cases a valid op
11171 tree (most likely null) is returned anyway. The error is reflected in
11172 the parser state, normally resulting in a single exception at the top
11173 level of parsing which covers all the compilation errors that occurred.
11174 Some compilation errors, however, will throw an exception immediately.
11176 The I<flags> parameter is reserved for future use, and must always
11183 Perl_parse_barestmt(pTHX_ U32 flags)
11186 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11187 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11191 =for apidoc Amx|SV *|parse_label|U32 flags
11193 Parse a single label, possibly optional, of the type that may prefix a
11194 Perl statement. It is up to the caller to ensure that the dynamic parser
11195 state (L</PL_parser> et al) is correctly set to reflect the source of
11196 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11197 label is optional, otherwise it is mandatory.
11199 The name of the label is returned in the form of a fresh scalar. If an
11200 optional label is absent, a null pointer is returned.
11202 If an error occurs in parsing, which can only occur if the label is
11203 mandatory, a valid label is returned anyway. The error is reflected in
11204 the parser state, normally resulting in a single exception at the top
11205 level of parsing which covers all the compilation errors that occurred.
11211 Perl_parse_label(pTHX_ U32 flags)
11213 if (flags & ~PARSE_OPTIONAL)
11214 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11215 if (PL_lex_state == LEX_KNOWNEXT) {
11216 PL_parser->yychar = yylex();
11217 if (PL_parser->yychar == LABEL) {
11218 char * const lpv = pl_yylval.pval;
11219 STRLEN llen = strlen(lpv);
11220 PL_parser->yychar = YYEMPTY;
11221 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11228 STRLEN wlen, bufptr_pos;
11231 if (!isIDFIRST_lazy_if(s, UTF))
11233 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11234 if (word_takes_any_delimeter(s, wlen))
11236 bufptr_pos = s - SvPVX(PL_linestr);
11238 lex_read_space(LEX_KEEP_PREVIOUS);
11240 s = SvPVX(PL_linestr) + bufptr_pos;
11241 if (t[0] == ':' && t[1] != ':') {
11242 PL_oldoldbufptr = PL_oldbufptr;
11245 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11249 if (flags & PARSE_OPTIONAL) {
11252 qerror(Perl_mess(aTHX_ "Parse error"));
11253 return newSVpvs("x");
11260 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11262 Parse a single complete Perl statement. This may be a normal imperative
11263 statement or a declaration that has compile-time effect, and may include
11264 optional labels. It is up to the caller to ensure that the dynamic
11265 parser state (L</PL_parser> et al) is correctly set to reflect the source
11266 of the code to be parsed and the lexical context for the statement.
11268 The op tree representing the statement is returned. This may be a
11269 null pointer if the statement is null, for example if it was actually
11270 a subroutine definition (which has compile-time side effects). If not
11271 null, it will be the result of a L</newSTATEOP> call, normally including
11272 a C<nextstate> or equivalent op.
11274 If an error occurs in parsing or compilation, in most cases a valid op
11275 tree (most likely null) is returned anyway. The error is reflected in
11276 the parser state, normally resulting in a single exception at the top
11277 level of parsing which covers all the compilation errors that occurred.
11278 Some compilation errors, however, will throw an exception immediately.
11280 The I<flags> parameter is reserved for future use, and must always
11287 Perl_parse_fullstmt(pTHX_ U32 flags)
11290 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11291 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11295 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11297 Parse a sequence of zero or more Perl statements. These may be normal
11298 imperative statements, including optional labels, or declarations
11299 that have compile-time effect, or any mixture thereof. The statement
11300 sequence ends when a closing brace or end-of-file is encountered in a
11301 place where a new statement could have validly started. It is up to
11302 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11303 is correctly set to reflect the source of the code to be parsed and the
11304 lexical context for the statements.
11306 The op tree representing the statement sequence is returned. This may
11307 be a null pointer if the statements were all null, for example if there
11308 were no statements or if there were only subroutine definitions (which
11309 have compile-time side effects). If not null, it will be a C<lineseq>
11310 list, normally including C<nextstate> or equivalent ops.
11312 If an error occurs in parsing or compilation, in most cases a valid op
11313 tree is returned anyway. The error is reflected in the parser state,
11314 normally resulting in a single exception at the top level of parsing
11315 which covers all the compilation errors that occurred. Some compilation
11316 errors, however, will throw an exception immediately.
11318 The I<flags> parameter is reserved for future use, and must always
11325 Perl_parse_stmtseq(pTHX_ U32 flags)
11330 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11331 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11332 c = lex_peek_unichar(0);
11333 if (c != -1 && c != /*{*/'}')
11334 qerror(Perl_mess(aTHX_ "Parse error"));
11338 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11340 S_lex_token_boundary(pTHX)
11342 PL_oldoldbufptr = PL_oldbufptr;
11343 PL_oldbufptr = PL_bufptr;
11346 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11348 S_parse_opt_lexvar(pTHX)
11353 lex_token_boundary();
11354 sigil = lex_read_unichar(0);
11355 if (lex_peek_unichar(0) == '#') {
11356 qerror(Perl_mess(aTHX_ "Parse error"));
11360 c = lex_peek_unichar(0);
11361 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11364 d = PL_tokenbuf + 1;
11365 PL_tokenbuf[0] = (char)sigil;
11366 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11368 if (d == PL_tokenbuf+1)
11371 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11372 OPf_MOD | (OPpLVAL_INTRO<<8));
11373 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11378 Perl_parse_subsignature(pTHX)
11381 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11382 OP *initops = NULL;
11384 c = lex_peek_unichar(0);
11385 while (c != /*(*/')') {
11389 if (prev_type == 2)
11390 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11391 var = parse_opt_lexvar();
11393 newBINOP(OP_AELEM, 0,
11394 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11396 newSVOP(OP_CONST, 0, newSViv(pos))) :
11399 c = lex_peek_unichar(0);
11401 lex_token_boundary();
11402 lex_read_unichar(0);
11404 c = lex_peek_unichar(0);
11405 if (c == ',' || c == /*(*/')') {
11407 qerror(Perl_mess(aTHX_ "Optional parameter "
11408 "lacks default expression"));
11410 OP *defexpr = parse_termexpr(0);
11411 if (defexpr->op_type == OP_UNDEF &&
11412 !(defexpr->op_flags & OPf_KIDS)) {
11417 scalar(newUNOP(OP_RV2AV, 0,
11418 newGVOP(OP_GV, 0, PL_defgv))),
11419 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11421 newCONDOP(0, ifop, expr, defexpr) :
11422 newLOGOP(OP_OR, 0, ifop, defexpr);
11427 if (prev_type == 1)
11428 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11429 "follows optional parameter"));
11431 min_arity = pos + 1;
11433 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11435 initops = op_append_list(OP_LINESEQ, initops,
11436 newSTATEOP(0, NULL, expr));
11442 if (prev_type == 2)
11443 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11444 var = parse_opt_lexvar();
11446 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11447 newBINOP(OP_BIT_AND, 0,
11448 scalar(newUNOP(OP_RV2AV, 0,
11449 newGVOP(OP_GV, 0, PL_defgv))),
11450 newSVOP(OP_CONST, 0, newSViv(1))),
11451 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11452 newSVOP(OP_CONST, 0,
11453 newSVpvs("Odd name/value argument "
11454 "for subroutine"))));
11455 if (pos != min_arity)
11456 chkop = newLOGOP(OP_AND, 0,
11458 scalar(newUNOP(OP_RV2AV, 0,
11459 newGVOP(OP_GV, 0, PL_defgv))),
11460 newSVOP(OP_CONST, 0, newSViv(pos))),
11462 initops = op_append_list(OP_LINESEQ,
11463 newSTATEOP(0, NULL, chkop),
11468 op_prepend_elem(OP_ASLICE,
11469 newOP(OP_PUSHMARK, 0),
11470 newLISTOP(OP_ASLICE, 0,
11472 newSVOP(OP_CONST, 0, newSViv(pos)),
11473 newUNOP(OP_AV2ARYLEN, 0,
11474 ref(newUNOP(OP_RV2AV, 0,
11475 newGVOP(OP_GV, 0, PL_defgv)),
11477 ref(newUNOP(OP_RV2AV, 0,
11478 newGVOP(OP_GV, 0, PL_defgv)),
11480 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11481 initops = op_append_list(OP_LINESEQ, initops,
11482 newSTATEOP(0, NULL,
11483 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11490 qerror(Perl_mess(aTHX_ "Parse error"));
11494 c = lex_peek_unichar(0);
11496 case /*(*/')': break;
11499 lex_token_boundary();
11500 lex_read_unichar(0);
11502 c = lex_peek_unichar(0);
11503 } while (c == ',');
11509 if (min_arity != 0) {
11510 initops = op_append_list(OP_LINESEQ,
11511 newSTATEOP(0, NULL,
11514 scalar(newUNOP(OP_RV2AV, 0,
11515 newGVOP(OP_GV, 0, PL_defgv))),
11516 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11517 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11518 newSVOP(OP_CONST, 0,
11519 newSVpvs("Too few arguments for subroutine"))))),
11522 if (max_arity != -1) {
11523 initops = op_append_list(OP_LINESEQ,
11524 newSTATEOP(0, NULL,
11527 scalar(newUNOP(OP_RV2AV, 0,
11528 newGVOP(OP_GV, 0, PL_defgv))),
11529 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11530 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11531 newSVOP(OP_CONST, 0,
11532 newSVpvs("Too many arguments for subroutine"))))),
11540 * c-indentation-style: bsd
11541 * c-basic-offset: 4
11542 * indent-tabs-mode: nil
11545 * ex: set ts=8 sts=4 sw=4 et: