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)
1993 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
1998 PERL_ARGS_ASSERT_FORCE_WORD;
2000 start = skipspace(start);
2002 if (isIDFIRST_lazy_if(s,UTF) ||
2003 (allow_pack && *s == ':') )
2005 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2006 if (check_keyword) {
2007 char *s2 = PL_tokenbuf;
2008 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2010 if (keyword(s2, len, 0))
2013 if (token == METHOD) {
2018 PL_expect = XOPERATOR;
2021 NEXTVAL_NEXTTOKE.opval
2022 = (OP*)newSVOP(OP_CONST,0,
2023 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2024 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2032 * Called when the lexer wants $foo *foo &foo etc, but the program
2033 * text only contains the "foo" portion. The first argument is a pointer
2034 * to the "foo", and the second argument is the type symbol to prefix.
2035 * Forces the next token to be a "WORD".
2036 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2040 S_force_ident(pTHX_ const char *s, int kind)
2042 PERL_ARGS_ASSERT_FORCE_IDENT;
2045 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2046 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2047 UTF ? SVf_UTF8 : 0));
2048 NEXTVAL_NEXTTOKE.opval = o;
2051 o->op_private = OPpCONST_ENTERED;
2052 /* XXX see note in pp_entereval() for why we forgo typo
2053 warnings if the symbol must be introduced in an eval.
2055 gv_fetchpvn_flags(s, len,
2056 (PL_in_eval ? GV_ADDMULTI
2057 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2058 kind == '$' ? SVt_PV :
2059 kind == '@' ? SVt_PVAV :
2060 kind == '%' ? SVt_PVHV :
2068 S_force_ident_maybe_lex(pTHX_ char pit)
2070 NEXTVAL_NEXTTOKE.ival = pit;
2075 Perl_str_to_version(pTHX_ SV *sv)
2080 const char *start = SvPV_const(sv,len);
2081 const char * const end = start + len;
2082 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2084 PERL_ARGS_ASSERT_STR_TO_VERSION;
2086 while (start < end) {
2090 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2095 retval += ((NV)n)/nshift;
2104 * Forces the next token to be a version number.
2105 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2106 * and if "guessing" is TRUE, then no new token is created (and the caller
2107 * must use an alternative parsing method).
2111 S_force_version(pTHX_ char *s, int guessing)
2116 PERL_ARGS_ASSERT_FORCE_VERSION;
2124 while (isDIGIT(*d) || *d == '_' || *d == '.')
2126 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2128 s = scan_num(s, &pl_yylval);
2129 version = pl_yylval.opval;
2130 ver = cSVOPx(version)->op_sv;
2131 if (SvPOK(ver) && !SvNIOK(ver)) {
2132 SvUPGRADE(ver, SVt_PVNV);
2133 SvNV_set(ver, str_to_version(ver));
2134 SvNOK_on(ver); /* hint that it is a version */
2137 else if (guessing) {
2142 /* NOTE: The parser sees the package name and the VERSION swapped */
2143 NEXTVAL_NEXTTOKE.opval = version;
2150 * S_force_strict_version
2151 * Forces the next token to be a version number using strict syntax rules.
2155 S_force_strict_version(pTHX_ char *s)
2158 const char *errstr = NULL;
2160 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2162 while (isSPACE(*s)) /* leading whitespace */
2165 if (is_STRICT_VERSION(s,&errstr)) {
2167 s = (char *)scan_version(s, ver, 0);
2168 version = newSVOP(OP_CONST, 0, ver);
2170 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2171 (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2175 yyerror(errstr); /* version required */
2179 /* NOTE: The parser sees the package name and the VERSION swapped */
2180 NEXTVAL_NEXTTOKE.opval = version;
2188 * Tokenize a quoted string passed in as an SV. It finds the next
2189 * chunk, up to end of string or a backslash. It may make a new
2190 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2195 S_tokeq(pTHX_ SV *sv)
2202 PERL_ARGS_ASSERT_TOKEQ;
2206 assert (!SvIsCOW(sv));
2207 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2211 /* This is relying on the SV being "well formed" with a trailing '\0' */
2212 while (s < send && !(*s == '\\' && s[1] == '\\'))
2217 if ( PL_hints & HINT_NEW_STRING ) {
2218 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2219 SVs_TEMP | SvUTF8(sv));
2223 if (s + 1 < send && (s[1] == '\\'))
2224 s++; /* all that, just for this */
2229 SvCUR_set(sv, d - SvPVX_const(sv));
2231 if ( PL_hints & HINT_NEW_STRING )
2232 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2237 * Now come three functions related to double-quote context,
2238 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2239 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2240 * interact with PL_lex_state, and create fake ( ... ) argument lists
2241 * to handle functions and concatenation.
2245 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2250 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2252 * Pattern matching will set PL_lex_op to the pattern-matching op to
2253 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2255 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2257 * Everything else becomes a FUNC.
2259 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2260 * had an OP_CONST or OP_READLINE). This just sets us up for a
2261 * call to S_sublex_push().
2265 S_sublex_start(pTHX)
2267 const I32 op_type = pl_yylval.ival;
2269 if (op_type == OP_NULL) {
2270 pl_yylval.opval = PL_lex_op;
2274 if (op_type == OP_CONST) {
2275 SV *sv = tokeq(PL_lex_stuff);
2277 if (SvTYPE(sv) == SVt_PVIV) {
2278 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2280 const char * const p = SvPV_const(sv, len);
2281 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2285 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2286 PL_lex_stuff = NULL;
2290 PL_sublex_info.super_state = PL_lex_state;
2291 PL_sublex_info.sub_inwhat = (U16)op_type;
2292 PL_sublex_info.sub_op = PL_lex_op;
2293 PL_lex_state = LEX_INTERPPUSH;
2297 pl_yylval.opval = PL_lex_op;
2307 * Create a new scope to save the lexing state. The scope will be
2308 * ended in S_sublex_done. Returns a '(', starting the function arguments
2309 * to the uc, lc, etc. found before.
2310 * Sets PL_lex_state to LEX_INTERPCONCAT.
2317 const bool is_heredoc = PL_multi_close == '<';
2320 PL_lex_state = PL_sublex_info.super_state;
2321 SAVEI8(PL_lex_dojoin);
2322 SAVEI32(PL_lex_brackets);
2323 SAVEI32(PL_lex_allbrackets);
2324 SAVEI32(PL_lex_formbrack);
2325 SAVEI8(PL_lex_fakeeof);
2326 SAVEI32(PL_lex_casemods);
2327 SAVEI32(PL_lex_starts);
2328 SAVEI8(PL_lex_state);
2329 SAVESPTR(PL_lex_repl);
2330 SAVEVPTR(PL_lex_inpat);
2331 SAVEI16(PL_lex_inwhat);
2334 SAVECOPLINE(PL_curcop);
2335 SAVEI32(PL_multi_end);
2336 SAVEI32(PL_parser->herelines);
2337 PL_parser->herelines = 0;
2339 SAVEI8(PL_multi_close);
2340 SAVEPPTR(PL_bufptr);
2341 SAVEPPTR(PL_bufend);
2342 SAVEPPTR(PL_oldbufptr);
2343 SAVEPPTR(PL_oldoldbufptr);
2344 SAVEPPTR(PL_last_lop);
2345 SAVEPPTR(PL_last_uni);
2346 SAVEPPTR(PL_linestart);
2347 SAVESPTR(PL_linestr);
2348 SAVEGENERICPV(PL_lex_brackstack);
2349 SAVEGENERICPV(PL_lex_casestack);
2350 SAVEGENERICPV(PL_parser->lex_shared);
2351 SAVEBOOL(PL_parser->lex_re_reparsing);
2352 SAVEI32(PL_copline);
2354 /* The here-doc parser needs to be able to peek into outer lexing
2355 scopes to find the body of the here-doc. So we put PL_linestr and
2356 PL_bufptr into lex_shared, to ‘share’ those values.
2358 PL_parser->lex_shared->ls_linestr = PL_linestr;
2359 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2361 PL_linestr = PL_lex_stuff;
2362 PL_lex_repl = PL_sublex_info.repl;
2363 PL_lex_stuff = NULL;
2364 PL_sublex_info.repl = NULL;
2366 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2367 = SvPVX(PL_linestr);
2368 PL_bufend += SvCUR(PL_linestr);
2369 PL_last_lop = PL_last_uni = NULL;
2370 SAVEFREESV(PL_linestr);
2371 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2373 PL_lex_dojoin = FALSE;
2374 PL_lex_brackets = PL_lex_formbrack = 0;
2375 PL_lex_allbrackets = 0;
2376 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2377 Newx(PL_lex_brackstack, 120, char);
2378 Newx(PL_lex_casestack, 12, char);
2379 PL_lex_casemods = 0;
2380 *PL_lex_casestack = '\0';
2382 PL_lex_state = LEX_INTERPCONCAT;
2384 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2385 PL_copline = NOLINE;
2387 Newxz(shared, 1, LEXSHARED);
2388 shared->ls_prev = PL_parser->lex_shared;
2389 PL_parser->lex_shared = shared;
2391 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2392 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2393 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2394 PL_lex_inpat = PL_sublex_info.sub_op;
2396 PL_lex_inpat = NULL;
2398 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2399 PL_in_eval &= ~EVAL_RE_REPARSING;
2406 * Restores lexer state after a S_sublex_push.
2412 if (!PL_lex_starts++) {
2413 SV * const sv = newSVpvs("");
2414 if (SvUTF8(PL_linestr))
2416 PL_expect = XOPERATOR;
2417 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2421 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2422 PL_lex_state = LEX_INTERPCASEMOD;
2426 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2427 assert(PL_lex_inwhat != OP_TRANSR);
2429 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2430 PL_linestr = PL_lex_repl;
2432 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2433 PL_bufend += SvCUR(PL_linestr);
2434 PL_last_lop = PL_last_uni = NULL;
2435 PL_lex_dojoin = FALSE;
2436 PL_lex_brackets = 0;
2437 PL_lex_allbrackets = 0;
2438 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2439 PL_lex_casemods = 0;
2440 *PL_lex_casestack = '\0';
2442 if (SvEVALED(PL_lex_repl)) {
2443 PL_lex_state = LEX_INTERPNORMAL;
2445 /* we don't clear PL_lex_repl here, so that we can check later
2446 whether this is an evalled subst; that means we rely on the
2447 logic to ensure sublex_done() is called again only via the
2448 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2451 PL_lex_state = LEX_INTERPCONCAT;
2454 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2455 CopLINE(PL_curcop) +=
2456 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2457 + PL_parser->herelines;
2458 PL_parser->herelines = 0;
2463 const line_t l = CopLINE(PL_curcop);
2465 if (PL_multi_close == '<')
2466 PL_parser->herelines += l - PL_multi_end;
2467 PL_bufend = SvPVX(PL_linestr);
2468 PL_bufend += SvCUR(PL_linestr);
2469 PL_expect = XOPERATOR;
2470 PL_sublex_info.sub_inwhat = 0;
2475 PERL_STATIC_INLINE SV*
2476 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2478 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2479 * interior, hence to the "}". Finds what the name resolves to, returning
2480 * an SV* containing it; NULL if no valid one found */
2482 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2489 const U8* first_bad_char_loc;
2490 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2492 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2494 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2496 &first_bad_char_loc))
2498 /* If warnings are on, this will print a more detailed analysis of what
2499 * is wrong than the error message below */
2500 utf8n_to_uvchr(first_bad_char_loc,
2501 e - ((char *) first_bad_char_loc),
2504 /* We deliberately don't try to print the malformed character, which
2505 * might not print very well; it also may be just the first of many
2506 * malformations, so don't print what comes after it */
2507 yyerror(Perl_form(aTHX_
2508 "Malformed UTF-8 character immediately after '%.*s'",
2509 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2513 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2514 /* include the <}> */
2515 e - backslash_ptr + 1);
2517 SvREFCNT_dec_NN(res);
2521 /* See if the charnames handler is the Perl core's, and if so, we can skip
2522 * the validation needed for a user-supplied one, as Perl's does its own
2524 table = GvHV(PL_hintgv); /* ^H */
2525 cvp = hv_fetchs(table, "charnames", FALSE);
2526 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2527 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2529 const char * const name = HvNAME(stash);
2530 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2531 && strEQ(name, "_charnames")) {
2536 /* Here, it isn't Perl's charname handler. We can't rely on a
2537 * user-supplied handler to validate the input name. For non-ut8 input,
2538 * look to see that the first character is legal. Then loop through the
2539 * rest checking that each is a continuation */
2541 /* This code makes the reasonable assumption that the only Latin1-range
2542 * characters that begin a character name alias are alphabetic, otherwise
2543 * would have to create a isCHARNAME_BEGIN macro */
2546 if (! isALPHAU(*s)) {
2551 if (! isCHARNAME_CONT(*s)) {
2554 if (*s == ' ' && *(s-1) == ' ') {
2557 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2558 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2559 "NO-BREAK SPACE in a charnames "
2560 "alias definition is deprecated");
2566 /* Similarly for utf8. For invariants can check directly; for other
2567 * Latin1, can calculate their code point and check; otherwise use a
2569 if (UTF8_IS_INVARIANT(*s)) {
2570 if (! isALPHAU(*s)) {
2574 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2575 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2581 if (! PL_utf8_charname_begin) {
2582 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2583 PL_utf8_charname_begin = _core_swash_init("utf8",
2584 "_Perl_Charname_Begin",
2586 1, 0, NULL, &flags);
2588 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2595 if (UTF8_IS_INVARIANT(*s)) {
2596 if (! isCHARNAME_CONT(*s)) {
2599 if (*s == ' ' && *(s-1) == ' ') {
2604 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2605 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2609 if (*s == *NBSP_UTF8
2610 && *(s+1) == *(NBSP_UTF8+1)
2611 && ckWARN_d(WARN_DEPRECATED))
2613 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2614 "NO-BREAK SPACE in a charnames "
2615 "alias definition is deprecated");
2620 if (! PL_utf8_charname_continue) {
2621 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2622 PL_utf8_charname_continue = _core_swash_init("utf8",
2623 "_Perl_Charname_Continue",
2625 1, 0, NULL, &flags);
2627 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2634 if (*(s-1) == ' ') {
2637 "charnames alias definitions may not contain trailing "
2638 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2639 (int)(s - backslash_ptr + 1), backslash_ptr,
2640 (int)(e - s + 1), s + 1
2642 UTF ? SVf_UTF8 : 0);
2646 if (SvUTF8(res)) { /* Don't accept malformed input */
2647 const U8* first_bad_char_loc;
2649 const char* const str = SvPV_const(res, len);
2650 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2651 /* If warnings are on, this will print a more detailed analysis of
2652 * what is wrong than the error message below */
2653 utf8n_to_uvchr(first_bad_char_loc,
2654 (char *) first_bad_char_loc - str,
2657 /* We deliberately don't try to print the malformed character,
2658 * which might not print very well; it also may be just the first
2659 * of many malformations, so don't print what comes after it */
2662 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2663 (int) (e - backslash_ptr + 1), backslash_ptr,
2664 (int) ((char *) first_bad_char_loc - str), str
2675 /* The final %.*s makes sure that should the trailing NUL be missing
2676 * that this print won't run off the end of the string */
2679 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2680 (int)(s - backslash_ptr + 1), backslash_ptr,
2681 (int)(e - s + 1), s + 1
2683 UTF ? SVf_UTF8 : 0);
2690 "charnames alias definitions may not contain a sequence of "
2691 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2692 (int)(s - backslash_ptr + 1), backslash_ptr,
2693 (int)(e - s + 1), s + 1
2695 UTF ? SVf_UTF8 : 0);
2702 Extracts the next constant part of a pattern, double-quoted string,
2703 or transliteration. This is terrifying code.
2705 For example, in parsing the double-quoted string "ab\x63$d", it would
2706 stop at the '$' and return an OP_CONST containing 'abc'.
2708 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2709 processing a pattern (PL_lex_inpat is true), a transliteration
2710 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2712 Returns a pointer to the character scanned up to. If this is
2713 advanced from the start pointer supplied (i.e. if anything was
2714 successfully parsed), will leave an OP_CONST for the substring scanned
2715 in pl_yylval. Caller must intuit reason for not parsing further
2716 by looking at the next characters herself.
2720 \N{FOO} => \N{U+hex_for_character_FOO}
2721 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2724 all other \-char, including \N and \N{ apart from \N{ABC}
2727 @ and $ where it appears to be a var, but not for $ as tail anchor
2732 In transliterations:
2733 characters are VERY literal, except for - not at the start or end
2734 of the string, which indicates a range. If the range is in bytes,
2735 scan_const expands the range to the full set of intermediate
2736 characters. If the range is in utf8, the hyphen is replaced with
2737 a certain range mark which will be handled by pmtrans() in op.c.
2739 In double-quoted strings:
2741 double-quoted style: \r and \n
2742 constants: \x31, etc.
2743 deprecated backrefs: \1 (in substitution replacements)
2744 case and quoting: \U \Q \E
2747 scan_const does *not* construct ops to handle interpolated strings.
2748 It stops processing as soon as it finds an embedded $ or @ variable
2749 and leaves it to the caller to work out what's going on.
2751 embedded arrays (whether in pattern or not) could be:
2752 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2754 $ in double-quoted strings must be the symbol of an embedded scalar.
2756 $ in pattern could be $foo or could be tail anchor. Assumption:
2757 it's a tail anchor if $ is the last thing in the string, or if it's
2758 followed by one of "()| \r\n\t"
2760 \1 (backreferences) are turned into $1 in substitutions
2762 The structure of the code is
2763 while (there's a character to process) {
2764 handle transliteration ranges
2765 skip regexp comments /(?#comment)/ and codes /(?{code})/
2766 skip #-initiated comments in //x patterns
2767 check for embedded arrays
2768 check for embedded scalars
2770 deprecate \1 in substitution replacements
2771 handle string-changing backslashes \l \U \Q \E, etc.
2772 switch (what was escaped) {
2773 handle \- in a transliteration (becomes a literal -)
2774 if a pattern and not \N{, go treat as regular character
2775 handle \132 (octal characters)
2776 handle \x15 and \x{1234} (hex characters)
2777 handle \N{name} (named characters, also \N{3,5} in a pattern)
2778 handle \cV (control characters)
2779 handle printf-style backslashes (\f, \r, \n, etc)
2782 } (end if backslash)
2783 handle regular character
2784 } (end while character to read)
2789 S_scan_const(pTHX_ char *start)
2791 char *send = PL_bufend; /* end of the constant */
2792 SV *sv = newSV(send - start); /* sv for the constant. See note below
2794 char *s = start; /* start of the constant */
2795 char *d = SvPVX(sv); /* destination for copies */
2796 bool dorange = FALSE; /* are we in a translit range? */
2797 bool didrange = FALSE; /* did we just finish a range? */
2798 bool in_charclass = FALSE; /* within /[...]/ */
2799 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2800 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2801 UTF8? But, this can show as true
2802 when the source isn't utf8, as for
2803 example when it is entirely composed
2805 SV *res; /* result from charnames */
2807 /* Note on sizing: The scanned constant is placed into sv, which is
2808 * initialized by newSV() assuming one byte of output for every byte of
2809 * input. This routine expects newSV() to allocate an extra byte for a
2810 * trailing NUL, which this routine will append if it gets to the end of
2811 * the input. There may be more bytes of input than output (eg., \N{LATIN
2812 * CAPITAL LETTER A}), or more output than input if the constant ends up
2813 * recoded to utf8, but each time a construct is found that might increase
2814 * the needed size, SvGROW() is called. Its size parameter each time is
2815 * based on the best guess estimate at the time, namely the length used so
2816 * far, plus the length the current construct will occupy, plus room for
2817 * the trailing NUL, plus one byte for every input byte still unscanned */
2819 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2822 UV literal_endpoint = 0;
2823 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2826 PERL_ARGS_ASSERT_SCAN_CONST;
2828 assert(PL_lex_inwhat != OP_TRANSR);
2829 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2830 /* If we are doing a trans and we know we want UTF8 set expectation */
2831 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2832 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2835 /* Protect sv from errors and fatal warnings. */
2836 ENTER_with_name("scan_const");
2839 while (s < send || dorange) {
2841 /* get transliterations out of the way (they're most literal) */
2842 if (PL_lex_inwhat == OP_TRANS) {
2843 /* expand a range A-Z to the full set of characters. AIE! */
2845 I32 i; /* current expanded character */
2846 I32 min; /* first character in range */
2847 I32 max; /* last character in range */
2858 char * const c = (char*)utf8_hop((U8*)d, -1);
2862 *c = (char) ILLEGAL_UTF8_BYTE;
2863 /* mark the range as done, and continue */
2869 i = d - SvPVX_const(sv); /* remember current offset */
2872 SvLEN(sv) + ((has_utf8)
2873 ? (512 - UTF_CONTINUATION_MARK
2876 /* How many two-byte within 0..255: 128 in UTF-8,
2877 * 96 in UTF-8-mod. */
2879 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2881 d = SvPVX(sv) + i; /* refresh d after realloc */
2885 for (j = 0; j <= 1; j++) {
2886 char * const c = (char*)utf8_hop((U8*)d, -1);
2887 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2893 max = (U8)0xff; /* only to \xff */
2894 uvmax = uv; /* \x{100} to uvmax */
2896 d = c; /* eat endpoint chars */
2901 d -= 2; /* eat the first char and the - */
2902 min = (U8)*d; /* first char in range */
2903 max = (U8)d[1]; /* last char in range */
2910 "Invalid range \"%c-%c\" in transliteration operator",
2911 (char)min, (char)max);
2915 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2916 * any subsets of these ranges into individual characters */
2917 if (literal_endpoint == 2 &&
2918 ((isLOWER_A(min) && isLOWER_A(max)) ||
2919 (isUPPER_A(min) && isUPPER_A(max))))
2921 for (i = min; i <= max; i++) {
2928 for (i = min; i <= max; i++)
2931 append_utf8_from_native_byte(i, &d);
2939 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2941 *d++ = (char) ILLEGAL_UTF8_BYTE;
2943 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2947 /* mark the range as done, and continue */
2951 literal_endpoint = 0;
2956 /* range begins (ignore - as first or last char) */
2957 else if (*s == '-' && s+1 < send && s != start) {
2959 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2966 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2976 literal_endpoint = 0;
2977 native_range = TRUE;
2982 /* if we get here, we're not doing a transliteration */
2984 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2987 while (s1 >= start && *s1-- == '\\')
2990 in_charclass = TRUE;
2993 else if (*s == ']' && PL_lex_inpat && in_charclass) {
2996 while (s1 >= start && *s1-- == '\\')
2999 in_charclass = FALSE;
3002 /* skip for regexp comments /(?#comment)/, except for the last
3003 * char, which will be done separately.
3004 * Stop on (?{..}) and friends */
3006 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3008 while (s+1 < send && *s != ')')
3011 else if (!PL_lex_casemods &&
3012 ( s[2] == '{' /* This should match regcomp.c */
3013 || (s[2] == '?' && s[3] == '{')))
3019 /* likewise skip #-initiated comments in //x patterns */
3020 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3021 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3022 while (s+1 < send && *s != '\n')
3026 /* no further processing of single-quoted regex */
3027 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3028 goto default_action;
3030 /* check for embedded arrays
3031 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3033 else if (*s == '@' && s[1]) {
3034 if (isWORDCHAR_lazy_if(s+1,UTF))
3036 if (strchr(":'{$", s[1]))
3038 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3039 break; /* in regexp, neither @+ nor @- are interpolated */
3042 /* check for embedded scalars. only stop if we're sure it's a
3045 else if (*s == '$') {
3046 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3048 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3050 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3051 "Possible unintended interpolation of $\\ in regex");
3053 break; /* in regexp, $ might be tail anchor */
3057 /* End of else if chain - OP_TRANS rejoin rest */
3060 if (*s == '\\' && s+1 < send) {
3061 char* e; /* Can be used for ending '}', etc. */
3065 /* warn on \1 - \9 in substitution replacements, but note that \11
3066 * is an octal; and \19 is \1 followed by '9' */
3067 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3068 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3070 /* diag_listed_as: \%d better written as $%d */
3071 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3076 /* string-change backslash escapes */
3077 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3081 /* In a pattern, process \N, but skip any other backslash escapes.
3082 * This is because we don't want to translate an escape sequence
3083 * into a meta symbol and have the regex compiler use the meta
3084 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3085 * in spite of this, we do have to process \N here while the proper
3086 * charnames handler is in scope. See bugs #56444 and #62056.
3087 * There is a complication because \N in a pattern may also stand
3088 * for 'match a non-nl', and not mean a charname, in which case its
3089 * processing should be deferred to the regex compiler. To be a
3090 * charname it must be followed immediately by a '{', and not look
3091 * like \N followed by a curly quantifier, i.e., not something like
3092 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3094 else if (PL_lex_inpat
3097 || regcurly(s + 1)))
3100 goto default_action;
3105 /* quoted - in transliterations */
3107 if (PL_lex_inwhat == OP_TRANS) {
3114 if ((isALPHANUMERIC(*s)))
3115 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3116 "Unrecognized escape \\%c passed through",
3118 /* default action is to copy the quoted character */
3119 goto default_action;
3122 /* eg. \132 indicates the octal constant 0132 */
3123 case '0': case '1': case '2': case '3':
3124 case '4': case '5': case '6': case '7':
3126 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3128 uv = grok_oct(s, &len, &flags, NULL);
3130 if (len < 3 && s < send && isDIGIT(*s)
3131 && ckWARN(WARN_MISC))
3133 Perl_warner(aTHX_ packWARN(WARN_MISC),
3134 "%s", form_short_octal_warning(s, len));
3137 goto NUM_ESCAPE_INSERT;
3139 /* eg. \o{24} indicates the octal constant \024 */
3144 bool valid = grok_bslash_o(&s, &uv, &error,
3145 TRUE, /* Output warning */
3146 FALSE, /* Not strict */
3147 TRUE, /* Output warnings for
3154 goto NUM_ESCAPE_INSERT;
3157 /* eg. \x24 indicates the hex constant 0x24 */
3162 bool valid = grok_bslash_x(&s, &uv, &error,
3163 TRUE, /* Output warning */
3164 FALSE, /* Not strict */
3165 TRUE, /* Output warnings for
3175 /* Insert oct or hex escaped character. There will always be
3176 * enough room in sv since such escapes will be longer than any
3177 * UTF-8 sequence they can end up as, except if they force us
3178 * to recode the rest of the string into utf8 */
3180 /* Here uv is the ordinal of the next character being added */
3181 if (!UVCHR_IS_INVARIANT(uv)) {
3182 if (!has_utf8 && uv > 255) {
3183 /* Might need to recode whatever we have accumulated so
3184 * far if it contains any chars variant in utf8 or
3187 SvCUR_set(sv, d - SvPVX_const(sv));
3190 /* See Note on sizing above. */
3191 sv_utf8_upgrade_flags_grow(sv,
3192 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3193 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3194 d = SvPVX(sv) + SvCUR(sv);
3199 d = (char*)uvchr_to_utf8((U8*)d, uv);
3200 if (PL_lex_inwhat == OP_TRANS &&
3201 PL_sublex_info.sub_op) {
3202 PL_sublex_info.sub_op->op_private |=
3203 (PL_lex_repl ? OPpTRANS_FROM_UTF
3207 if (uv > 255 && !dorange)
3208 native_range = FALSE;
3221 /* In a non-pattern \N must be a named character, like \N{LATIN
3222 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3223 * mean to match a non-newline. For non-patterns, named
3224 * characters are converted to their string equivalents. In
3225 * patterns, named characters are not converted to their
3226 * ultimate forms for the same reasons that other escapes
3227 * aren't. Instead, they are converted to the \N{U+...} form
3228 * to get the value from the charnames that is in effect right
3229 * now, while preserving the fact that it was a named character
3230 * so that the regex compiler knows this */
3232 /* The structure of this section of code (besides checking for
3233 * errors and upgrading to utf8) is:
3234 * Further disambiguate between the two meanings of \N, and if
3235 * not a charname, go process it elsewhere
3236 * If of form \N{U+...}, pass it through if a pattern;
3237 * otherwise convert to utf8
3238 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3239 * pattern; otherwise convert to utf8 */
3241 /* Here, s points to the 'N'; the test below is guaranteed to
3242 * succeed if we are being called on a pattern as we already
3243 * know from a test above that the next character is a '{'.
3244 * On a non-pattern \N must mean 'named sequence, which
3245 * requires braces */
3248 yyerror("Missing braces on \\N{}");
3253 /* If there is no matching '}', it is an error. */
3254 if (! (e = strchr(s, '}'))) {
3255 if (! PL_lex_inpat) {
3256 yyerror("Missing right brace on \\N{}");
3258 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3263 /* Here it looks like a named character */
3265 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3266 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3267 | PERL_SCAN_DISALLOW_PREFIX;
3270 /* For \N{U+...}, the '...' is a unicode value even on
3271 * EBCDIC machines */
3272 s += 2; /* Skip to next char after the 'U+' */
3274 uv = grok_hex(s, &len, &flags, NULL);
3275 if (len == 0 || len != (STRLEN)(e - s)) {
3276 yyerror("Invalid hexadecimal number in \\N{U+...}");
3283 /* On non-EBCDIC platforms, pass through to the regex
3284 * compiler unchanged. The reason we evaluated the
3285 * number above is to make sure there wasn't a syntax
3286 * error. But on EBCDIC we convert to native so
3287 * downstream code can continue to assume it's native
3289 s -= 5; /* Include the '\N{U+' */
3291 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3294 (unsigned int) UNI_TO_NATIVE(uv));
3296 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3300 else { /* Not a pattern: convert the hex to string */
3302 /* If destination is not in utf8, unconditionally
3303 * recode it to be so. This is because \N{} implies
3304 * Unicode semantics, and scalars have to be in utf8
3305 * to guarantee those semantics */
3307 SvCUR_set(sv, d - SvPVX_const(sv));
3310 /* See Note on sizing above. */
3311 sv_utf8_upgrade_flags_grow(
3313 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3314 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3315 d = SvPVX(sv) + SvCUR(sv);
3319 /* Add the (Unicode) code point to the output. */
3320 if (UNI_IS_INVARIANT(uv)) {
3321 *d++ = (char) LATIN1_TO_NATIVE(uv);
3324 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3328 else /* Here is \N{NAME} but not \N{U+...}. */
3329 if ((res = get_and_check_backslash_N_name(s, e)))
3332 const char *str = SvPV_const(res, len);
3335 if (! len) { /* The name resolved to an empty string */
3336 Copy("\\N{}", d, 4, char);
3340 /* In order to not lose information for the regex
3341 * compiler, pass the result in the specially made
3342 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3343 * the code points in hex of each character
3344 * returned by charnames */
3346 const char *str_end = str + len;
3347 const STRLEN off = d - SvPVX_const(sv);
3349 if (! SvUTF8(res)) {
3350 /* For the non-UTF-8 case, we can determine the
3351 * exact length needed without having to parse
3352 * through the string. Each character takes up
3353 * 2 hex digits plus either a trailing dot or
3355 d = off + SvGROW(sv, off
3357 + 6 /* For the "\N{U+", and
3359 + (STRLEN)(send - e));
3360 Copy("\\N{U+", d, 5, char);
3362 while (str < str_end) {
3365 my_snprintf(hex_string,
3367 "%02X.", (U8) *str);
3368 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3369 Copy(hex_string, d, 3, char);
3373 d--; /* We will overwrite below the final
3374 dot with a right brace */
3377 STRLEN char_length; /* cur char's byte length */
3379 /* and the number of bytes after this is
3380 * translated into hex digits */
3381 STRLEN output_length;
3383 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3384 * for max('U+', '.'); and 1 for NUL */
3385 char hex_string[2 * UTF8_MAXBYTES + 5];
3387 /* Get the first character of the result. */
3388 U32 uv = utf8n_to_uvchr((U8 *) str,
3392 /* Convert first code point to hex, including
3393 * the boiler plate before it. */
3395 my_snprintf(hex_string, sizeof(hex_string),
3399 /* Make sure there is enough space to hold it */
3400 d = off + SvGROW(sv, off
3402 + (STRLEN)(send - e)
3403 + 2); /* '}' + NUL */
3405 Copy(hex_string, d, output_length, char);
3408 /* For each subsequent character, append dot and
3409 * its ordinal in hex */
3410 while ((str += char_length) < str_end) {
3411 const STRLEN off = d - SvPVX_const(sv);
3412 U32 uv = utf8n_to_uvchr((U8 *) str,
3417 my_snprintf(hex_string,
3422 d = off + SvGROW(sv, off
3424 + (STRLEN)(send - e)
3425 + 2); /* '}' + NUL */
3426 Copy(hex_string, d, output_length, char);
3431 *d++ = '}'; /* Done. Add the trailing brace */
3434 else { /* Here, not in a pattern. Convert the name to a
3437 /* If destination is not in utf8, unconditionally
3438 * recode it to be so. This is because \N{} implies
3439 * Unicode semantics, and scalars have to be in utf8
3440 * to guarantee those semantics */
3442 SvCUR_set(sv, d - SvPVX_const(sv));
3445 /* See Note on sizing above. */
3446 sv_utf8_upgrade_flags_grow(sv,
3447 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3448 len + (STRLEN)(send - s) + 1);
3449 d = SvPVX(sv) + SvCUR(sv);
3451 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3453 /* See Note on sizing above. (NOTE: SvCUR() is not
3454 * set correctly here). */
3455 const STRLEN off = d - SvPVX_const(sv);
3456 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3458 if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
3459 sv_utf8_upgrade(res);
3460 str = SvPV_const(res, len);
3462 Copy(str, d, len, char);
3468 } /* End \N{NAME} */
3471 native_range = FALSE; /* \N{} is defined to be Unicode */
3473 s = e + 1; /* Point to just after the '}' */
3476 /* \c is a control character */
3480 *d++ = grok_bslash_c(*s++, 1);
3483 yyerror("Missing control char name in \\c");
3487 /* printf-style backslashes, formfeeds, newlines, etc */
3513 } /* end if (backslash) */
3520 /* If we started with encoded form, or already know we want it,
3521 then encode the next character */
3522 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3526 /* One might think that it is wasted effort in the case of the
3527 * source being utf8 (this_utf8 == TRUE) to take the next character
3528 * in the source, convert it to an unsigned value, and then convert
3529 * it back again. But the source has not been validated here. The
3530 * routine that does the conversion checks for errors like
3533 const UV nextuv = (this_utf8)
3534 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3536 const STRLEN need = UNISKIP(nextuv);
3538 SvCUR_set(sv, d - SvPVX_const(sv));
3541 /* See Note on sizing above. */
3542 sv_utf8_upgrade_flags_grow(sv,
3543 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3544 need + (STRLEN)(send - s) + 1);
3545 d = SvPVX(sv) + SvCUR(sv);
3547 } else if (need > len) {
3548 /* encoded value larger than old, may need extra space (NOTE:
3549 * SvCUR() is not set correctly here). See Note on sizing
3551 const STRLEN off = d - SvPVX_const(sv);
3552 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3556 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3558 if (uv > 255 && !dorange)
3559 native_range = FALSE;
3565 } /* while loop to process each character */
3567 /* terminate the string and set up the sv */
3569 SvCUR_set(sv, d - SvPVX_const(sv));
3570 if (SvCUR(sv) >= SvLEN(sv))
3571 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3572 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3575 if (PL_encoding && !has_utf8) {
3576 sv_recode_to_utf8(sv, PL_encoding);
3582 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3583 PL_sublex_info.sub_op->op_private |=
3584 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3588 /* shrink the sv if we allocated more than we used */
3589 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3590 SvPV_shrink_to_cur(sv);
3593 /* return the substring (via pl_yylval) only if we parsed anything */
3596 for (; s2 < s; s2++) {
3598 COPLINE_INC_WITH_HERELINES;
3600 SvREFCNT_inc_simple_void_NN(sv);
3601 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3602 && ! PL_parser->lex_re_reparsing)
3604 const char *const key = PL_lex_inpat ? "qr" : "q";
3605 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3609 if (PL_lex_inwhat == OP_TRANS) {
3612 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3615 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3623 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3626 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3628 LEAVE_with_name("scan_const");
3633 * Returns TRUE if there's more to the expression (e.g., a subscript),
3636 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3638 * ->[ and ->{ return TRUE
3639 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3640 * { and [ outside a pattern are always subscripts, so return TRUE
3641 * if we're outside a pattern and it's not { or [, then return FALSE
3642 * if we're in a pattern and the first char is a {
3643 * {4,5} (any digits around the comma) returns FALSE
3644 * if we're in a pattern and the first char is a [
3646 * [SOMETHING] has a funky algorithm to decide whether it's a
3647 * character class or not. It has to deal with things like
3648 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3649 * anything else returns TRUE
3652 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3655 S_intuit_more(pTHX_ char *s)
3657 PERL_ARGS_ASSERT_INTUIT_MORE;
3659 if (PL_lex_brackets)
3661 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3663 if (*s == '-' && s[1] == '>'
3664 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3665 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3666 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3668 if (*s != '{' && *s != '[')
3673 /* In a pattern, so maybe we have {n,m}. */
3681 /* On the other hand, maybe we have a character class */
3684 if (*s == ']' || *s == '^')
3687 /* this is terrifying, and it works */
3690 const char * const send = strchr(s,']');
3691 unsigned char un_char, last_un_char;
3692 char tmpbuf[sizeof PL_tokenbuf * 4];
3694 if (!send) /* has to be an expression */
3696 weight = 2; /* let's weigh the evidence */
3700 else if (isDIGIT(*s)) {
3702 if (isDIGIT(s[1]) && s[2] == ']')
3708 Zero(seen,256,char);
3710 for (; s < send; s++) {
3711 last_un_char = un_char;
3712 un_char = (unsigned char)*s;
3717 weight -= seen[un_char] * 10;
3718 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3720 char *tmp = PL_bufend;
3721 PL_bufend = (char*)send;
3722 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3724 len = (int)strlen(tmpbuf);
3725 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3726 UTF ? SVf_UTF8 : 0, SVt_PV))
3731 else if (*s == '$' && s[1] &&
3732 strchr("[#!%*<>()-=",s[1])) {
3733 if (/*{*/ strchr("])} =",s[2]))
3742 if (strchr("wds]",s[1]))
3744 else if (seen[(U8)'\''] || seen[(U8)'"'])
3746 else if (strchr("rnftbxcav",s[1]))
3748 else if (isDIGIT(s[1])) {
3750 while (s[1] && isDIGIT(s[1]))
3760 if (strchr("aA01! ",last_un_char))
3762 if (strchr("zZ79~",s[1]))
3764 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3765 weight -= 5; /* cope with negative subscript */
3768 if (!isWORDCHAR(last_un_char)
3769 && !(last_un_char == '$' || last_un_char == '@'
3770 || last_un_char == '&')
3771 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3776 if (keyword(tmpbuf, d - tmpbuf, 0))
3779 if (un_char == last_un_char + 1)
3781 weight -= seen[un_char];
3786 if (weight >= 0) /* probably a character class */
3796 * Does all the checking to disambiguate
3798 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3799 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3801 * First argument is the stuff after the first token, e.g. "bar".
3803 * Not a method if foo is a filehandle.
3804 * Not a method if foo is a subroutine prototyped to take a filehandle.
3805 * Not a method if it's really "Foo $bar"
3806 * Method if it's "foo $bar"
3807 * Not a method if it's really "print foo $bar"
3808 * Method if it's really "foo package::" (interpreted as package->foo)
3809 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3810 * Not a method if bar is a filehandle or package, but is quoted with
3815 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3817 char *s = start + (*start == '$');
3818 char tmpbuf[sizeof PL_tokenbuf];
3821 /* Mustn't actually add anything to a symbol table.
3822 But also don't want to "initialise" any placeholder
3823 constants that might already be there into full
3824 blown PVGVs with attached PVCV. */
3826 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3828 PERL_ARGS_ASSERT_INTUIT_METHOD;
3830 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3832 if (cv && SvPOK(cv)) {
3833 const char *proto = CvPROTO(cv);
3835 while (*proto && (isSPACE(*proto) || *proto == ';'))
3842 if (*start == '$') {
3843 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3844 isUPPER(*PL_tokenbuf))
3849 return *s == '(' ? FUNCMETH : METHOD;
3852 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3853 /* start is the beginning of the possible filehandle/object,
3854 * and s is the end of it
3855 * tmpbuf is a copy of it (but with single quotes as double colons)
3858 if (!keyword(tmpbuf, len, 0)) {
3859 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3864 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3865 if (indirgv && GvCVu(indirgv))
3867 /* filehandle or package name makes it a method */
3868 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3870 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3871 return 0; /* no assumptions -- "=>" quotes bareword */
3873 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3874 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3875 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3879 return *s == '(' ? FUNCMETH : METHOD;
3885 /* Encoded script support. filter_add() effectively inserts a
3886 * 'pre-processing' function into the current source input stream.
3887 * Note that the filter function only applies to the current source file
3888 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3890 * The datasv parameter (which may be NULL) can be used to pass
3891 * private data to this instance of the filter. The filter function
3892 * can recover the SV using the FILTER_DATA macro and use it to
3893 * store private buffers and state information.
3895 * The supplied datasv parameter is upgraded to a PVIO type
3896 * and the IoDIRP/IoANY field is used to store the function pointer,
3897 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3898 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3899 * private use must be set using malloc'd pointers.
3903 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3911 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3912 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3914 if (!PL_rsfp_filters)
3915 PL_rsfp_filters = newAV();
3918 SvUPGRADE(datasv, SVt_PVIO);
3919 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3920 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3921 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3922 FPTR2DPTR(void *, IoANY(datasv)),
3923 SvPV_nolen(datasv)));
3924 av_unshift(PL_rsfp_filters, 1);
3925 av_store(PL_rsfp_filters, 0, datasv) ;
3927 !PL_parser->filtered
3928 && PL_parser->lex_flags & LEX_EVALBYTES
3929 && PL_bufptr < PL_bufend
3931 const char *s = PL_bufptr;
3932 while (s < PL_bufend) {
3934 SV *linestr = PL_parser->linestr;
3935 char *buf = SvPVX(linestr);
3936 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3937 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3938 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3939 STRLEN const linestart_pos = PL_parser->linestart - buf;
3940 STRLEN const last_uni_pos =
3941 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3942 STRLEN const last_lop_pos =
3943 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3944 av_push(PL_rsfp_filters, linestr);
3945 PL_parser->linestr =
3946 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3947 buf = SvPVX(PL_parser->linestr);
3948 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3949 PL_parser->bufptr = buf + bufptr_pos;
3950 PL_parser->oldbufptr = buf + oldbufptr_pos;
3951 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3952 PL_parser->linestart = buf + linestart_pos;
3953 if (PL_parser->last_uni)
3954 PL_parser->last_uni = buf + last_uni_pos;
3955 if (PL_parser->last_lop)
3956 PL_parser->last_lop = buf + last_lop_pos;
3957 SvLEN(linestr) = SvCUR(linestr);
3958 SvCUR(linestr) = s-SvPVX(linestr);
3959 PL_parser->filtered = 1;
3969 /* Delete most recently added instance of this filter function. */
3971 Perl_filter_del(pTHX_ filter_t funcp)
3975 PERL_ARGS_ASSERT_FILTER_DEL;
3978 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3979 FPTR2DPTR(void*, funcp)));
3981 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3983 /* if filter is on top of stack (usual case) just pop it off */
3984 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3985 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3986 sv_free(av_pop(PL_rsfp_filters));
3990 /* we need to search for the correct entry and clear it */
3991 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3995 /* Invoke the idxth filter function for the current rsfp. */
3996 /* maxlen 0 = read one text line */
3998 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4002 /* This API is bad. It should have been using unsigned int for maxlen.
4003 Not sure if we want to change the API, but if not we should sanity
4004 check the value here. */
4005 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4007 PERL_ARGS_ASSERT_FILTER_READ;
4009 if (!PL_parser || !PL_rsfp_filters)
4011 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4012 /* Provide a default input filter to make life easy. */
4013 /* Note that we append to the line. This is handy. */
4014 DEBUG_P(PerlIO_printf(Perl_debug_log,
4015 "filter_read %d: from rsfp\n", idx));
4016 if (correct_length) {
4019 const int old_len = SvCUR(buf_sv);
4021 /* ensure buf_sv is large enough */
4022 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4023 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4024 correct_length)) <= 0) {
4025 if (PerlIO_error(PL_rsfp))
4026 return -1; /* error */
4028 return 0 ; /* end of file */
4030 SvCUR_set(buf_sv, old_len + len) ;
4031 SvPVX(buf_sv)[old_len + len] = '\0';
4034 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4035 if (PerlIO_error(PL_rsfp))
4036 return -1; /* error */
4038 return 0 ; /* end of file */
4041 return SvCUR(buf_sv);
4043 /* Skip this filter slot if filter has been deleted */
4044 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4045 DEBUG_P(PerlIO_printf(Perl_debug_log,
4046 "filter_read %d: skipped (filter deleted)\n",
4048 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4050 if (SvTYPE(datasv) != SVt_PVIO) {
4051 if (correct_length) {
4053 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4054 if (!remainder) return 0; /* eof */
4055 if (correct_length > remainder) correct_length = remainder;
4056 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4057 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4060 const char *s = SvEND(datasv);
4061 const char *send = SvPVX(datasv) + SvLEN(datasv);
4069 if (s == send) return 0; /* eof */
4070 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4071 SvCUR_set(datasv, s-SvPVX(datasv));
4073 return SvCUR(buf_sv);
4075 /* Get function pointer hidden within datasv */
4076 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4077 DEBUG_P(PerlIO_printf(Perl_debug_log,
4078 "filter_read %d: via function %p (%s)\n",
4079 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4080 /* Call function. The function is expected to */
4081 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4082 /* Return: <0:error, =0:eof, >0:not eof */
4083 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4087 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4089 PERL_ARGS_ASSERT_FILTER_GETS;
4091 #ifdef PERL_CR_FILTER
4092 if (!PL_rsfp_filters) {
4093 filter_add(S_cr_textfilter,NULL);
4096 if (PL_rsfp_filters) {
4098 SvCUR_set(sv, 0); /* start with empty line */
4099 if (FILTER_READ(0, sv, 0) > 0)
4100 return ( SvPVX(sv) ) ;
4105 return (sv_gets(sv, PL_rsfp, append));
4109 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4113 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4115 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4119 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4120 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4122 return GvHV(gv); /* Foo:: */
4125 /* use constant CLASS => 'MyClass' */
4126 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4127 if (gv && GvCV(gv)) {
4128 SV * const sv = cv_const_sv(GvCV(gv));
4130 return gv_stashsv(sv, 0);
4133 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4138 S_tokenize_use(pTHX_ int is_use, char *s) {
4139 PERL_ARGS_ASSERT_TOKENIZE_USE;
4141 if (PL_expect != XSTATE)
4142 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4143 is_use ? "use" : "no"));
4146 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4147 s = force_version(s, TRUE);
4148 if (*s == ';' || *s == '}'
4149 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4150 NEXTVAL_NEXTTOKE.opval = NULL;
4153 else if (*s == 'v') {
4154 s = force_word(s,WORD,FALSE,TRUE);
4155 s = force_version(s, FALSE);
4159 s = force_word(s,WORD,FALSE,TRUE);
4160 s = force_version(s, FALSE);
4162 pl_yylval.ival = is_use;
4166 static const char* const exp_name[] =
4167 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4168 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4173 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4175 S_word_takes_any_delimeter(char *p, STRLEN len)
4177 return (len == 1 && strchr("msyq", p[0])) ||
4179 (p[0] == 't' && p[1] == 'r') ||
4180 (p[0] == 'q' && strchr("qwxr", p[1]))));
4184 S_check_scalar_slice(pTHX_ char *s)
4187 while (*s == ' ' || *s == '\t') s++;
4188 if (*s == 'q' && s[1] == 'w'
4189 && !isWORDCHAR_lazy_if(s+2,UTF))
4191 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4192 s += UTF ? UTF8SKIP(s) : 1;
4193 if (*s == '}' || *s == ']')
4194 pl_yylval.ival = OPpSLICEWARNING;
4200 Works out what to call the token just pulled out of the input
4201 stream. The yacc parser takes care of taking the ops we return and
4202 stitching them into a tree.
4205 The type of the next token
4208 Switch based on the current state:
4209 - if we already built the token before, use it
4210 - if we have a case modifier in a string, deal with that
4211 - handle other cases of interpolation inside a string
4212 - scan the next line if we are inside a format
4213 In the normal state switch on the next character:
4215 if alphabetic, go to key lookup
4216 unrecoginized character - croak
4217 - 0/4/26: handle end-of-line or EOF
4218 - cases for whitespace
4219 - \n and #: handle comments and line numbers
4220 - various operators, brackets and sigils
4223 - 'v': vstrings (or go to key lookup)
4224 - 'x' repetition operator (or go to key lookup)
4225 - other ASCII alphanumerics (key lookup begins here):
4228 scan built-in keyword (but do nothing with it yet)
4229 check for statement label
4230 check for lexical subs
4231 goto just_a_word if there is one
4232 see whether built-in keyword is overridden
4233 switch on keyword number:
4234 - default: just_a_word:
4235 not a built-in keyword; handle bareword lookup
4236 disambiguate between method and sub call
4237 fall back to bareword
4238 - cases for built-in keywords
4246 char *s = PL_bufptr;
4250 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4254 /* orig_keyword, gvp, and gv are initialized here because
4255 * jump to the label just_a_word_zero can bypass their
4256 * initialization later. */
4257 I32 orig_keyword = 0;
4262 SV* tmp = newSVpvs("");
4263 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4264 (IV)CopLINE(PL_curcop),
4265 lex_state_names[PL_lex_state],
4266 exp_name[PL_expect],
4267 pv_display(tmp, s, strlen(s), 0, 60));
4271 switch (PL_lex_state) {
4273 case LEX_INTERPNORMAL:
4276 /* when we've already built the next token, just pull it out of the queue */
4279 pl_yylval = PL_nextval[PL_nexttoke];
4281 PL_lex_state = PL_lex_defer;
4282 PL_lex_defer = LEX_NORMAL;
4286 next_type = PL_nexttype[PL_nexttoke];
4287 if (next_type & (7<<24)) {
4288 if (next_type & (1<<24)) {
4289 if (PL_lex_brackets > 100)
4290 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4291 PL_lex_brackstack[PL_lex_brackets++] =
4292 (char) ((next_type >> 16) & 0xff);
4294 if (next_type & (2<<24))
4295 PL_lex_allbrackets++;
4296 if (next_type & (4<<24))
4297 PL_lex_allbrackets--;
4298 next_type &= 0xffff;
4300 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4303 /* interpolated case modifiers like \L \U, including \Q and \E.
4304 when we get here, PL_bufptr is at the \
4306 case LEX_INTERPCASEMOD:
4308 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4310 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4311 PL_bufptr, PL_bufend, *PL_bufptr);
4313 /* handle \E or end of string */
4314 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4316 if (PL_lex_casemods) {
4317 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4318 PL_lex_casestack[PL_lex_casemods] = '\0';
4320 if (PL_bufptr != PL_bufend
4321 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4322 || oldmod == 'F')) {
4324 PL_lex_state = LEX_INTERPCONCAT;
4326 PL_lex_allbrackets--;
4329 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4330 /* Got an unpaired \E */
4331 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4332 "Useless use of \\E");
4334 if (PL_bufptr != PL_bufend)
4336 PL_lex_state = LEX_INTERPCONCAT;
4340 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4341 "### Saw case modifier\n"); });
4343 if (s[1] == '\\' && s[2] == 'E') {
4345 PL_lex_state = LEX_INTERPCONCAT;
4350 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4351 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4352 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4353 (strchr(PL_lex_casestack, 'L')
4354 || strchr(PL_lex_casestack, 'U')
4355 || strchr(PL_lex_casestack, 'F'))) {
4356 PL_lex_casestack[--PL_lex_casemods] = '\0';
4357 PL_lex_allbrackets--;
4360 if (PL_lex_casemods > 10)
4361 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4362 PL_lex_casestack[PL_lex_casemods++] = *s;
4363 PL_lex_casestack[PL_lex_casemods] = '\0';
4364 PL_lex_state = LEX_INTERPCONCAT;
4365 NEXTVAL_NEXTTOKE.ival = 0;
4366 force_next((2<<24)|'(');
4368 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4370 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4372 NEXTVAL_NEXTTOKE.ival = OP_LC;
4374 NEXTVAL_NEXTTOKE.ival = OP_UC;
4376 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4378 NEXTVAL_NEXTTOKE.ival = OP_FC;
4380 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4384 if (PL_lex_starts) {
4387 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4388 if (PL_lex_casemods == 1 && PL_lex_inpat)
4391 AopNOASSIGN(OP_CONCAT);
4397 case LEX_INTERPPUSH:
4398 return REPORT(sublex_push());
4400 case LEX_INTERPSTART:
4401 if (PL_bufptr == PL_bufend)
4402 return REPORT(sublex_done());
4403 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4404 "### Interpolated variable\n"); });
4406 /* for /@a/, we leave the joining for the regex engine to do
4407 * (unless we're within \Q etc) */
4408 PL_lex_dojoin = (*PL_bufptr == '@'
4409 && (!PL_lex_inpat || PL_lex_casemods));
4410 PL_lex_state = LEX_INTERPNORMAL;
4411 if (PL_lex_dojoin) {
4412 NEXTVAL_NEXTTOKE.ival = 0;
4414 force_ident("\"", '$');
4415 NEXTVAL_NEXTTOKE.ival = 0;
4417 NEXTVAL_NEXTTOKE.ival = 0;
4418 force_next((2<<24)|'(');
4419 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4422 /* Convert (?{...}) and friends to 'do {...}' */
4423 if (PL_lex_inpat && *PL_bufptr == '(') {
4424 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4426 if (*PL_bufptr != '{')
4428 PL_expect = XTERMBLOCK;
4432 if (PL_lex_starts++) {
4434 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4435 if (!PL_lex_casemods && PL_lex_inpat)
4438 AopNOASSIGN(OP_CONCAT);
4442 case LEX_INTERPENDMAYBE:
4443 if (intuit_more(PL_bufptr)) {
4444 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4450 if (PL_lex_dojoin) {
4451 const U8 dojoin_was = PL_lex_dojoin;
4452 PL_lex_dojoin = FALSE;
4453 PL_lex_state = LEX_INTERPCONCAT;
4454 PL_lex_allbrackets--;
4455 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4457 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4458 && SvEVALED(PL_lex_repl))
4460 if (PL_bufptr != PL_bufend)
4461 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4464 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4465 re_eval_str. If the here-doc body’s length equals the previous
4466 value of re_eval_start, re_eval_start will now be null. So
4467 check re_eval_str as well. */
4468 if (PL_parser->lex_shared->re_eval_start
4469 || PL_parser->lex_shared->re_eval_str) {
4471 if (*PL_bufptr != ')')
4472 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4474 /* having compiled a (?{..}) expression, return the original
4475 * text too, as a const */
4476 if (PL_parser->lex_shared->re_eval_str) {
4477 sv = PL_parser->lex_shared->re_eval_str;
4478 PL_parser->lex_shared->re_eval_str = NULL;
4480 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4481 SvPV_shrink_to_cur(sv);
4483 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4484 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4485 NEXTVAL_NEXTTOKE.opval =
4486 (OP*)newSVOP(OP_CONST, 0,
4489 PL_parser->lex_shared->re_eval_start = NULL;
4495 case LEX_INTERPCONCAT:
4497 if (PL_lex_brackets)
4498 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4499 (long) PL_lex_brackets);
4501 if (PL_bufptr == PL_bufend)
4502 return REPORT(sublex_done());
4504 /* m'foo' still needs to be parsed for possible (?{...}) */
4505 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4506 SV *sv = newSVsv(PL_linestr);
4508 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4512 s = scan_const(PL_bufptr);
4514 PL_lex_state = LEX_INTERPCASEMOD;
4516 PL_lex_state = LEX_INTERPSTART;
4519 if (s != PL_bufptr) {
4520 NEXTVAL_NEXTTOKE = pl_yylval;
4523 if (PL_lex_starts++) {
4524 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4525 if (!PL_lex_casemods && PL_lex_inpat)
4528 AopNOASSIGN(OP_CONCAT);
4538 s = scan_formline(PL_bufptr);
4539 if (!PL_lex_formbrack)
4548 /* We really do *not* want PL_linestr ever becoming a COW. */
4549 assert (!SvIsCOW(PL_linestr));
4551 PL_oldoldbufptr = PL_oldbufptr;
4553 PL_parser->saw_infix_sigil = 0;
4558 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4561 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4562 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4564 SVs_TEMP | SVf_UTF8),
4565 10, UNI_DISPLAY_ISPRINT)
4566 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4567 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4568 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4569 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4573 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4574 UTF8fARG(UTF, (s - d), d),
4579 goto fake_eof; /* emulate EOF on ^D or ^Z */
4581 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4584 if (PL_lex_brackets &&
4585 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4586 yyerror((const char *)
4588 ? "Format not terminated"
4589 : "Missing right curly or square bracket"));
4591 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4592 "### Tokener got EOF\n");
4596 if (s++ < PL_bufend)
4597 goto retry; /* ignore stray nulls */
4600 if (!PL_in_eval && !PL_preambled) {
4601 PL_preambled = TRUE;
4603 /* Generate a string of Perl code to load the debugger.
4604 * If PERL5DB is set, it will return the contents of that,
4605 * otherwise a compile-time require of perl5db.pl. */
4607 const char * const pdb = PerlEnv_getenv("PERL5DB");
4610 sv_setpv(PL_linestr, pdb);
4611 sv_catpvs(PL_linestr,";");
4613 SETERRNO(0,SS_NORMAL);
4614 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4616 PL_parser->preambling = CopLINE(PL_curcop);
4618 sv_setpvs(PL_linestr,"");
4619 if (PL_preambleav) {
4620 SV **svp = AvARRAY(PL_preambleav);
4621 SV **const end = svp + AvFILLp(PL_preambleav);
4623 sv_catsv(PL_linestr, *svp);
4625 sv_catpvs(PL_linestr, ";");
4627 sv_free(MUTABLE_SV(PL_preambleav));
4628 PL_preambleav = NULL;
4631 sv_catpvs(PL_linestr,
4632 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4633 if (PL_minus_n || PL_minus_p) {
4634 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4636 sv_catpvs(PL_linestr,"chomp;");
4639 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4640 || *PL_splitstr == '"')
4641 && strchr(PL_splitstr + 1, *PL_splitstr))
4642 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4644 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4645 bytes can be used as quoting characters. :-) */
4646 const char *splits = PL_splitstr;
4647 sv_catpvs(PL_linestr, "our @F=split(q\0");
4650 if (*splits == '\\')
4651 sv_catpvn(PL_linestr, splits, 1);
4652 sv_catpvn(PL_linestr, splits, 1);
4653 } while (*splits++);
4654 /* This loop will embed the trailing NUL of
4655 PL_linestr as the last thing it does before
4657 sv_catpvs(PL_linestr, ");");
4661 sv_catpvs(PL_linestr,"our @F=split(' ');");
4664 sv_catpvs(PL_linestr, "\n");
4665 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4666 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4667 PL_last_lop = PL_last_uni = NULL;
4668 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4669 update_debugger_info(PL_linestr, NULL, 0);
4674 bof = PL_rsfp ? TRUE : FALSE;
4677 fake_eof = LEX_FAKE_EOF;
4679 PL_bufptr = PL_bufend;
4680 COPLINE_INC_WITH_HERELINES;
4681 if (!lex_next_chunk(fake_eof)) {
4682 CopLINE_dec(PL_curcop);
4684 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4686 CopLINE_dec(PL_curcop);
4688 /* If it looks like the start of a BOM or raw UTF-16,
4689 * check if it in fact is. */
4690 if (bof && PL_rsfp &&
4692 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4695 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4696 bof = (offset == (Off_t)SvCUR(PL_linestr));
4697 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4698 /* offset may include swallowed CR */
4700 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4703 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4704 s = swallow_bom((U8*)s);
4707 if (PL_parser->in_pod) {
4708 /* Incest with pod. */
4709 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4710 sv_setpvs(PL_linestr, "");
4711 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4712 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4713 PL_last_lop = PL_last_uni = NULL;
4714 PL_parser->in_pod = 0;
4717 if (PL_rsfp || PL_parser->filtered)
4719 } while (PL_parser->in_pod);
4720 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4721 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4722 PL_last_lop = PL_last_uni = NULL;
4723 if (CopLINE(PL_curcop) == 1) {
4724 while (s < PL_bufend && isSPACE(*s))
4726 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4730 if (*s == '#' && *(s+1) == '!')
4732 #ifdef ALTERNATE_SHEBANG
4734 static char const as[] = ALTERNATE_SHEBANG;
4735 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4736 d = s + (sizeof(as) - 1);
4738 #endif /* ALTERNATE_SHEBANG */
4747 while (*d && !isSPACE(*d))
4751 #ifdef ARG_ZERO_IS_SCRIPT
4752 if (ipathend > ipath) {
4754 * HP-UX (at least) sets argv[0] to the script name,
4755 * which makes $^X incorrect. And Digital UNIX and Linux,
4756 * at least, set argv[0] to the basename of the Perl
4757 * interpreter. So, having found "#!", we'll set it right.
4759 SV* copfilesv = CopFILESV(PL_curcop);
4762 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4764 assert(SvPOK(x) || SvGMAGICAL(x));
4765 if (sv_eq(x, copfilesv)) {
4766 sv_setpvn(x, ipath, ipathend - ipath);
4772 const char *bstart = SvPV_const(copfilesv, blen);
4773 const char * const lstart = SvPV_const(x, llen);
4775 bstart += blen - llen;
4776 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4777 sv_setpvn(x, ipath, ipathend - ipath);
4784 /* Anything to do if no copfilesv? */
4786 TAINT_NOT; /* $^X is always tainted, but that's OK */
4788 #endif /* ARG_ZERO_IS_SCRIPT */
4793 d = instr(s,"perl -");
4795 d = instr(s,"perl");
4797 /* avoid getting into infinite loops when shebang
4798 * line contains "Perl" rather than "perl" */
4800 for (d = ipathend-4; d >= ipath; --d) {
4801 if (isALPHA_FOLD_EQ(*d, 'p')
4802 && !ibcmp(d, "perl", 4))
4812 #ifdef ALTERNATE_SHEBANG
4814 * If the ALTERNATE_SHEBANG on this system starts with a
4815 * character that can be part of a Perl expression, then if
4816 * we see it but not "perl", we're probably looking at the
4817 * start of Perl code, not a request to hand off to some
4818 * other interpreter. Similarly, if "perl" is there, but
4819 * not in the first 'word' of the line, we assume the line
4820 * contains the start of the Perl program.
4822 if (d && *s != '#') {
4823 const char *c = ipath;
4824 while (*c && !strchr("; \t\r\n\f\v#", *c))
4827 d = NULL; /* "perl" not in first word; ignore */
4829 *s = '#'; /* Don't try to parse shebang line */
4831 #endif /* ALTERNATE_SHEBANG */
4836 !instr(s,"indir") &&
4837 instr(PL_origargv[0],"perl"))
4844 while (s < PL_bufend && isSPACE(*s))
4846 if (s < PL_bufend) {
4847 Newx(newargv,PL_origargc+3,char*);
4849 while (s < PL_bufend && !isSPACE(*s))
4852 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4855 newargv = PL_origargv;
4858 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4860 Perl_croak(aTHX_ "Can't exec %s", ipath);
4863 while (*d && !isSPACE(*d))
4865 while (SPACE_OR_TAB(*d))
4869 const bool switches_done = PL_doswitches;
4870 const U32 oldpdb = PL_perldb;
4871 const bool oldn = PL_minus_n;
4872 const bool oldp = PL_minus_p;
4876 bool baduni = FALSE;
4878 const char *d2 = d1 + 1;
4879 if (parse_unicode_opts((const char **)&d2)
4883 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
4884 const char * const m = d1;
4885 while (*d1 && !isSPACE(*d1))
4887 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4890 d1 = moreswitches(d1);
4892 if (PL_doswitches && !switches_done) {
4893 int argc = PL_origargc;
4894 char **argv = PL_origargv;
4897 } while (argc && argv[0][0] == '-' && argv[0][1]);
4898 init_argv_symbols(argc,argv);
4900 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4901 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4902 /* if we have already added "LINE: while (<>) {",
4903 we must not do it again */
4905 sv_setpvs(PL_linestr, "");
4906 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4907 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4908 PL_last_lop = PL_last_uni = NULL;
4909 PL_preambled = FALSE;
4910 if (PERLDB_LINE || PERLDB_SAVESRC)
4911 (void)gv_fetchfile(PL_origfilename);
4918 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4919 PL_lex_state = LEX_FORMLINE;
4920 NEXTVAL_NEXTTOKE.ival = 0;
4921 force_next(FORMRBRACK);
4926 #ifdef PERL_STRICT_CR
4927 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4929 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4931 case ' ': case '\t': case '\f': case 013:
4936 if (PL_lex_state != LEX_NORMAL ||
4937 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
4938 const bool in_comment = *s == '#';
4939 if (*s == '#' && s == PL_linestart && PL_in_eval
4940 && !PL_rsfp && !PL_parser->filtered) {
4941 /* handle eval qq[#line 1 "foo"\n ...] */
4942 CopLINE_dec(PL_curcop);
4946 while (d < PL_bufend && *d != '\n')
4950 else if (d > PL_bufend)
4951 /* Found by Ilya: feed random input to Perl. */
4952 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
4955 if (in_comment && d == PL_bufend
4956 && PL_lex_state == LEX_INTERPNORMAL
4957 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
4958 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
4961 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4962 PL_lex_state = LEX_FORMLINE;
4963 NEXTVAL_NEXTTOKE.ival = 0;
4964 force_next(FORMRBRACK);
4969 while (s < PL_bufend && *s != '\n')
4977 else if (s > PL_bufend)
4978 /* Found by Ilya: feed random input to Perl. */
4979 Perl_croak(aTHX_ "panic: input overflow");
4983 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
4991 while (s < PL_bufend && SPACE_OR_TAB(*s))
4994 if (strnEQ(s,"=>",2)) {
4995 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
4996 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4997 OPERATOR('-'); /* unary minus */
5000 case 'r': ftst = OP_FTEREAD; break;
5001 case 'w': ftst = OP_FTEWRITE; break;
5002 case 'x': ftst = OP_FTEEXEC; break;
5003 case 'o': ftst = OP_FTEOWNED; break;
5004 case 'R': ftst = OP_FTRREAD; break;
5005 case 'W': ftst = OP_FTRWRITE; break;
5006 case 'X': ftst = OP_FTREXEC; break;
5007 case 'O': ftst = OP_FTROWNED; break;
5008 case 'e': ftst = OP_FTIS; break;
5009 case 'z': ftst = OP_FTZERO; break;
5010 case 's': ftst = OP_FTSIZE; break;
5011 case 'f': ftst = OP_FTFILE; break;
5012 case 'd': ftst = OP_FTDIR; break;
5013 case 'l': ftst = OP_FTLINK; break;
5014 case 'p': ftst = OP_FTPIPE; break;
5015 case 'S': ftst = OP_FTSOCK; break;
5016 case 'u': ftst = OP_FTSUID; break;
5017 case 'g': ftst = OP_FTSGID; break;
5018 case 'k': ftst = OP_FTSVTX; break;
5019 case 'b': ftst = OP_FTBLK; break;
5020 case 'c': ftst = OP_FTCHR; break;
5021 case 't': ftst = OP_FTTTY; break;
5022 case 'T': ftst = OP_FTTEXT; break;
5023 case 'B': ftst = OP_FTBINARY; break;
5024 case 'M': case 'A': case 'C':
5025 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5027 case 'M': ftst = OP_FTMTIME; break;
5028 case 'A': ftst = OP_FTATIME; break;
5029 case 'C': ftst = OP_FTCTIME; break;
5037 PL_last_uni = PL_oldbufptr;
5038 PL_last_lop_op = (OPCODE)ftst;
5039 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5040 "### Saw file test %c\n", (int)tmp);
5045 /* Assume it was a minus followed by a one-letter named
5046 * subroutine call (or a -bareword), then. */
5047 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5048 "### '-%c' looked like a file test but was not\n",
5055 const char tmp = *s++;
5058 if (PL_expect == XOPERATOR)
5063 else if (*s == '>') {
5066 if (FEATURE_POSTDEREF_IS_ENABLED && (
5067 ((*s == '$' || *s == '&') && s[1] == '*')
5068 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5069 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5070 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5073 Perl_ck_warner_d(aTHX_
5074 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5075 "Postfix dereference is experimental"
5077 PL_expect = XPOSTDEREF;
5080 if (isIDFIRST_lazy_if(s,UTF)) {
5081 s = force_word(s,METHOD,FALSE,TRUE);
5089 if (PL_expect == XOPERATOR) {
5090 if (*s == '=' && !PL_lex_allbrackets &&
5091 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5098 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5100 OPERATOR('-'); /* unary minus */
5106 const char tmp = *s++;
5109 if (PL_expect == XOPERATOR)
5114 if (PL_expect == XOPERATOR) {
5115 if (*s == '=' && !PL_lex_allbrackets &&
5116 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5123 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5130 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5131 if (PL_expect != XOPERATOR) {
5132 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5133 PL_expect = XOPERATOR;
5134 force_ident(PL_tokenbuf, '*');
5142 if (*s == '=' && !PL_lex_allbrackets &&
5143 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5149 if (*s == '=' && !PL_lex_allbrackets &&
5150 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5154 PL_parser->saw_infix_sigil = 1;
5159 if (PL_expect == XOPERATOR) {
5160 if (s[1] == '=' && !PL_lex_allbrackets &&
5161 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5164 PL_parser->saw_infix_sigil = 1;
5167 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5168 PL_tokenbuf[0] = '%';
5169 s = scan_ident(s, PL_tokenbuf + 1,
5170 sizeof PL_tokenbuf - 1, FALSE);
5172 if (!PL_tokenbuf[1]) {
5175 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5177 PL_tokenbuf[0] = '@';
5179 PL_expect = XOPERATOR;
5180 force_ident_maybe_lex('%');
5184 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5185 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5190 if (PL_lex_brackets > 100)
5191 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5192 PL_lex_brackstack[PL_lex_brackets++] = 0;
5193 PL_lex_allbrackets++;
5195 const char tmp = *s++;
5200 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5202 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5205 Perl_ck_warner_d(aTHX_
5206 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5207 "Smartmatch is experimental");
5213 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5220 goto just_a_word_zero_gv;
5226 switch (PL_expect) {
5228 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5230 PL_bufptr = s; /* update in case we back off */
5233 "Use of := for an empty attribute list is not allowed");
5240 PL_expect = XTERMBLOCK;
5244 while (isIDFIRST_lazy_if(s,UTF)) {
5247 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5248 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5249 if (tmp < 0) tmp = -tmp;
5264 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5266 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5267 COPLINE_SET_FROM_MULTI_END;
5269 /* MUST advance bufptr here to avoid bogus
5270 "at end of line" context messages from yyerror().
5272 PL_bufptr = s + len;
5273 yyerror("Unterminated attribute parameter in attribute list");
5277 return REPORT(0); /* EOF indicator */
5281 sv_catsv(sv, PL_lex_stuff);
5282 attrs = op_append_elem(OP_LIST, attrs,
5283 newSVOP(OP_CONST, 0, sv));
5284 SvREFCNT_dec(PL_lex_stuff);
5285 PL_lex_stuff = NULL;
5288 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5290 if (PL_in_my == KEY_our) {
5291 deprecate(":unique");
5294 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5297 /* NOTE: any CV attrs applied here need to be part of
5298 the CVf_BUILTIN_ATTRS define in cv.h! */
5299 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5301 CvLVALUE_on(PL_compcv);
5303 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5305 deprecate(":locked");
5307 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5309 CvMETHOD_on(PL_compcv);
5311 /* After we've set the flags, it could be argued that
5312 we don't need to do the attributes.pm-based setting
5313 process, and shouldn't bother appending recognized
5314 flags. To experiment with that, uncomment the
5315 following "else". (Note that's already been
5316 uncommented. That keeps the above-applied built-in
5317 attributes from being intercepted (and possibly
5318 rejected) by a package's attribute routines, but is
5319 justified by the performance win for the common case
5320 of applying only built-in attributes.) */
5322 attrs = op_append_elem(OP_LIST, attrs,
5323 newSVOP(OP_CONST, 0,
5327 if (*s == ':' && s[1] != ':')
5330 break; /* require real whitespace or :'s */
5331 /* XXX losing whitespace on sequential attributes here */
5334 if (*s != ';' && *s != '}' &&
5335 !(PL_expect == XOPERATOR
5336 ? (*s == '=' || *s == ')')
5337 : (*s == '{' || *s == '('))) {
5338 const char q = ((*s == '\'') ? '"' : '\'');
5339 /* If here for an expression, and parsed no attrs, back
5341 if (PL_expect == XOPERATOR && !attrs) {
5345 /* MUST advance bufptr here to avoid bogus "at end of line"
5346 context messages from yyerror().
5349 yyerror( (const char *)
5351 ? Perl_form(aTHX_ "Invalid separator character "
5352 "%c%c%c in attribute list", q, *s, q)
5353 : "Unterminated attribute list" ) );
5361 NEXTVAL_NEXTTOKE.opval = attrs;
5367 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5371 PL_lex_allbrackets--;
5375 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5376 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5380 PL_lex_allbrackets++;
5383 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5390 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5393 PL_lex_allbrackets--;
5399 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5402 if (PL_lex_brackets <= 0)
5403 /* diag_listed_as: Unmatched right %s bracket */
5404 yyerror("Unmatched right square bracket");
5407 PL_lex_allbrackets--;
5408 if (PL_lex_state == LEX_INTERPNORMAL) {
5409 if (PL_lex_brackets == 0) {
5410 if (*s == '-' && s[1] == '>')
5411 PL_lex_state = LEX_INTERPENDMAYBE;
5412 else if (*s != '[' && *s != '{')
5413 PL_lex_state = LEX_INTERPEND;
5420 if (PL_lex_brackets > 100) {
5421 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5423 switch (PL_expect) {
5425 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5426 PL_lex_allbrackets++;
5427 OPERATOR(HASHBRACK);
5429 while (s < PL_bufend && SPACE_OR_TAB(*s))
5432 PL_tokenbuf[0] = '\0';
5433 if (d < PL_bufend && *d == '-') {
5434 PL_tokenbuf[0] = '-';
5436 while (d < PL_bufend && SPACE_OR_TAB(*d))
5439 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5440 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5442 while (d < PL_bufend && SPACE_OR_TAB(*d))
5445 const char minus = (PL_tokenbuf[0] == '-');
5446 s = force_word(s + minus, WORD, FALSE, TRUE);
5454 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5455 PL_lex_allbrackets++;
5460 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5461 PL_lex_allbrackets++;
5465 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5466 PL_lex_allbrackets++;
5471 if (PL_oldoldbufptr == PL_last_lop)
5472 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5474 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5475 PL_lex_allbrackets++;
5478 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5480 /* This hack is to get the ${} in the message. */
5482 yyerror("syntax error");
5485 OPERATOR(HASHBRACK);
5487 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
5488 /* ${...} or @{...} etc., but not print {...} */
5492 /* This hack serves to disambiguate a pair of curlies
5493 * as being a block or an anon hash. Normally, expectation
5494 * determines that, but in cases where we're not in a
5495 * position to expect anything in particular (like inside
5496 * eval"") we have to resolve the ambiguity. This code
5497 * covers the case where the first term in the curlies is a
5498 * quoted string. Most other cases need to be explicitly
5499 * disambiguated by prepending a "+" before the opening
5500 * curly in order to force resolution as an anon hash.
5502 * XXX should probably propagate the outer expectation
5503 * into eval"" to rely less on this hack, but that could
5504 * potentially break current behavior of eval"".
5508 if (*s == '\'' || *s == '"' || *s == '`') {
5509 /* common case: get past first string, handling escapes */
5510 for (t++; t < PL_bufend && *t != *s;)
5515 else if (*s == 'q') {
5518 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5519 && !isWORDCHAR(*t))))
5521 /* skip q//-like construct */
5523 char open, close, term;
5526 while (t < PL_bufend && isSPACE(*t))
5528 /* check for q => */
5529 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5530 OPERATOR(HASHBRACK);
5534 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5538 for (t++; t < PL_bufend; t++) {
5539 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5541 else if (*t == open)
5545 for (t++; t < PL_bufend; t++) {
5546 if (*t == '\\' && t+1 < PL_bufend)
5548 else if (*t == close && --brackets <= 0)
5550 else if (*t == open)
5557 /* skip plain q word */
5558 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5561 else if (isWORDCHAR_lazy_if(t,UTF)) {
5563 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5566 while (t < PL_bufend && isSPACE(*t))
5568 /* if comma follows first term, call it an anon hash */
5569 /* XXX it could be a comma expression with loop modifiers */
5570 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5571 || (*t == '=' && t[1] == '>')))
5572 OPERATOR(HASHBRACK);
5573 if (PL_expect == XREF)
5576 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5582 pl_yylval.ival = CopLINE(PL_curcop);
5583 if (isSPACE(*s) || *s == '#')
5584 PL_copline = NOLINE; /* invalidate current command line number */
5585 TOKEN(formbrack ? '=' : '{');
5587 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5591 if (PL_lex_brackets <= 0)
5592 /* diag_listed_as: Unmatched right %s bracket */
5593 yyerror("Unmatched right curly bracket");
5595 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5596 PL_lex_allbrackets--;
5597 if (PL_lex_state == LEX_INTERPNORMAL) {
5598 if (PL_lex_brackets == 0) {
5599 if (PL_expect & XFAKEBRACK) {
5600 PL_expect &= XENUMMASK;
5601 PL_lex_state = LEX_INTERPEND;
5603 return yylex(); /* ignore fake brackets */
5605 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5606 && SvEVALED(PL_lex_repl))
5607 PL_lex_state = LEX_INTERPEND;
5608 else if (*s == '-' && s[1] == '>')
5609 PL_lex_state = LEX_INTERPENDMAYBE;
5610 else if (*s != '[' && *s != '{')
5611 PL_lex_state = LEX_INTERPEND;
5614 if (PL_expect & XFAKEBRACK) {
5615 PL_expect &= XENUMMASK;
5617 return yylex(); /* ignore fake brackets */
5619 force_next(formbrack ? '.' : '}');
5620 if (formbrack) LEAVE;
5621 if (formbrack == 2) { /* means . where arguments were expected */
5627 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5630 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5631 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5638 if (PL_expect == XOPERATOR) {
5639 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5640 && isIDFIRST_lazy_if(s,UTF))
5642 CopLINE_dec(PL_curcop);
5643 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5644 CopLINE_inc(PL_curcop);
5646 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5647 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5651 PL_parser->saw_infix_sigil = 1;
5655 PL_tokenbuf[0] = '&';
5656 s = scan_ident(s - 1, PL_tokenbuf + 1,
5657 sizeof PL_tokenbuf - 1, TRUE);
5658 if (PL_tokenbuf[1]) {
5659 PL_expect = XOPERATOR;
5660 force_ident_maybe_lex('&');
5664 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5670 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5671 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5678 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5679 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5687 const char tmp = *s++;
5689 if (!PL_lex_allbrackets &&
5690 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5697 if (!PL_lex_allbrackets &&
5698 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5706 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5707 && strchr("+-*/%.^&|<",tmp))
5708 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5709 "Reversed %c= operator",(int)tmp);
5711 if (PL_expect == XSTATE && isALPHA(tmp) &&
5712 (s == PL_linestart+1 || s[-2] == '\n') )
5714 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5715 || PL_lex_state != LEX_NORMAL) {
5720 if (strnEQ(s,"=cut",4)) {
5734 PL_parser->in_pod = 1;
5738 if (PL_expect == XBLOCK) {
5740 #ifdef PERL_STRICT_CR
5741 while (SPACE_OR_TAB(*t))
5743 while (SPACE_OR_TAB(*t) || *t == '\r')
5746 if (*t == '\n' || *t == '#') {
5749 SAVEI8(PL_parser->form_lex_state);
5750 SAVEI32(PL_lex_formbrack);
5751 PL_parser->form_lex_state = PL_lex_state;
5752 PL_lex_formbrack = PL_lex_brackets + 1;
5756 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5765 const char tmp = *s++;
5767 /* was this !=~ where !~ was meant?
5768 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5770 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5771 const char *t = s+1;
5773 while (t < PL_bufend && isSPACE(*t))
5776 if (*t == '/' || *t == '?' ||
5777 ((*t == 'm' || *t == 's' || *t == 'y')
5778 && !isWORDCHAR(t[1])) ||
5779 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5780 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5781 "!=~ should be !~");
5783 if (!PL_lex_allbrackets &&
5784 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5796 if (PL_expect != XOPERATOR) {
5797 if (s[1] != '<' && !strchr(s,'>'))
5800 s = scan_heredoc(s);
5802 s = scan_inputsymbol(s);
5803 PL_expect = XOPERATOR;
5804 TOKEN(sublex_start());
5810 if (*s == '=' && !PL_lex_allbrackets &&
5811 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5815 SHop(OP_LEFT_SHIFT);
5820 if (!PL_lex_allbrackets &&
5821 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5828 if (!PL_lex_allbrackets &&
5829 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5837 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5845 const char tmp = *s++;
5847 if (*s == '=' && !PL_lex_allbrackets &&
5848 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5852 SHop(OP_RIGHT_SHIFT);
5854 else if (tmp == '=') {
5855 if (!PL_lex_allbrackets &&
5856 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5864 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5873 if (PL_expect == XOPERATOR) {
5874 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5875 return deprecate_commaless_var_list();
5878 else if (PL_expect == XPOSTDEREF) {
5881 POSTDEREF(DOLSHARP);
5886 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
5887 PL_tokenbuf[0] = '@';
5888 s = scan_ident(s + 1, PL_tokenbuf + 1,
5889 sizeof PL_tokenbuf - 1, FALSE);
5890 if (PL_expect == XOPERATOR)
5891 no_op("Array length", s);
5892 if (!PL_tokenbuf[1])
5894 PL_expect = XOPERATOR;
5895 force_ident_maybe_lex('#');
5899 PL_tokenbuf[0] = '$';
5900 s = scan_ident(s, PL_tokenbuf + 1,
5901 sizeof PL_tokenbuf - 1, FALSE);
5902 if (PL_expect == XOPERATOR)
5904 if (!PL_tokenbuf[1]) {
5906 yyerror("Final $ should be \\$ or $name");
5912 const char tmp = *s;
5913 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5916 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5917 && intuit_more(s)) {
5919 PL_tokenbuf[0] = '@';
5920 if (ckWARN(WARN_SYNTAX)) {
5923 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
5926 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
5927 while (t < PL_bufend && *t != ']')
5929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5930 "Multidimensional syntax %.*s not supported",
5931 (int)((t - PL_bufptr) + 1), PL_bufptr);
5935 else if (*s == '{') {
5937 PL_tokenbuf[0] = '%';
5938 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
5939 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
5941 char tmpbuf[sizeof PL_tokenbuf];
5944 } while (isSPACE(*t));
5945 if (isIDFIRST_lazy_if(t,UTF)) {
5947 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5952 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
5953 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5954 "You need to quote \"%"UTF8f"\"",
5955 UTF8fARG(UTF, len, tmpbuf));
5961 PL_expect = XOPERATOR;
5962 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
5963 const bool islop = (PL_last_lop == PL_oldoldbufptr);
5964 if (!islop || PL_last_lop_op == OP_GREPSTART)
5965 PL_expect = XOPERATOR;
5966 else if (strchr("$@\"'`q", *s))
5967 PL_expect = XTERM; /* e.g. print $fh "foo" */
5968 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
5969 PL_expect = XTERM; /* e.g. print $fh &sub */
5970 else if (isIDFIRST_lazy_if(s,UTF)) {
5971 char tmpbuf[sizeof PL_tokenbuf];
5973 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5974 if ((t2 = keyword(tmpbuf, len, 0))) {
5975 /* binary operators exclude handle interpretations */
5987 PL_expect = XTERM; /* e.g. print $fh length() */
5992 PL_expect = XTERM; /* e.g. print $fh subr() */
5995 else if (isDIGIT(*s))
5996 PL_expect = XTERM; /* e.g. print $fh 3 */
5997 else if (*s == '.' && isDIGIT(s[1]))
5998 PL_expect = XTERM; /* e.g. print $fh .3 */
5999 else if ((*s == '?' || *s == '-' || *s == '+')
6000 && !isSPACE(s[1]) && s[1] != '=')
6001 PL_expect = XTERM; /* e.g. print $fh -1 */
6002 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6004 PL_expect = XTERM; /* e.g. print $fh /.../
6005 XXX except DORDOR operator
6007 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6009 PL_expect = XTERM; /* print $fh <<"EOF" */
6012 force_ident_maybe_lex('$');
6016 if (PL_expect == XOPERATOR)
6018 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6019 PL_tokenbuf[0] = '@';
6020 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6022 if (!PL_tokenbuf[1]) {
6025 if (PL_lex_state == LEX_NORMAL)
6027 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6029 PL_tokenbuf[0] = '%';
6031 /* Warn about @ where they meant $. */
6032 if (*s == '[' || *s == '{') {
6033 if (ckWARN(WARN_SYNTAX)) {
6034 S_check_scalar_slice(aTHX_ s);
6038 PL_expect = XOPERATOR;
6039 force_ident_maybe_lex('@');
6042 case '/': /* may be division, defined-or, or pattern */
6043 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6044 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6045 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6050 else if (PL_expect == XOPERATOR) {
6052 if (*s == '=' && !PL_lex_allbrackets &&
6053 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6060 /* Disable warning on "study /blah/" */
6061 if (PL_oldoldbufptr == PL_last_uni
6062 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6063 || memNE(PL_last_uni, "study", 5)
6064 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6067 s = scan_pat(s,OP_MATCH);
6068 TERM(sublex_start());
6071 case '?': /* conditional */
6073 if (!PL_lex_allbrackets &&
6074 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6078 PL_lex_allbrackets++;
6082 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6083 #ifdef PERL_STRICT_CR
6086 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6088 && (s == PL_linestart || s[-1] == '\n') )
6091 formbrack = 2; /* dot seen where arguments expected */
6094 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6098 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6101 if (!PL_lex_allbrackets &&
6102 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6109 pl_yylval.ival = OPf_SPECIAL;
6115 if (*s == '=' && !PL_lex_allbrackets &&
6116 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6123 case '0': case '1': case '2': case '3': case '4':
6124 case '5': case '6': case '7': case '8': case '9':
6125 s = scan_num(s, &pl_yylval);
6126 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6127 if (PL_expect == XOPERATOR)
6132 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6135 COPLINE_SET_FROM_MULTI_END;
6136 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6137 if (PL_expect == XOPERATOR) {
6138 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6139 return deprecate_commaless_var_list();
6144 pl_yylval.ival = OP_CONST;
6145 TERM(sublex_start());
6148 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6151 printbuf("### Saw string before %s\n", s);
6153 PerlIO_printf(Perl_debug_log,
6154 "### Saw unterminated string\n");
6156 if (PL_expect == XOPERATOR) {
6157 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6158 return deprecate_commaless_var_list();
6165 pl_yylval.ival = OP_CONST;
6166 /* FIXME. I think that this can be const if char *d is replaced by
6167 more localised variables. */
6168 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6169 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6170 pl_yylval.ival = OP_STRINGIFY;
6174 if (pl_yylval.ival == OP_CONST)
6175 COPLINE_SET_FROM_MULTI_END;
6176 TERM(sublex_start());
6179 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6180 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6181 if (PL_expect == XOPERATOR)
6182 no_op("Backticks",s);
6185 pl_yylval.ival = OP_BACKTICK;
6186 TERM(sublex_start());
6190 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6192 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6194 if (PL_expect == XOPERATOR)
6195 no_op("Backslash",s);
6199 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6200 char *start = s + 2;
6201 while (isDIGIT(*start) || *start == '_')
6203 if (*start == '.' && isDIGIT(start[1])) {
6204 s = scan_num(s, &pl_yylval);
6207 else if ((*start == ':' && start[1] == ':')
6208 || (PL_expect == XSTATE && *start == ':'))
6210 else if (PL_expect == XSTATE) {
6212 while (d < PL_bufend && isSPACE(*d)) d++;
6213 if (*d == ':') goto keylookup;
6215 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6216 if (!isALPHA(*start) && (PL_expect == XTERM
6217 || PL_expect == XSTATE
6218 || PL_expect == XTERMORDORDOR)) {
6219 GV *const gv = gv_fetchpvn_flags(s, start - s,
6220 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6222 s = scan_num(s, &pl_yylval);
6229 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6282 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6284 /* Some keywords can be followed by any delimiter, including ':' */
6285 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6287 /* x::* is just a word, unless x is "CORE" */
6288 if (!anydelim && *s == ':' && s[1] == ':') {
6289 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6294 while (d < PL_bufend && isSPACE(*d))
6295 d++; /* no comments skipped here, or s### is misparsed */
6297 /* Is this a word before a => operator? */
6298 if (*d == '=' && d[1] == '>') {
6302 = (OP*)newSVOP(OP_CONST, 0,
6303 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6304 pl_yylval.opval->op_private = OPpCONST_BARE;
6308 /* Check for plugged-in keyword */
6312 char *saved_bufptr = PL_bufptr;
6314 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6316 if (result == KEYWORD_PLUGIN_DECLINE) {
6317 /* not a plugged-in keyword */
6318 PL_bufptr = saved_bufptr;
6319 } else if (result == KEYWORD_PLUGIN_STMT) {
6320 pl_yylval.opval = o;
6322 if (!PL_nexttoke) PL_expect = XSTATE;
6323 return REPORT(PLUGSTMT);
6324 } else if (result == KEYWORD_PLUGIN_EXPR) {
6325 pl_yylval.opval = o;
6327 if (!PL_nexttoke) PL_expect = XOPERATOR;
6328 return REPORT(PLUGEXPR);
6330 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6335 /* Check for built-in keyword */
6336 tmp = keyword(PL_tokenbuf, len, 0);
6338 /* Is this a label? */
6339 if (!anydelim && PL_expect == XSTATE
6340 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6342 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6343 pl_yylval.pval[len] = '\0';
6344 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6349 /* Check for lexical sub */
6350 if (PL_expect != XOPERATOR) {
6351 char tmpbuf[sizeof PL_tokenbuf + 1];
6353 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6354 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
6355 if (off != NOT_IN_PAD) {
6356 assert(off); /* we assume this is boolean-true below */
6357 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6358 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6359 HEK * const stashname = HvNAME_HEK(stash);
6360 sv = newSVhek(stashname);
6361 sv_catpvs(sv, "::");
6362 sv_catpvn_flags(sv, PL_tokenbuf, len,
6363 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6364 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6374 rv2cv_op = newOP(OP_PADANY, 0);
6375 rv2cv_op->op_targ = off;
6376 cv = find_lexical_cv(off);
6384 if (tmp < 0) { /* second-class keyword? */
6385 GV *ogv = NULL; /* override (winner) */
6386 GV *hgv = NULL; /* hidden (loser) */
6387 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6389 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6390 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6394 if (GvIMPORTED_CV(gv))
6396 else if (! CvMETHOD(cv))
6400 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6404 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6405 : SvPCS_IMPORTED(gv)
6406 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6415 tmp = 0; /* overridden by import or by GLOBAL */
6418 && -tmp==KEY_lock /* XXX generalizable kludge */
6421 tmp = 0; /* any sub overrides "weak" keyword */
6423 else { /* no override */
6425 if (tmp == KEY_dump) {
6426 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6427 "dump() better written as CORE::dump()");
6431 if (hgv && tmp != KEY_x) /* never ambiguous */
6432 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6433 "Ambiguous call resolved as CORE::%s(), "
6434 "qualify as such or use &",
6439 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6440 && (!anydelim || *s != '#')) {
6441 /* no override, and not s### either; skipspace is safe here
6442 * check for => on following line */
6444 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6445 STRLEN soff = s - SvPVX(PL_linestr);
6446 s = skipspace_flags(s, LEX_NO_INCLINE);
6447 arrow = *s == '=' && s[1] == '>';
6448 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6449 s = SvPVX(PL_linestr) + soff;
6457 default: /* not a keyword */
6458 /* Trade off - by using this evil construction we can pull the
6459 variable gv into the block labelled keylookup. If not, then
6460 we have to give it function scope so that the goto from the
6461 earlier ':' case doesn't bypass the initialisation. */
6463 just_a_word_zero_gv:
6475 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6479 /* Get the rest if it looks like a package qualifier */
6481 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6483 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6486 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6487 UTF8fARG(UTF, len, PL_tokenbuf),
6488 *s == '\'' ? "'" : "::");
6493 if (PL_expect == XOPERATOR) {
6494 if (PL_bufptr == PL_linestart) {
6495 CopLINE_dec(PL_curcop);
6496 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6497 CopLINE_inc(PL_curcop);
6500 no_op("Bareword",s);
6503 /* See if the name is "Foo::",
6504 in which case Foo is a bareword
6505 (and a package name). */
6508 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6510 if (ckWARN(WARN_BAREWORD)
6511 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6512 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6513 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6514 UTF8fARG(UTF, len, PL_tokenbuf));
6516 PL_tokenbuf[len] = '\0';
6525 /* if we saw a global override before, get the right name */
6528 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6531 SV * const tmp_sv = sv;
6532 sv = newSVpvs("CORE::GLOBAL::");
6533 sv_catsv(sv, tmp_sv);
6534 SvREFCNT_dec(tmp_sv);
6538 /* Presume this is going to be a bareword of some sort. */
6540 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6541 pl_yylval.opval->op_private = OPpCONST_BARE;
6543 /* And if "Foo::", then that's what it certainly is. */
6549 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6550 const_op->op_private = OPpCONST_BARE;
6552 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
6556 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
6559 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
6562 /* Use this var to track whether intuit_method has been
6563 called. intuit_method returns 0 or > 255. */
6566 /* See if it's the indirect object for a list operator. */
6568 if (PL_oldoldbufptr &&
6569 PL_oldoldbufptr < PL_bufptr &&
6570 (PL_oldoldbufptr == PL_last_lop
6571 || PL_oldoldbufptr == PL_last_uni) &&
6572 /* NO SKIPSPACE BEFORE HERE! */
6573 (PL_expect == XREF ||
6574 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6576 bool immediate_paren = *s == '(';
6578 /* (Now we can afford to cross potential line boundary.) */
6581 /* Two barewords in a row may indicate method call. */
6583 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6584 (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6588 /* If not a declared subroutine, it's an indirect object. */
6589 /* (But it's an indir obj regardless for sort.) */
6590 /* Also, if "_" follows a filetest operator, it's a bareword */
6593 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6595 (PL_last_lop_op != OP_MAPSTART &&
6596 PL_last_lop_op != OP_GREPSTART))))
6597 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6598 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6601 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6606 PL_expect = XOPERATOR;
6609 /* Is this a word before a => operator? */
6610 if (*s == '=' && s[1] == '>' && !pkgname) {
6613 if (gvp || (lex && !off)) {
6614 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
6615 /* This is our own scalar, created a few lines
6616 above, so this is safe. */
6618 sv_setpv(sv, PL_tokenbuf);
6619 if (UTF && !IN_BYTES
6620 && is_utf8_string((U8*)PL_tokenbuf, len))
6627 /* If followed by a paren, it's certainly a subroutine. */
6632 while (SPACE_OR_TAB(*d))
6634 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6639 NEXTVAL_NEXTTOKE.opval =
6640 off ? rv2cv_op : pl_yylval.opval;
6642 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6643 else op_free(rv2cv_op), force_next(WORD);
6648 /* If followed by var or block, call it a method (unless sub) */
6650 if ((*s == '$' || *s == '{') && !cv) {
6652 PL_last_lop = PL_oldbufptr;
6653 PL_last_lop_op = OP_METHOD;
6654 if (!PL_lex_allbrackets &&
6655 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6656 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6657 PL_expect = XBLOCKTERM;
6659 return REPORT(METHOD);
6662 /* If followed by a bareword, see if it looks like indir obj. */
6664 if (tmp == 1 && !orig_keyword
6665 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6666 && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
6669 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
6671 sv_setpvn(sv, PL_tokenbuf, len);
6672 if (UTF && !IN_BYTES
6673 && is_utf8_string((U8*)PL_tokenbuf, len))
6675 else SvUTF8_off(sv);
6678 if (tmp == METHOD && !PL_lex_allbrackets &&
6679 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6680 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6684 /* Not a method, so call it a subroutine (if defined) */
6687 /* Check for a constant sub */
6688 if ((sv = cv_const_sv_or_av(cv))) {
6691 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6692 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6693 if (SvTYPE(sv) == SVt_PVAV)
6694 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6697 pl_yylval.opval->op_private = 0;
6698 pl_yylval.opval->op_folded = 1;
6699 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6704 op_free(pl_yylval.opval);
6706 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6707 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6708 PL_last_lop = PL_oldbufptr;
6709 PL_last_lop_op = OP_ENTERSUB;
6710 /* Is there a prototype? */
6714 STRLEN protolen = CvPROTOLEN(cv);
6715 const char *proto = CvPROTO(cv);
6717 proto = S_strip_spaces(aTHX_ proto, &protolen);
6720 if ((optional = *proto == ';'))
6723 while (*proto == ';');
6727 *proto == '$' || *proto == '_'
6728 || *proto == '*' || *proto == '+'
6733 *proto == '\\' && proto[1] && proto[2] == '\0'
6736 UNIPROTO(UNIOPSUB,optional);
6737 if (*proto == '\\' && proto[1] == '[') {
6738 const char *p = proto + 2;
6739 while(*p && *p != ']')
6741 if(*p == ']' && !p[1])
6742 UNIPROTO(UNIOPSUB,optional);
6744 if (*proto == '&' && *s == '{') {
6746 sv_setpvs(PL_subname, "__ANON__");
6748 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6749 if (!PL_lex_allbrackets &&
6750 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6751 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6755 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6757 force_next(off ? PRIVATEREF : WORD);
6758 if (!PL_lex_allbrackets &&
6759 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6760 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6764 /* Call it a bare word */
6766 if (PL_hints & HINT_STRICT_SUBS)
6767 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6770 /* after "print" and similar functions (corresponding to
6771 * "F? L" in opcode.pl), whatever wasn't already parsed as
6772 * a filehandle should be subject to "strict subs".
6773 * Likewise for the optional indirect-object argument to system
6774 * or exec, which can't be a bareword */
6775 if ((PL_last_lop_op == OP_PRINT
6776 || PL_last_lop_op == OP_PRTF
6777 || PL_last_lop_op == OP_SAY
6778 || PL_last_lop_op == OP_SYSTEM
6779 || PL_last_lop_op == OP_EXEC)
6780 && (PL_hints & HINT_STRICT_SUBS))
6781 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6782 if (lastchar != '-') {
6783 if (ckWARN(WARN_RESERVED)) {
6787 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6789 /* PL_warn_reserved is constant */
6790 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6791 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6801 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6802 && saw_infix_sigil) {
6803 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6804 "Operator or semicolon missing before %c%"UTF8f,
6806 UTF8fARG(UTF, strlen(PL_tokenbuf),
6808 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6809 "Ambiguous use of %c resolved as operator %c",
6810 lastchar, lastchar);
6817 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6822 (OP*)newSVOP(OP_CONST, 0,
6823 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6826 case KEY___PACKAGE__:
6828 (OP*)newSVOP(OP_CONST, 0,
6830 ? newSVhek(HvNAME_HEK(PL_curstash))
6837 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6838 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6841 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6843 gv_init(gv,stash,"DATA",4,0);
6846 GvIOp(gv) = newIO();
6847 IoIFP(GvIOp(gv)) = PL_rsfp;
6848 #if defined(HAS_FCNTL) && defined(F_SETFD)
6850 const int fd = PerlIO_fileno(PL_rsfp);
6851 fcntl(fd,F_SETFD,fd >= 3);
6854 /* Mark this internal pseudo-handle as clean */
6855 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6856 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6857 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6859 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6860 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6861 /* if the script was opened in binmode, we need to revert
6862 * it to text mode for compatibility; but only iff it has CRs
6863 * XXX this is a questionable hack at best. */
6864 if (PL_bufend-PL_bufptr > 2
6865 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6868 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6869 loc = PerlIO_tell(PL_rsfp);
6870 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6873 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6875 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6876 #endif /* NETWARE */
6878 PerlIO_seek(PL_rsfp, loc, 0);
6882 #ifdef PERLIO_LAYERS
6885 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6886 else if (PL_encoding) {
6892 XPUSHs(PL_encoding);
6894 call_method("name", G_SCALAR);
6898 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
6899 Perl_form(aTHX_ ":encoding(%"SVf")",
6912 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
6921 if (PL_expect == XSTATE) {
6932 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6933 if ((*s == ':' && s[1] == ':')
6934 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
6938 Copy(PL_bufptr, PL_tokenbuf, olen, char);
6942 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
6943 UTF8fARG(UTF, len, PL_tokenbuf));
6946 else if (tmp == KEY_require || tmp == KEY_do
6948 /* that's a way to remember we saw "CORE::" */
6960 LOP(OP_ACCEPT,XTERM);
6963 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
6968 LOP(OP_ATAN2,XTERM);
6974 LOP(OP_BINMODE,XTERM);
6977 LOP(OP_BLESS,XTERM);
6986 /* We have to disambiguate the two senses of
6987 "continue". If the next token is a '{' then
6988 treat it as the start of a continue block;
6989 otherwise treat it as a control operator.
6999 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7009 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7018 if (!PL_cryptseen) {
7019 PL_cryptseen = TRUE;
7023 LOP(OP_CRYPT,XTERM);
7026 LOP(OP_CHMOD,XTERM);
7029 LOP(OP_CHOWN,XTERM);
7032 LOP(OP_CONNECT,XTERM);
7052 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7054 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7055 && !keyword(PL_tokenbuf + 1, len, 0)) {
7058 force_ident_maybe_lex('&');
7063 if (orig_keyword == KEY_do) {
7072 PL_hints |= HINT_BLOCK_SCOPE;
7082 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7083 STR_WITH_LEN("NDBM_File::"),
7084 STR_WITH_LEN("DB_File::"),
7085 STR_WITH_LEN("GDBM_File::"),
7086 STR_WITH_LEN("SDBM_File::"),
7087 STR_WITH_LEN("ODBM_File::"),
7089 LOP(OP_DBMOPEN,XTERM);
7101 pl_yylval.ival = CopLINE(PL_curcop);
7105 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7117 if (*s == '{') { /* block eval */
7118 PL_expect = XTERMBLOCK;
7119 UNIBRACK(OP_ENTERTRY);
7121 else { /* string eval */
7123 UNIBRACK(OP_ENTEREVAL);
7128 UNIBRACK(-OP_ENTEREVAL);
7142 case KEY_endhostent:
7148 case KEY_endservent:
7151 case KEY_endprotoent:
7162 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7164 pl_yylval.ival = CopLINE(PL_curcop);
7166 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7169 if ((PL_bufend - p) >= 3 &&
7170 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7172 else if ((PL_bufend - p) >= 4 &&
7173 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7176 /* skip optional package name, as in "for my abc $x (..)" */
7177 if (isIDFIRST_lazy_if(p,UTF)) {
7178 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7182 Perl_croak(aTHX_ "Missing $ on loop variable");
7187 LOP(OP_FORMLINE,XTERM);
7196 LOP(OP_FCNTL,XTERM);
7202 LOP(OP_FLOCK,XTERM);
7205 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7210 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7215 LOP(OP_GREPSTART, XREF);
7232 case KEY_getpriority:
7233 LOP(OP_GETPRIORITY,XTERM);
7235 case KEY_getprotobyname:
7238 case KEY_getprotobynumber:
7239 LOP(OP_GPBYNUMBER,XTERM);
7241 case KEY_getprotoent:
7253 case KEY_getpeername:
7254 UNI(OP_GETPEERNAME);
7256 case KEY_gethostbyname:
7259 case KEY_gethostbyaddr:
7260 LOP(OP_GHBYADDR,XTERM);
7262 case KEY_gethostent:
7265 case KEY_getnetbyname:
7268 case KEY_getnetbyaddr:
7269 LOP(OP_GNBYADDR,XTERM);
7274 case KEY_getservbyname:
7275 LOP(OP_GSBYNAME,XTERM);
7277 case KEY_getservbyport:
7278 LOP(OP_GSBYPORT,XTERM);
7280 case KEY_getservent:
7283 case KEY_getsockname:
7284 UNI(OP_GETSOCKNAME);
7286 case KEY_getsockopt:
7287 LOP(OP_GSOCKOPT,XTERM);
7302 pl_yylval.ival = CopLINE(PL_curcop);
7303 Perl_ck_warner_d(aTHX_
7304 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7305 "given is experimental");
7310 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7318 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7320 pl_yylval.ival = CopLINE(PL_curcop);
7324 LOP(OP_INDEX,XTERM);
7330 LOP(OP_IOCTL,XTERM);
7358 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7363 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7377 LOP(OP_LISTEN,XTERM);
7386 s = scan_pat(s,OP_MATCH);
7387 TERM(sublex_start());
7390 LOP(OP_MAPSTART, XREF);
7393 LOP(OP_MKDIR,XTERM);
7396 LOP(OP_MSGCTL,XTERM);
7399 LOP(OP_MSGGET,XTERM);
7402 LOP(OP_MSGRCV,XTERM);
7405 LOP(OP_MSGSND,XTERM);
7410 PL_in_my = (U16)tmp;
7412 if (isIDFIRST_lazy_if(s,UTF)) {
7413 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7414 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7416 if (!FEATURE_LEXSUBS_IS_ENABLED)
7418 "Experimental \"%s\" subs not enabled",
7419 tmp == KEY_my ? "my" :
7420 tmp == KEY_state ? "state" : "our");
7421 Perl_ck_warner_d(aTHX_
7422 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7423 "The lexical_subs feature is experimental");
7426 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7427 if (!PL_in_my_stash) {
7431 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7432 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
7433 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7443 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7448 s = tokenize_use(0, s);
7452 if (*s == '(' || (s = skipspace(s), *s == '('))
7455 if (!PL_lex_allbrackets &&
7456 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7457 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7463 if (isIDFIRST_lazy_if(s,UTF)) {
7465 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7467 for (t=d; isSPACE(*t);)
7469 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7471 && !(t[0] == '=' && t[1] == '>')
7472 && !(t[0] == ':' && t[1] == ':')
7473 && !keyword(s, d-s, 0)
7475 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7476 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7477 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7483 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7485 pl_yylval.ival = OP_OR;
7495 LOP(OP_OPEN_DIR,XTERM);
7498 checkcomma(s,PL_tokenbuf,"filehandle");
7502 checkcomma(s,PL_tokenbuf,"filehandle");
7521 s = force_word(s,WORD,FALSE,TRUE);
7523 s = force_strict_version(s);
7527 LOP(OP_PIPE_OP,XTERM);
7530 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7533 COPLINE_SET_FROM_MULTI_END;
7534 pl_yylval.ival = OP_CONST;
7535 TERM(sublex_start());
7542 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7545 COPLINE_SET_FROM_MULTI_END;
7546 PL_expect = XOPERATOR;
7547 if (SvCUR(PL_lex_stuff)) {
7548 int warned_comma = !ckWARN(WARN_QW);
7549 int warned_comment = warned_comma;
7550 d = SvPV_force(PL_lex_stuff, len);
7552 for (; isSPACE(*d) && len; --len, ++d)
7557 if (!warned_comma || !warned_comment) {
7558 for (; !isSPACE(*d) && len; --len, ++d) {
7559 if (!warned_comma && *d == ',') {
7560 Perl_warner(aTHX_ packWARN(WARN_QW),
7561 "Possible attempt to separate words with commas");
7564 else if (!warned_comment && *d == '#') {
7565 Perl_warner(aTHX_ packWARN(WARN_QW),
7566 "Possible attempt to put comments in qw() list");
7572 for (; !isSPACE(*d) && len; --len, ++d)
7575 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7576 words = op_append_elem(OP_LIST, words,
7577 newSVOP(OP_CONST, 0, tokeq(sv)));
7582 words = newNULLLIST();
7584 SvREFCNT_dec(PL_lex_stuff);
7585 PL_lex_stuff = NULL;
7587 PL_expect = XOPERATOR;
7588 pl_yylval.opval = sawparens(words);
7593 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7596 pl_yylval.ival = OP_STRINGIFY;
7597 if (SvIVX(PL_lex_stuff) == '\'')
7598 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7599 TERM(sublex_start());
7602 s = scan_pat(s,OP_QR);
7603 TERM(sublex_start());
7606 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7609 pl_yylval.ival = OP_BACKTICK;
7610 TERM(sublex_start());
7618 s = force_version(s, FALSE);
7620 else if (*s != 'v' || !isDIGIT(s[1])
7621 || (s = force_version(s, TRUE), *s == 'v'))
7623 *PL_tokenbuf = '\0';
7624 s = force_word(s,WORD,TRUE,TRUE);
7625 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7626 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7627 GV_ADD | (UTF ? SVf_UTF8 : 0));
7629 yyerror("<> at require-statement should be quotes");
7631 if (orig_keyword == KEY_require) {
7637 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
7639 PL_last_uni = PL_oldbufptr;
7640 PL_last_lop_op = OP_REQUIRE;
7642 return REPORT( (int)REQUIRE );
7651 LOP(OP_RENAME,XTERM);
7660 LOP(OP_RINDEX,XTERM);
7669 UNIDOR(OP_READLINE);
7672 UNIDOR(OP_BACKTICK);
7681 LOP(OP_REVERSE,XTERM);
7684 UNIDOR(OP_READLINK);
7691 if (pl_yylval.opval)
7692 TERM(sublex_start());
7694 TOKEN(1); /* force error */
7697 checkcomma(s,PL_tokenbuf,"filehandle");
7707 LOP(OP_SELECT,XTERM);
7713 LOP(OP_SEMCTL,XTERM);
7716 LOP(OP_SEMGET,XTERM);
7719 LOP(OP_SEMOP,XTERM);
7725 LOP(OP_SETPGRP,XTERM);
7727 case KEY_setpriority:
7728 LOP(OP_SETPRIORITY,XTERM);
7730 case KEY_sethostent:
7736 case KEY_setservent:
7739 case KEY_setprotoent:
7749 LOP(OP_SEEKDIR,XTERM);
7751 case KEY_setsockopt:
7752 LOP(OP_SSOCKOPT,XTERM);
7758 LOP(OP_SHMCTL,XTERM);
7761 LOP(OP_SHMGET,XTERM);
7764 LOP(OP_SHMREAD,XTERM);
7767 LOP(OP_SHMWRITE,XTERM);
7770 LOP(OP_SHUTDOWN,XTERM);
7779 LOP(OP_SOCKET,XTERM);
7781 case KEY_socketpair:
7782 LOP(OP_SOCKPAIR,XTERM);
7785 checkcomma(s,PL_tokenbuf,"subroutine name");
7788 s = force_word(s,WORD,TRUE,TRUE);
7792 LOP(OP_SPLIT,XTERM);
7795 LOP(OP_SPRINTF,XTERM);
7798 LOP(OP_SPLICE,XTERM);
7813 LOP(OP_SUBSTR,XTERM);
7819 char * const tmpbuf = PL_tokenbuf + 1;
7820 expectation attrful;
7821 bool have_name, have_proto;
7822 const int key = tmp;
7823 SV *format_name = NULL;
7828 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7829 (*s == ':' && s[1] == ':'))
7833 attrful = XATTRBLOCK;
7834 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7836 if (key == KEY_format)
7837 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7839 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7841 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
7843 sv_setpvn(PL_subname, tmpbuf, len);
7845 sv_setsv(PL_subname,PL_curstname);
7846 sv_catpvs(PL_subname,"::");
7847 sv_catpvn(PL_subname,tmpbuf,len);
7849 if (SvUTF8(PL_linestr))
7850 SvUTF8_on(PL_subname);
7857 if (key == KEY_my || key == KEY_our || key==KEY_state)
7860 /* diag_listed_as: Missing name in "%s sub" */
7862 "Missing name in \"%s\"", PL_bufptr);
7864 PL_expect = XTERMBLOCK;
7865 attrful = XATTRTERM;
7866 sv_setpvs(PL_subname,"?");
7870 if (key == KEY_format) {
7872 NEXTVAL_NEXTTOKE.opval
7873 = (OP*)newSVOP(OP_CONST,0, format_name);
7874 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
7880 /* Look for a prototype */
7881 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
7882 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7883 COPLINE_SET_FROM_MULTI_END;
7885 Perl_croak(aTHX_ "Prototype not terminated");
7886 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
7894 if (*s == ':' && s[1] != ':')
7895 PL_expect = attrful;
7896 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
7898 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
7899 else if (*s != ';' && *s != '}')
7900 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
7904 NEXTVAL_NEXTTOKE.opval =
7905 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
7906 PL_lex_stuff = NULL;
7911 sv_setpvs(PL_subname, "__ANON__");
7913 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7916 force_ident_maybe_lex('&');
7921 LOP(OP_SYSTEM,XREF);
7924 LOP(OP_SYMLINK,XTERM);
7927 LOP(OP_SYSCALL,XTERM);
7930 LOP(OP_SYSOPEN,XTERM);
7933 LOP(OP_SYSSEEK,XTERM);
7936 LOP(OP_SYSREAD,XTERM);
7939 LOP(OP_SYSWRITE,XTERM);
7944 TERM(sublex_start());
7965 LOP(OP_TRUNCATE,XTERM);
7977 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7979 pl_yylval.ival = CopLINE(PL_curcop);
7983 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7985 pl_yylval.ival = CopLINE(PL_curcop);
7989 LOP(OP_UNLINK,XTERM);
7995 LOP(OP_UNPACK,XTERM);
7998 LOP(OP_UTIME,XTERM);
8004 LOP(OP_UNSHIFT,XTERM);
8007 s = tokenize_use(1, s);
8017 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8019 pl_yylval.ival = CopLINE(PL_curcop);
8020 Perl_ck_warner_d(aTHX_
8021 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8022 "when is experimental");
8026 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8028 pl_yylval.ival = CopLINE(PL_curcop);
8032 PL_hints |= HINT_BLOCK_SCOPE;
8039 LOP(OP_WAITPID,XTERM);
8045 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8046 * we use the same number on EBCDIC */
8047 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8051 if (PL_expect == XOPERATOR) {
8052 if (*s == '=' && !PL_lex_allbrackets &&
8053 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8061 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8063 pl_yylval.ival = OP_XOR;
8072 Looks up an identifier in the pad or in a package
8075 PRIVATEREF if this is a lexical name.
8076 WORD if this belongs to a package.
8079 if we're in a my declaration
8080 croak if they tried to say my($foo::bar)
8081 build the ops for a my() declaration
8082 if it's an access to a my() variable
8083 build ops for access to a my() variable
8084 if in a dq string, and they've said @foo and we can't find @foo
8086 build ops for a bareword
8090 S_pending_ident(pTHX)
8093 const char pit = (char)pl_yylval.ival;
8094 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8095 /* All routes through this function want to know if there is a colon. */
8096 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8098 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8099 "### Pending identifier '%s'\n", PL_tokenbuf); });
8101 /* if we're in a my(), we can't allow dynamics here.
8102 $foo'bar has already been turned into $foo::bar, so
8103 just check for colons.
8105 if it's a legal name, the OP is a PADANY.
8108 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8110 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8111 "variable %s in \"our\"",
8112 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8113 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8117 /* PL_no_myglob is constant */
8118 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8119 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8120 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8121 UTF ? SVf_UTF8 : 0);
8125 pl_yylval.opval = newOP(OP_PADANY, 0);
8126 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8127 UTF ? SVf_UTF8 : 0);
8133 build the ops for accesses to a my() variable.
8138 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8139 UTF ? SVf_UTF8 : 0);
8140 if (tmp != NOT_IN_PAD) {
8141 /* might be an "our" variable" */
8142 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8143 /* build ops for a bareword */
8144 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8145 HEK * const stashname = HvNAME_HEK(stash);
8146 SV * const sym = newSVhek(stashname);
8147 sv_catpvs(sym, "::");
8148 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8149 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8150 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8154 ((PL_tokenbuf[0] == '$') ? SVt_PV
8155 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8160 pl_yylval.opval = newOP(OP_PADANY, 0);
8161 pl_yylval.opval->op_targ = tmp;
8167 Whine if they've said @foo in a doublequoted string,
8168 and @foo isn't a variable we can find in the symbol
8171 if (ckWARN(WARN_AMBIGUOUS) &&
8172 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8173 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8174 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8175 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8176 /* DO NOT warn for @- and @+ */
8177 && !( PL_tokenbuf[2] == '\0' &&
8178 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8181 /* Downgraded from fatal to warning 20000522 mjd */
8182 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8183 "Possible unintended interpolation of %"UTF8f
8185 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8189 /* build ops for a bareword */
8190 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8191 newSVpvn_flags(PL_tokenbuf + 1,
8193 UTF ? SVf_UTF8 : 0 ));
8194 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8196 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8197 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8198 | ( UTF ? SVf_UTF8 : 0 ),
8199 ((PL_tokenbuf[0] == '$') ? SVt_PV
8200 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8206 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8208 PERL_ARGS_ASSERT_CHECKCOMMA;
8210 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8211 if (ckWARN(WARN_SYNTAX)) {
8214 for (w = s+2; *w && level; w++) {
8222 /* the list of chars below is for end of statements or
8223 * block / parens, boolean operators (&&, ||, //) and branch
8224 * constructs (or, and, if, until, unless, while, err, for).
8225 * Not a very solid hack... */
8226 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8227 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8228 "%s (...) interpreted as function",name);
8231 while (s < PL_bufend && isSPACE(*s))
8235 while (s < PL_bufend && isSPACE(*s))
8237 if (isIDFIRST_lazy_if(s,UTF)) {
8238 const char * const w = s;
8239 s += UTF ? UTF8SKIP(s) : 1;
8240 while (isWORDCHAR_lazy_if(s,UTF))
8241 s += UTF ? UTF8SKIP(s) : 1;
8242 while (s < PL_bufend && isSPACE(*s))
8247 if (keyword(w, s - w, 0))
8250 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8251 if (gv && GvCVu(gv))
8255 Copy(w, tmpbuf+1, s - w, char);
8257 off = pad_findmy_pvn(tmpbuf, s-w+1, UTF ? SVf_UTF8 : 0);
8258 if (off != NOT_IN_PAD) return;
8260 Perl_croak(aTHX_ "No comma allowed after %s", what);
8265 /* S_new_constant(): do any overload::constant lookup.
8267 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8268 Best used as sv=new_constant(..., sv, ...).
8269 If s, pv are NULL, calls subroutine with one argument,
8270 and <type> is used with error messages only.
8271 <type> is assumed to be well formed UTF-8 */
8274 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8275 SV *sv, SV *pv, const char *type, STRLEN typelen)
8278 HV * table = GvHV(PL_hintgv); /* ^H */
8283 const char *why1 = "", *why2 = "", *why3 = "";
8285 PERL_ARGS_ASSERT_NEW_CONSTANT;
8286 /* We assume that this is true: */
8287 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8290 /* charnames doesn't work well if there have been errors found */
8291 if (PL_error_count > 0 && *key == 'c')
8293 SvREFCNT_dec_NN(sv);
8294 return &PL_sv_undef;
8297 sv_2mortal(sv); /* Parent created it permanently */
8299 || ! (PL_hints & HINT_LOCALIZE_HH)
8300 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8305 /* Here haven't found what we're looking for. If it is charnames,
8306 * perhaps it needs to be loaded. Try doing that before giving up */
8308 Perl_load_module(aTHX_
8310 newSVpvs("_charnames"),
8311 /* version parameter; no need to specify it, as if
8312 * we get too early a version, will fail anyway,
8313 * not being able to find '_charnames' */
8318 assert(sp == PL_stack_sp);
8319 table = GvHV(PL_hintgv);
8321 && (PL_hints & HINT_LOCALIZE_HH)
8322 && (cvp = hv_fetch(table, key, keylen, FALSE))
8328 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8329 msg = Perl_form(aTHX_
8330 "Constant(%.*s) unknown",
8331 (int)(type ? typelen : len),
8337 why3 = "} is not defined";
8340 msg = Perl_form(aTHX_
8341 /* The +3 is for '\N{'; -4 for that, plus '}' */
8342 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8346 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8347 (int)(type ? typelen : len),
8348 (type ? type: s), why1, why2, why3);
8351 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8352 return SvREFCNT_inc_simple_NN(sv);
8357 pv = newSVpvn_flags(s, len, SVs_TEMP);
8359 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8361 typesv = &PL_sv_undef;
8363 PUSHSTACKi(PERLSI_OVERLOAD);
8375 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8379 /* Check the eval first */
8380 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8382 const char * errstr;
8383 sv_catpvs(errsv, "Propagated");
8384 errstr = SvPV_const(errsv, errlen);
8385 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8387 res = SvREFCNT_inc_simple_NN(sv);
8391 SvREFCNT_inc_simple_void_NN(res);
8400 why1 = "Call to &{$^H{";
8402 why3 = "}} did not return a defined value";
8404 (void)sv_2mortal(sv);
8411 PERL_STATIC_INLINE void
8412 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8413 PERL_ARGS_ASSERT_PARSE_IDENT;
8417 Perl_croak(aTHX_ "%s", ident_too_long);
8418 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8419 /* The UTF-8 case must come first, otherwise things
8420 * like c\N{COMBINING TILDE} would start failing, as the
8421 * isWORDCHAR_A case below would gobble the 'c' up.
8424 char *t = *s + UTF8SKIP(*s);
8425 while (isIDCONT_utf8((U8*)t))
8427 if (*d + (t - *s) > e)
8428 Perl_croak(aTHX_ "%s", ident_too_long);
8429 Copy(*s, *d, t - *s, char);
8433 else if ( isWORDCHAR_A(**s) ) {
8436 } while (isWORDCHAR_A(**s) && *d < e);
8438 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8443 else if (allow_package && **s == ':' && (*s)[1] == ':'
8444 /* Disallow things like Foo::$bar. For the curious, this is
8445 * the code path that triggers the "Bad name after" warning
8446 * when looking for barewords.
8448 && (*s)[2] != '$') {
8458 /* Returns a NUL terminated string, with the length of the string written to
8462 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8465 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8466 bool is_utf8 = cBOOL(UTF);
8468 PERL_ARGS_ASSERT_SCAN_WORD;
8470 parse_ident(&s, &d, e, allow_package, is_utf8);
8477 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8479 I32 herelines = PL_parser->herelines;
8480 SSize_t bracket = -1;
8483 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8484 bool is_utf8 = cBOOL(UTF);
8485 I32 orig_copline = 0, tmp_copline = 0;
8487 PERL_ARGS_ASSERT_SCAN_IDENT;
8492 while (isDIGIT(*s)) {
8494 Perl_croak(aTHX_ "%s", ident_too_long);
8499 parse_ident(&s, &d, e, 1, is_utf8);
8504 /* Either a digit variable, or parse_ident() found an identifier
8505 (anything valid as a bareword), so job done and return. */
8506 if (PL_lex_state != LEX_NORMAL)
8507 PL_lex_state = LEX_INTERPENDMAYBE;
8510 if (*s == '$' && s[1] &&
8511 (isIDFIRST_lazy_if(s+1,is_utf8)
8512 || isDIGIT_A((U8)s[1])
8515 || strnEQ(s+1,"::",2)) )
8517 /* Dereferencing a value in a scalar variable.
8518 The alternatives are different syntaxes for a scalar variable.
8519 Using ' as a leading package separator isn't allowed. :: is. */
8522 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8524 bracket = s - SvPVX(PL_linestr);
8526 orig_copline = CopLINE(PL_curcop);
8527 if (s < PL_bufend && isSPACE(*s)) {
8532 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8533 * iff Unicode semantics are to be used. The legal ones are any of:
8535 * b) ASCII punctuation
8536 * c) When not under Unicode rules, any upper Latin1 character
8537 * d) \c?, \c\, \c^, \c_, and \cA..\cZ, minus the ones that have traditionally
8538 * been matched by \s on ASCII platforms. That is: \c?, plus 1-32, minus
8540 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
8541 || isDIGIT_A((U8)(d)) \
8542 || (!(u) && !isASCII((U8)(d))) \
8543 || ((((U8)(d)) < 32) \
8544 && (((((U8)(d)) >= 14) \
8545 || (((U8)(d)) <= 8 && (d) != 0) \
8546 || (((U8)(d)) == 13)))) \
8547 || (((U8)(d)) == toCTRL('?')))
8549 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
8551 if ( isCNTRL_A((U8)*s) ) {
8552 deprecate("literal control characters in variable names");
8556 const STRLEN skip = UTF8SKIP(s);
8559 for ( i = 0; i < skip; i++ )
8567 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8568 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8572 /* Warn about ambiguous code after unary operators if {...} notation isn't
8573 used. There's no difference in ambiguity; it's merely a heuristic
8574 about when not to warn. */
8575 else if (ck_uni && bracket == -1)
8577 if (bracket != -1) {
8578 /* If we were processing {...} notation then... */
8579 if (isIDFIRST_lazy_if(d,is_utf8)) {
8580 /* if it starts as a valid identifier, assume that it is one.
8581 (the later check for } being at the expected point will trap
8582 cases where this doesn't pan out.) */
8583 d += is_utf8 ? UTF8SKIP(d) : 1;
8584 parse_ident(&s, &d, e, 1, is_utf8);
8586 tmp_copline = CopLINE(PL_curcop);
8587 if (s < PL_bufend && isSPACE(*s)) {
8590 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8591 /* ${foo[0]} and ${foo{bar}} notation. */
8592 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8593 const char * const brack =
8595 ((*s == '[') ? "[...]" : "{...}");
8596 orig_copline = CopLINE(PL_curcop);
8597 CopLINE_set(PL_curcop, tmp_copline);
8598 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8599 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8600 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8601 funny, dest, brack, funny, dest, brack);
8602 CopLINE_set(PL_curcop, orig_copline);
8605 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8606 PL_lex_allbrackets++;
8610 /* Handle extended ${^Foo} variables
8611 * 1999-02-27 mjd-perl-patch@plover.com */
8612 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8616 while (isWORDCHAR(*s) && d < e) {
8620 Perl_croak(aTHX_ "%s", ident_too_long);
8625 tmp_copline = CopLINE(PL_curcop);
8626 if (s < PL_bufend && isSPACE(*s)) {
8630 /* Expect to find a closing } after consuming any trailing whitespace.
8634 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8635 PL_lex_state = LEX_INTERPEND;
8638 if (PL_lex_state == LEX_NORMAL) {
8639 if (ckWARN(WARN_AMBIGUOUS) &&
8640 (keyword(dest, d - dest, 0)
8641 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8643 SV *tmp = newSVpvn_flags( dest, d - dest,
8644 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8647 orig_copline = CopLINE(PL_curcop);
8648 CopLINE_set(PL_curcop, tmp_copline);
8649 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8650 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8651 funny, SVfARG(tmp), funny, SVfARG(tmp));
8652 CopLINE_set(PL_curcop, orig_copline);
8657 /* Didn't find the closing } at the point we expected, so restore
8658 state such that the next thing to process is the opening { and */
8659 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8660 CopLINE_set(PL_curcop, orig_copline);
8661 PL_parser->herelines = herelines;
8665 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8666 PL_lex_state = LEX_INTERPEND;
8671 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8673 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8674 * the parse starting at 's', based on the subset that are valid in this
8675 * context input to this routine in 'valid_flags'. Advances s. Returns
8676 * TRUE if the input should be treated as a valid flag, so the next char
8677 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
8678 * first call on the current regex. This routine will set it to any
8679 * charset modifier found. The caller shouldn't change it. This way,
8680 * another charset modifier encountered in the parse can be detected as an
8681 * error, as we have decided to allow only one */
8684 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8686 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8687 if (isWORDCHAR_lazy_if(*s, UTF)) {
8688 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8689 UTF ? SVf_UTF8 : 0);
8691 /* Pretend that it worked, so will continue processing before
8700 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8701 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8702 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8703 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8704 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8705 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8706 case LOCALE_PAT_MOD:
8708 goto multiple_charsets;
8710 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8713 case UNICODE_PAT_MOD:
8715 goto multiple_charsets;
8717 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8720 case ASCII_RESTRICT_PAT_MOD:
8722 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8726 /* Error if previous modifier wasn't an 'a', but if it was, see
8727 * if, and accept, a second occurrence (only) */
8729 || get_regex_charset(*pmfl)
8730 != REGEX_ASCII_RESTRICTED_CHARSET)
8732 goto multiple_charsets;
8734 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8738 case DEPENDS_PAT_MOD:
8740 goto multiple_charsets;
8742 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8751 if (*charset != c) {
8752 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8754 else if (c == 'a') {
8755 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8756 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8759 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8762 /* Pretend that it worked, so will continue processing before dieing */
8768 S_scan_pat(pTHX_ char *start, I32 type)
8772 const char * const valid_flags =
8773 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8774 char charset = '\0'; /* character set modifier */
8776 PERL_ARGS_ASSERT_SCAN_PAT;
8778 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8780 Perl_croak(aTHX_ "Search pattern not terminated");
8782 pm = (PMOP*)newPMOP(type, 0);
8783 if (PL_multi_open == '?') {
8784 /* This is the only point in the code that sets PMf_ONCE: */
8785 pm->op_pmflags |= PMf_ONCE;
8787 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8788 allows us to restrict the list needed by reset to just the ??
8790 assert(type != OP_TRANS);
8792 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8795 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8798 elements = mg->mg_len / sizeof(PMOP**);
8799 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8800 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8801 mg->mg_len = elements * sizeof(PMOP**);
8802 PmopSTASH_set(pm,PL_curstash);
8806 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8807 * anon CV. False positives like qr/[(?{]/ are harmless */
8809 if (type == OP_QR) {
8811 char *e, *p = SvPV(PL_lex_stuff, len);
8813 for (; p < e; p++) {
8814 if (p[0] == '(' && p[1] == '?'
8815 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8817 pm->op_pmflags |= PMf_HAS_CV;
8821 pm->op_pmflags |= PMf_IS_QR;
8824 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
8825 /* issue a warning if /c is specified,but /g is not */
8826 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8828 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8829 "Use of /c modifier is meaningless without /g" );
8832 PL_lex_op = (OP*)pm;
8833 pl_yylval.ival = OP_MATCH;
8838 S_scan_subst(pTHX_ char *start)
8845 char charset = '\0'; /* character set modifier */
8848 PERL_ARGS_ASSERT_SCAN_SUBST;
8850 pl_yylval.ival = OP_NULL;
8852 s = scan_str(start, TRUE, FALSE, FALSE, &t);
8855 Perl_croak(aTHX_ "Substitution pattern not terminated");
8859 first_start = PL_multi_start;
8860 first_line = CopLINE(PL_curcop);
8861 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8864 SvREFCNT_dec(PL_lex_stuff);
8865 PL_lex_stuff = NULL;
8867 Perl_croak(aTHX_ "Substitution replacement not terminated");
8869 PL_multi_start = first_start; /* so whole substitution is taken together */
8871 pm = (PMOP*)newPMOP(OP_SUBST, 0);
8875 if (*s == EXEC_PAT_MOD) {
8879 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
8885 if ((pm->op_pmflags & PMf_CONTINUE)) {
8886 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
8890 SV * const repl = newSVpvs("");
8893 pm->op_pmflags |= PMf_EVAL;
8896 sv_catpvs(repl, "eval ");
8898 sv_catpvs(repl, "do ");
8900 sv_catpvs(repl, "{");
8901 sv_catsv(repl, PL_sublex_info.repl);
8902 sv_catpvs(repl, "}");
8904 SvREFCNT_dec(PL_sublex_info.repl);
8905 PL_sublex_info.repl = repl;
8907 if (CopLINE(PL_curcop) != first_line) {
8908 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
8909 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
8910 CopLINE(PL_curcop) - first_line;
8911 CopLINE_set(PL_curcop, first_line);
8914 PL_lex_op = (OP*)pm;
8915 pl_yylval.ival = OP_SUBST;
8920 S_scan_trans(pTHX_ char *start)
8927 bool nondestruct = 0;
8930 PERL_ARGS_ASSERT_SCAN_TRANS;
8932 pl_yylval.ival = OP_NULL;
8934 s = scan_str(start,FALSE,FALSE,FALSE,&t);
8936 Perl_croak(aTHX_ "Transliteration pattern not terminated");
8940 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8943 SvREFCNT_dec(PL_lex_stuff);
8944 PL_lex_stuff = NULL;
8946 Perl_croak(aTHX_ "Transliteration replacement not terminated");
8949 complement = del = squash = 0;
8953 complement = OPpTRANS_COMPLEMENT;
8956 del = OPpTRANS_DELETE;
8959 squash = OPpTRANS_SQUASH;
8971 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
8972 o->op_private &= ~OPpTRANS_ALL;
8973 o->op_private |= del|squash|complement|
8974 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
8975 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
8978 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
8985 Takes a pointer to the first < in <<FOO.
8986 Returns a pointer to the byte following <<FOO.
8988 This function scans a heredoc, which involves different methods
8989 depending on whether we are in a string eval, quoted construct, etc.
8990 This is because PL_linestr could containing a single line of input, or
8991 a whole string being evalled, or the contents of the current quote-
8994 The two basic methods are:
8995 - Steal lines from the input stream
8996 - Scan the heredoc in PL_linestr and remove it therefrom
8998 In a file scope or filtered eval, the first method is used; in a
8999 string eval, the second.
9001 In a quote-like operator, we have to choose between the two,
9002 depending on where we can find a newline. We peek into outer lex-
9003 ing scopes until we find one with a newline in it. If we reach the
9004 outermost lexing scope and it is a file, we use the stream method.
9005 Otherwise it is treated as an eval.
9009 S_scan_heredoc(pTHX_ char *s)
9011 I32 op_type = OP_SCALAR;
9018 const bool infile = PL_rsfp || PL_parser->filtered;
9019 const line_t origline = CopLINE(PL_curcop);
9020 LEXSHARED *shared = PL_parser->lex_shared;
9022 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9025 d = PL_tokenbuf + 1;
9026 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9027 *PL_tokenbuf = '\n';
9029 while (SPACE_OR_TAB(*peek))
9031 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9034 s = delimcpy(d, e, s, PL_bufend, term, &len);
9036 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9042 /* <<\FOO is equivalent to <<'FOO' */
9046 if (!isWORDCHAR_lazy_if(s,UTF))
9047 deprecate("bare << to mean <<\"\"");
9048 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9053 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9054 Perl_croak(aTHX_ "Delimiter for here document is too long");
9057 len = d - PL_tokenbuf;
9059 #ifndef PERL_STRICT_CR
9060 d = strchr(s, '\r');
9062 char * const olds = s;
9064 while (s < PL_bufend) {
9070 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9079 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9084 tmpstr = newSV_type(SVt_PVIV);
9088 SvIV_set(tmpstr, -1);
9090 else if (term == '`') {
9091 op_type = OP_BACKTICK;
9092 SvIV_set(tmpstr, '\\');
9095 PL_multi_start = origline + 1 + PL_parser->herelines;
9096 PL_multi_open = PL_multi_close = '<';
9097 /* inside a string eval or quote-like operator */
9098 if (!infile || PL_lex_inwhat) {
9101 char * const olds = s;
9102 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9103 /* These two fields are not set until an inner lexing scope is
9104 entered. But we need them set here. */
9105 shared->ls_bufptr = s;
9106 shared->ls_linestr = PL_linestr;
9108 /* Look for a newline. If the current buffer does not have one,
9109 peek into the line buffer of the parent lexing scope, going
9110 up as many levels as necessary to find one with a newline
9113 while (!(s = (char *)memchr(
9114 (void *)shared->ls_bufptr, '\n',
9115 SvEND(shared->ls_linestr)-shared->ls_bufptr
9117 shared = shared->ls_prev;
9118 /* shared is only null if we have gone beyond the outermost
9119 lexing scope. In a file, we will have broken out of the
9120 loop in the previous iteration. In an eval, the string buf-
9121 fer ends with "\n;", so the while condition above will have
9122 evaluated to false. So shared can never be null. */
9124 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9125 most lexing scope. In a file, shared->ls_linestr at that
9126 level is just one line, so there is no body to steal. */
9127 if (infile && !shared->ls_prev) {
9133 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9136 linestr = shared->ls_linestr;
9137 bufend = SvEND(linestr);
9139 while (s < bufend - len + 1 &&
9140 memNE(s,PL_tokenbuf,len) ) {
9142 ++PL_parser->herelines;
9144 if (s >= bufend - len + 1) {
9147 sv_setpvn(tmpstr,d+1,s-d);
9149 /* the preceding stmt passes a newline */
9150 PL_parser->herelines++;
9152 /* s now points to the newline after the heredoc terminator.
9153 d points to the newline before the body of the heredoc.
9156 /* We are going to modify linestr in place here, so set
9157 aside copies of the string if necessary for re-evals or
9159 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9160 check shared->re_eval_str. */
9161 if (shared->re_eval_start || shared->re_eval_str) {
9162 /* Set aside the rest of the regexp */
9163 if (!shared->re_eval_str)
9164 shared->re_eval_str =
9165 newSVpvn(shared->re_eval_start,
9166 bufend - shared->re_eval_start);
9167 shared->re_eval_start -= s-d;
9169 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9170 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9171 cx->blk_eval.cur_text == linestr)
9173 cx->blk_eval.cur_text = newSVsv(linestr);
9174 SvSCREAM_on(cx->blk_eval.cur_text);
9176 /* Copy everything from s onwards back to d. */
9177 Move(s,d,bufend-s + 1,char);
9178 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9179 /* Setting PL_bufend only applies when we have not dug deeper
9180 into other scopes, because sublex_done sets PL_bufend to
9181 SvEND(PL_linestr). */
9182 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9189 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9190 term = PL_tokenbuf[1];
9192 linestr_save = PL_linestr; /* must restore this afterwards */
9193 d = s; /* and this */
9194 PL_linestr = newSVpvs("");
9195 PL_bufend = SvPVX(PL_linestr);
9197 PL_bufptr = PL_bufend;
9198 CopLINE_set(PL_curcop,
9199 origline + 1 + PL_parser->herelines);
9200 if (!lex_next_chunk(LEX_NO_TERM)
9201 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9202 SvREFCNT_dec(linestr_save);
9205 CopLINE_set(PL_curcop, origline);
9206 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9207 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9208 /* ^That should be enough to avoid this needing to grow: */
9209 sv_catpvs(PL_linestr, "\n\0");
9210 assert(s == SvPVX(PL_linestr));
9211 PL_bufend = SvEND(PL_linestr);
9214 PL_parser->herelines++;
9215 PL_last_lop = PL_last_uni = NULL;
9216 #ifndef PERL_STRICT_CR
9217 if (PL_bufend - PL_linestart >= 2) {
9218 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9219 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9221 PL_bufend[-2] = '\n';
9223 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9225 else if (PL_bufend[-1] == '\r')
9226 PL_bufend[-1] = '\n';
9228 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9229 PL_bufend[-1] = '\n';
9231 if (*s == term && PL_bufend-s >= len
9232 && memEQ(s,PL_tokenbuf + 1,len)) {
9233 SvREFCNT_dec(PL_linestr);
9234 PL_linestr = linestr_save;
9235 PL_linestart = SvPVX(linestr_save);
9236 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9241 sv_catsv(tmpstr,PL_linestr);
9245 PL_multi_end = origline + PL_parser->herelines;
9246 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9247 SvPV_shrink_to_cur(tmpstr);
9250 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9252 else if (PL_encoding)
9253 sv_recode_to_utf8(tmpstr, PL_encoding);
9255 PL_lex_stuff = tmpstr;
9256 pl_yylval.ival = op_type;
9260 SvREFCNT_dec(tmpstr);
9261 CopLINE_set(PL_curcop, origline);
9262 missingterm(PL_tokenbuf + 1);
9266 takes: current position in input buffer
9267 returns: new position in input buffer
9268 side-effects: pl_yylval and lex_op are set.
9273 <FH> read from filehandle
9274 <pkg::FH> read from package qualified filehandle
9275 <pkg'FH> read from package qualified filehandle
9276 <$fh> read from filehandle in $fh
9282 S_scan_inputsymbol(pTHX_ char *start)
9284 char *s = start; /* current position in buffer */
9287 char *d = PL_tokenbuf; /* start of temp holding space */
9288 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9290 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9292 end = strchr(s, '\n');
9295 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9297 /* die if we didn't have space for the contents of the <>,
9298 or if it didn't end, or if we see a newline
9301 if (len >= (I32)sizeof PL_tokenbuf)
9302 Perl_croak(aTHX_ "Excessively long <> operator");
9304 Perl_croak(aTHX_ "Unterminated <> operator");
9309 Remember, only scalar variables are interpreted as filehandles by
9310 this code. Anything more complex (e.g., <$fh{$num}>) will be
9311 treated as a glob() call.
9312 This code makes use of the fact that except for the $ at the front,
9313 a scalar variable and a filehandle look the same.
9315 if (*d == '$' && d[1]) d++;
9317 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9318 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9319 d += UTF ? UTF8SKIP(d) : 1;
9321 /* If we've tried to read what we allow filehandles to look like, and
9322 there's still text left, then it must be a glob() and not a getline.
9323 Use scan_str to pull out the stuff between the <> and treat it
9324 as nothing more than a string.
9327 if (d - PL_tokenbuf != len) {
9328 pl_yylval.ival = OP_GLOB;
9329 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9331 Perl_croak(aTHX_ "Glob not terminated");
9335 bool readline_overriden = FALSE;
9337 /* we're in a filehandle read situation */
9340 /* turn <> into <ARGV> */
9342 Copy("ARGV",d,5,char);
9344 /* Check whether readline() is overriden */
9345 if ((gv_readline = gv_override("readline",8)))
9346 readline_overriden = TRUE;
9348 /* if <$fh>, create the ops to turn the variable into a
9352 /* try to find it in the pad for this block, otherwise find
9353 add symbol table ops
9355 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9356 if (tmp != NOT_IN_PAD) {
9357 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9358 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9359 HEK * const stashname = HvNAME_HEK(stash);
9360 SV * const sym = sv_2mortal(newSVhek(stashname));
9361 sv_catpvs(sym, "::");
9367 OP * const o = newOP(OP_PADSV, 0);
9369 PL_lex_op = readline_overriden
9370 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9371 op_append_elem(OP_LIST, o,
9372 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9373 : (OP*)newUNOP(OP_READLINE, 0, o);
9381 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
9383 PL_lex_op = readline_overriden
9384 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9385 op_append_elem(OP_LIST,
9386 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9387 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9388 : (OP*)newUNOP(OP_READLINE, 0,
9389 newUNOP(OP_RV2SV, 0,
9390 newGVOP(OP_GV, 0, gv)));
9392 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9393 pl_yylval.ival = OP_NULL;
9396 /* If it's none of the above, it must be a literal filehandle
9397 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9399 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9400 PL_lex_op = readline_overriden
9401 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9402 op_append_elem(OP_LIST,
9403 newGVOP(OP_GV, 0, gv),
9404 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9405 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9406 pl_yylval.ival = OP_NULL;
9416 start position in buffer
9417 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9418 only if they are of the open/close form
9419 keep_delims preserve the delimiters around the string
9420 re_reparse compiling a run-time /(?{})/:
9421 collapse // to /, and skip encoding src
9422 delimp if non-null, this is set to the position of
9423 the closing delimiter, or just after it if
9424 the closing and opening delimiters differ
9425 (i.e., the opening delimiter of a substitu-
9427 returns: position to continue reading from buffer
9428 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9429 updates the read buffer.
9431 This subroutine pulls a string out of the input. It is called for:
9432 q single quotes q(literal text)
9433 ' single quotes 'literal text'
9434 qq double quotes qq(interpolate $here please)
9435 " double quotes "interpolate $here please"
9436 qx backticks qx(/bin/ls -l)
9437 ` backticks `/bin/ls -l`
9438 qw quote words @EXPORT_OK = qw( func() $spam )
9439 m// regexp match m/this/
9440 s/// regexp substitute s/this/that/
9441 tr/// string transliterate tr/this/that/
9442 y/// string transliterate y/this/that/
9443 ($*@) sub prototypes sub foo ($)
9444 (stuff) sub attr parameters sub foo : attr(stuff)
9445 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9447 In most of these cases (all but <>, patterns and transliterate)
9448 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9449 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9450 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9453 It skips whitespace before the string starts, and treats the first
9454 character as the delimiter. If the delimiter is one of ([{< then
9455 the corresponding "close" character )]}> is used as the closing
9456 delimiter. It allows quoting of delimiters, and if the string has
9457 balanced delimiters ([{<>}]) it allows nesting.
9459 On success, the SV with the resulting string is put into lex_stuff or,
9460 if that is already non-NULL, into lex_repl. The second case occurs only
9461 when parsing the RHS of the special constructs s/// and tr/// (y///).
9462 For convenience, the terminating delimiter character is stuffed into
9467 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9471 SV *sv; /* scalar value: string */
9472 const char *tmps; /* temp string, used for delimiter matching */
9473 char *s = start; /* current position in the buffer */
9474 char term; /* terminating character */
9475 char *to; /* current position in the sv's data */
9476 I32 brackets = 1; /* bracket nesting level */
9477 bool has_utf8 = FALSE; /* is there any utf8 content? */
9478 I32 termcode; /* terminating char. code */
9479 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9480 STRLEN termlen; /* length of terminating string */
9481 int last_off = 0; /* last position for nesting bracket */
9484 PERL_ARGS_ASSERT_SCAN_STR;
9486 /* skip space before the delimiter */
9491 /* mark where we are, in case we need to report errors */
9494 /* after skipping whitespace, the next character is the terminator */
9497 termcode = termstr[0] = term;
9501 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9502 Copy(s, termstr, termlen, U8);
9503 if (!UTF8_IS_INVARIANT(term))
9507 /* mark where we are */
9508 PL_multi_start = CopLINE(PL_curcop);
9509 PL_multi_open = term;
9510 herelines = PL_parser->herelines;
9512 /* find corresponding closing delimiter */
9513 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9514 termcode = termstr[0] = term = tmps[5];
9516 PL_multi_close = term;
9518 if (PL_multi_open == PL_multi_close) {
9519 keep_bracketed_quoted = FALSE;
9522 /* create a new SV to hold the contents. 79 is the SV's initial length.
9523 What a random number. */
9524 sv = newSV_type(SVt_PVIV);
9526 SvIV_set(sv, termcode);
9527 (void)SvPOK_only(sv); /* validate pointer */
9529 /* move past delimiter and try to read a complete string */
9531 sv_catpvn(sv, s, termlen);
9534 if (PL_encoding && !UTF && !re_reparse) {
9538 int offset = s - SvPVX_const(PL_linestr);
9539 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9540 &offset, (char*)termstr, termlen);
9544 if (SvIsCOW(PL_linestr)) {
9545 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9546 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9547 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9548 char *buf = SvPVX(PL_linestr);
9549 bufend_pos = PL_parser->bufend - buf;
9550 bufptr_pos = PL_parser->bufptr - buf;
9551 oldbufptr_pos = PL_parser->oldbufptr - buf;
9552 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9553 linestart_pos = PL_parser->linestart - buf;
9554 last_uni_pos = PL_parser->last_uni
9555 ? PL_parser->last_uni - buf
9557 last_lop_pos = PL_parser->last_lop
9558 ? PL_parser->last_lop - buf
9561 PL_parser->lex_shared->re_eval_start ?
9562 PL_parser->lex_shared->re_eval_start - buf : 0;
9565 sv_force_normal(PL_linestr);
9567 buf = SvPVX(PL_linestr);
9568 PL_parser->bufend = buf + bufend_pos;
9569 PL_parser->bufptr = buf + bufptr_pos;
9570 PL_parser->oldbufptr = buf + oldbufptr_pos;
9571 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9572 PL_parser->linestart = buf + linestart_pos;
9573 if (PL_parser->last_uni)
9574 PL_parser->last_uni = buf + last_uni_pos;
9575 if (PL_parser->last_lop)
9576 PL_parser->last_lop = buf + last_lop_pos;
9577 if (PL_parser->lex_shared->re_eval_start)
9578 PL_parser->lex_shared->re_eval_start =
9579 buf + re_eval_start_pos;
9582 ns = SvPVX_const(PL_linestr) + offset;
9583 svlast = SvEND(sv) - 1;
9585 for (; s < ns; s++) {
9586 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9587 COPLINE_INC_WITH_HERELINES;
9590 goto read_more_line;
9592 /* handle quoted delimiters */
9593 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9595 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9597 if ((svlast-1 - t) % 2) {
9598 if (!keep_bracketed_quoted) {
9601 SvCUR_set(sv, SvCUR(sv) - 1);
9606 if (PL_multi_open == PL_multi_close) {
9612 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9613 /* At here, all closes are "was quoted" one,
9614 so we don't check PL_multi_close. */
9616 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9621 else if (*t == PL_multi_open)
9629 SvCUR_set(sv, w - SvPVX_const(sv));
9631 last_off = w - SvPVX(sv);
9632 if (--brackets <= 0)
9638 SvCUR_set(sv, SvCUR(sv) - 1);
9644 /* extend sv if need be */
9645 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9646 /* set 'to' to the next character in the sv's string */
9647 to = SvPVX(sv)+SvCUR(sv);
9649 /* if open delimiter is the close delimiter read unbridle */
9650 if (PL_multi_open == PL_multi_close) {
9651 for (; s < PL_bufend; s++,to++) {
9652 /* embedded newlines increment the current line number */
9653 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9654 COPLINE_INC_WITH_HERELINES;
9655 /* handle quoted delimiters */
9656 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9657 if (!keep_bracketed_quoted
9659 || (re_reparse && s[1] == '\\'))
9662 else /* any other quotes are simply copied straight through */
9665 /* terminate when run out of buffer (the for() condition), or
9666 have found the terminator */
9667 else if (*s == term) {
9670 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9673 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9679 /* if the terminator isn't the same as the start character (e.g.,
9680 matched brackets), we have to allow more in the quoting, and
9681 be prepared for nested brackets.
9684 /* read until we run out of string, or we find the terminator */
9685 for (; s < PL_bufend; s++,to++) {
9686 /* embedded newlines increment the line count */
9687 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9688 COPLINE_INC_WITH_HERELINES;
9689 /* backslashes can escape the open or closing characters */
9690 if (*s == '\\' && s+1 < PL_bufend) {
9691 if (!keep_bracketed_quoted &&
9692 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9699 /* allow nested opens and closes */
9700 else if (*s == PL_multi_close && --brackets <= 0)
9702 else if (*s == PL_multi_open)
9704 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9709 /* terminate the copied string and update the sv's end-of-string */
9711 SvCUR_set(sv, to - SvPVX_const(sv));
9714 * this next chunk reads more into the buffer if we're not done yet
9718 break; /* handle case where we are done yet :-) */
9720 #ifndef PERL_STRICT_CR
9721 if (to - SvPVX_const(sv) >= 2) {
9722 if ((to[-2] == '\r' && to[-1] == '\n') ||
9723 (to[-2] == '\n' && to[-1] == '\r'))
9727 SvCUR_set(sv, to - SvPVX_const(sv));
9729 else if (to[-1] == '\r')
9732 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9737 /* if we're out of file, or a read fails, bail and reset the current
9738 line marker so we can report where the unterminated string began
9740 COPLINE_INC_WITH_HERELINES;
9741 PL_bufptr = PL_bufend;
9742 if (!lex_next_chunk(0)) {
9744 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9750 /* at this point, we have successfully read the delimited string */
9752 if (!PL_encoding || UTF || re_reparse) {
9755 sv_catpvn(sv, s, termlen);
9758 if (has_utf8 || (PL_encoding && !re_reparse))
9761 PL_multi_end = CopLINE(PL_curcop);
9762 CopLINE_set(PL_curcop, PL_multi_start);
9763 PL_parser->herelines = herelines;
9765 /* if we allocated too much space, give some back */
9766 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9767 SvLEN_set(sv, SvCUR(sv) + 1);
9768 SvPV_renew(sv, SvLEN(sv));
9771 /* decide whether this is the first or second quoted string we've read
9776 PL_sublex_info.repl = sv;
9779 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9785 takes: pointer to position in buffer
9786 returns: pointer to new position in buffer
9787 side-effects: builds ops for the constant in pl_yylval.op
9789 Read a number in any of the formats that Perl accepts:
9791 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9792 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9793 0b[01](_?[01])* binary integers
9794 0[0-7](_?[0-7])* octal integers
9795 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
9796 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
9798 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9801 If it reads a number without a decimal point or an exponent, it will
9802 try converting the number to an integer and see if it can do so
9803 without loss of precision.
9807 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9809 const char *s = start; /* current position in buffer */
9810 char *d; /* destination in temp buffer */
9811 char *e; /* end of temp buffer */
9812 NV nv; /* number read, as a double */
9813 SV *sv = NULL; /* place to put the converted number */
9814 bool floatit; /* boolean: int or float? */
9815 const char *lastub = NULL; /* position of last underbar */
9816 static const char* const number_too_long = "Number too long";
9817 /* Hexadecimal floating point.
9819 * In many places (where we have quads and NV is IEEE 754 double)
9820 * we can fit the mantissa bits of a NV into an unsigned quad.
9821 * (Note that UVs might not be quads even when we have quads.)
9822 * This will not work everywhere, though (either no quads, or
9823 * using long doubles), in which case we have to resort to NV,
9824 * which will probably mean horrible loss of precision due to
9825 * multiple fp operations. */
9828 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
9829 # define HEXFP_UQUAD
9830 Uquad_t hexfp_uquad = 0;
9831 int hexfp_frac_bits = 0;
9836 NV hexfp_mult = 1.0;
9837 UV high_non_zero = 0; /* highest digit */
9839 PERL_ARGS_ASSERT_SCAN_NUM;
9841 /* We use the first character to decide what type of number this is */
9845 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
9847 /* if it starts with a 0, it could be an octal number, a decimal in
9848 0.13 disguise, or a hexadecimal number, or a binary number. */
9852 u holds the "number so far"
9853 shift the power of 2 of the base
9854 (hex == 4, octal == 3, binary == 1)
9855 overflowed was the number more than we can hold?
9857 Shift is used when we add a digit. It also serves as an "are
9858 we in octal/hex/binary?" indicator to disallow hex characters
9864 bool overflowed = FALSE;
9865 bool just_zero = TRUE; /* just plain 0 or binary number? */
9866 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
9867 static const char* const bases[5] =
9868 { "", "binary", "", "octal", "hexadecimal" };
9869 static const char* const Bases[5] =
9870 { "", "Binary", "", "Octal", "Hexadecimal" };
9871 static const char* const maxima[5] =
9873 "0b11111111111111111111111111111111",
9877 const char *base, *Base, *max;
9880 if (isALPHA_FOLD_EQ(s[1], 'x')) {
9884 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
9889 /* check for a decimal in disguise */
9890 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
9892 /* so it must be octal */
9899 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9900 "Misplaced _ in number");
9904 base = bases[shift];
9905 Base = Bases[shift];
9906 max = maxima[shift];
9908 /* read the rest of the number */
9910 /* x is used in the overflow test,
9911 b is the digit we're adding on. */
9916 /* if we don't mention it, we're done */
9920 /* _ are ignored -- but warned about if consecutive */
9922 if (lastub && s == lastub + 1)
9923 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9924 "Misplaced _ in number");
9928 /* 8 and 9 are not octal */
9931 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
9935 case '2': case '3': case '4':
9936 case '5': case '6': case '7':
9938 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
9942 b = *s++ & 15; /* ASCII digit -> value of digit */
9946 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
9947 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
9948 /* make sure they said 0x */
9953 /* Prepare to put the digit we have onto the end
9954 of the number so far. We check for overflows.
9960 x = u << shift; /* make room for the digit */
9962 total_bits += shift;
9964 if ((x >> shift) != u
9965 && !(PL_hints & HINT_NEW_BINARY)) {
9968 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
9969 "Integer overflow in %s number",
9972 u = x | b; /* add the digit to the end */
9975 n *= nvshift[shift];
9976 /* If an NV has not enough bits in its
9977 * mantissa to represent an UV this summing of
9978 * small low-order numbers is a waste of time
9979 * (because the NV cannot preserve the
9980 * low-order bits anyway): we could just
9981 * remember when did we overflow and in the
9982 * end just multiply n by the right
9987 if (high_non_zero == 0 && b > 0)
9990 /* this could be hexfp, but peek ahead
9991 * to avoid matching ".." */
9992 if (UNLIKELY(HEXFP_PEEK(s))) {
10000 /* if we get here, we had success: make a scalar value from
10005 /* final misplaced underbar check */
10006 if (s[-1] == '_') {
10007 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10010 if (UNLIKELY(HEXFP_PEEK(s))) {
10011 /* Do sloppy (on the underbars) but quick detection
10012 * (and value construction) for hexfp, the decimal
10013 * detection will shortly be more thorough with the
10014 * underbar checks. */
10018 #else /* HEXFP_NV */
10023 NV mult = 1 / 16.0;
10026 while (isXDIGIT(*h) || *h == '_') {
10027 if (isXDIGIT(*h)) {
10028 U8 b = XDIGIT_VALUE(*h);
10029 total_bits += shift;
10031 hexfp_uquad <<= shift;
10033 hexfp_frac_bits += shift;
10034 #else /* HEXFP_NV */
10035 hexfp_nv += b * mult;
10043 if (total_bits >= 4) {
10044 if (high_non_zero < 0x8)
10046 if (high_non_zero < 0x4)
10048 if (high_non_zero < 0x2)
10052 if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
10053 bool negexp = FALSE;
10057 else if (*h == '-') {
10063 while (isDIGIT(*h) || *h == '_') {
10066 hexfp_exp += *h - '0';
10069 -hexfp_exp < NV_MIN_EXP - 1) {
10070 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10071 "Hexadecimal float: exponent underflow");
10078 hexfp_exp > NV_MAX_EXP - 1) {
10079 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10080 "Hexadecimal float: exponent overflow");
10089 hexfp_exp = -hexfp_exp;
10091 hexfp_exp -= hexfp_frac_bits;
10093 hexfp_mult = pow(2.0, hexfp_exp);
10101 if (n > 4294967295.0)
10102 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10103 "%s number > %s non-portable",
10109 if (u > 0xffffffff)
10110 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10111 "%s number > %s non-portable",
10116 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10117 sv = new_constant(start, s - start, "integer",
10118 sv, NULL, NULL, 0);
10119 else if (PL_hints & HINT_NEW_BINARY)
10120 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10125 handle decimal numbers.
10126 we're also sent here when we read a 0 as the first digit
10128 case '1': case '2': case '3': case '4': case '5':
10129 case '6': case '7': case '8': case '9': case '.':
10132 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10141 /* read next group of digits and _ and copy into d */
10142 while (isDIGIT(*s) || *s == '_' ||
10143 UNLIKELY(hexfp && isXDIGIT(*s))) {
10144 /* skip underscores, checking for misplaced ones
10148 if (lastub && s == lastub + 1)
10149 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10150 "Misplaced _ in number");
10154 /* check for end of fixed-length buffer */
10156 Perl_croak(aTHX_ "%s", number_too_long);
10157 /* if we're ok, copy the character */
10162 /* final misplaced underbar check */
10163 if (lastub && s == lastub + 1) {
10164 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10167 /* read a decimal portion if there is one. avoid
10168 3..5 being interpreted as the number 3. followed
10171 if (*s == '.' && s[1] != '.') {
10176 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10177 "Misplaced _ in number");
10181 /* copy, ignoring underbars, until we run out of digits.
10183 for (; isDIGIT(*s) || *s == '_' ||
10184 UNLIKELY(hexfp && isXDIGIT(*s));
10186 /* fixed length buffer check */
10188 Perl_croak(aTHX_ "%s", number_too_long);
10190 if (lastub && s == lastub + 1)
10191 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10192 "Misplaced _ in number");
10198 /* fractional part ending in underbar? */
10199 if (s[-1] == '_') {
10200 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10201 "Misplaced _ in number");
10203 if (*s == '.' && isDIGIT(s[1])) {
10204 /* oops, it's really a v-string, but without the "v" */
10210 /* read exponent part, if present */
10211 if ((isALPHA_FOLD_EQ(*s, 'e')
10212 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
10213 && strchr("+-0123456789_", s[1]))
10217 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
10218 ditto for p (hexfloats) */
10219 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
10220 /* At least some Mach atof()s don't grok 'E' */
10223 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
10230 /* stray preinitial _ */
10232 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10233 "Misplaced _ in number");
10237 /* allow positive or negative exponent */
10238 if (*s == '+' || *s == '-')
10241 /* stray initial _ */
10243 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10244 "Misplaced _ in number");
10248 /* read digits of exponent */
10249 while (isDIGIT(*s) || *s == '_') {
10252 Perl_croak(aTHX_ "%s", number_too_long);
10256 if (((lastub && s == lastub + 1) ||
10257 (!isDIGIT(s[1]) && s[1] != '_')))
10258 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10259 "Misplaced _ in number");
10267 We try to do an integer conversion first if no characters
10268 indicating "float" have been found.
10273 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10275 if (flags == IS_NUMBER_IN_UV) {
10277 sv = newSViv(uv); /* Prefer IVs over UVs. */
10280 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10281 if (uv <= (UV) IV_MIN)
10282 sv = newSViv(-(IV)uv);
10289 STORE_NUMERIC_LOCAL_SET_STANDARD();
10290 /* terminate the string */
10292 if (UNLIKELY(hexfp)) {
10293 # ifdef NV_MANT_DIG
10294 if (total_bits > NV_MANT_DIG)
10295 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
10296 "Hexadecimal float: mantissa overflow");
10299 nv = hexfp_uquad * hexfp_mult;
10300 #else /* HEXFP_NV */
10301 nv = hexfp_nv * hexfp_mult;
10304 nv = Atof(PL_tokenbuf);
10306 RESTORE_NUMERIC_LOCAL();
10311 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10312 const char *const key = floatit ? "float" : "integer";
10313 const STRLEN keylen = floatit ? 5 : 7;
10314 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10315 key, keylen, sv, NULL, NULL, 0);
10319 /* if it starts with a v, it could be a v-string */
10322 sv = newSV(5); /* preallocate storage space */
10323 ENTER_with_name("scan_vstring");
10325 s = scan_vstring(s, PL_bufend, sv);
10326 SvREFCNT_inc_simple_void_NN(sv);
10327 LEAVE_with_name("scan_vstring");
10331 /* make the op for the constant and return */
10334 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10336 lvalp->opval = NULL;
10342 S_scan_formline(pTHX_ char *s)
10346 SV * const stuff = newSVpvs("");
10347 bool needargs = FALSE;
10348 bool eofmt = FALSE;
10350 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10352 while (!needargs) {
10355 #ifdef PERL_STRICT_CR
10356 while (SPACE_OR_TAB(*t))
10359 while (SPACE_OR_TAB(*t) || *t == '\r')
10362 if (*t == '\n' || t == PL_bufend) {
10367 eol = (char *) memchr(s,'\n',PL_bufend-s);
10371 for (t = s; t < eol; t++) {
10372 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10374 goto enough; /* ~~ must be first line in formline */
10376 if (*t == '@' || *t == '^')
10380 sv_catpvn(stuff, s, eol-s);
10381 #ifndef PERL_STRICT_CR
10382 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10383 char *end = SvPVX(stuff) + SvCUR(stuff);
10386 SvCUR_set(stuff, SvCUR(stuff) - 1);
10394 if ((PL_rsfp || PL_parser->filtered)
10395 && PL_parser->form_lex_state == LEX_NORMAL) {
10397 PL_bufptr = PL_bufend;
10398 COPLINE_INC_WITH_HERELINES;
10399 got_some = lex_next_chunk(0);
10400 CopLINE_dec(PL_curcop);
10408 if (!SvCUR(stuff) || needargs)
10409 PL_lex_state = PL_parser->form_lex_state;
10410 if (SvCUR(stuff)) {
10411 PL_expect = XSTATE;
10413 const char *s2 = s;
10414 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10418 PL_expect = XTERMBLOCK;
10419 NEXTVAL_NEXTTOKE.ival = 0;
10422 NEXTVAL_NEXTTOKE.ival = 0;
10423 force_next(FORMLBRACK);
10426 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10428 else if (PL_encoding)
10429 sv_recode_to_utf8(stuff, PL_encoding);
10431 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10435 SvREFCNT_dec(stuff);
10437 PL_lex_formbrack = 0;
10443 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10445 const I32 oldsavestack_ix = PL_savestack_ix;
10446 CV* const outsidecv = PL_compcv;
10448 SAVEI32(PL_subline);
10449 save_item(PL_subname);
10450 SAVESPTR(PL_compcv);
10452 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10453 CvFLAGS(PL_compcv) |= flags;
10455 PL_subline = CopLINE(PL_curcop);
10456 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10457 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10458 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10459 if (outsidecv && CvPADLIST(outsidecv))
10460 CvPADLIST(PL_compcv)->xpadl_outid =
10461 PadlistNAMES(CvPADLIST(outsidecv));
10463 return oldsavestack_ix;
10467 S_yywarn(pTHX_ const char *const s, U32 flags)
10469 PERL_ARGS_ASSERT_YYWARN;
10471 PL_in_eval |= EVAL_WARNONLY;
10472 yyerror_pv(s, flags);
10473 PL_in_eval &= ~EVAL_WARNONLY;
10478 Perl_yyerror(pTHX_ const char *const s)
10480 PERL_ARGS_ASSERT_YYERROR;
10481 return yyerror_pvn(s, strlen(s), 0);
10485 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10487 PERL_ARGS_ASSERT_YYERROR_PV;
10488 return yyerror_pvn(s, strlen(s), flags);
10492 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10494 const char *context = NULL;
10497 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10498 int yychar = PL_parser->yychar;
10500 PERL_ARGS_ASSERT_YYERROR_PVN;
10502 if (!yychar || (yychar == ';' && !PL_rsfp))
10503 sv_catpvs(where_sv, "at EOF");
10504 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10505 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10506 PL_oldbufptr != PL_bufptr) {
10509 The code below is removed for NetWare because it abends/crashes on NetWare
10510 when the script has error such as not having the closing quotes like:
10511 if ($var eq "value)
10512 Checking of white spaces is anyway done in NetWare code.
10515 while (isSPACE(*PL_oldoldbufptr))
10518 context = PL_oldoldbufptr;
10519 contlen = PL_bufptr - PL_oldoldbufptr;
10521 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10522 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10525 The code below is removed for NetWare because it abends/crashes on NetWare
10526 when the script has error such as not having the closing quotes like:
10527 if ($var eq "value)
10528 Checking of white spaces is anyway done in NetWare code.
10531 while (isSPACE(*PL_oldbufptr))
10534 context = PL_oldbufptr;
10535 contlen = PL_bufptr - PL_oldbufptr;
10537 else if (yychar > 255)
10538 sv_catpvs(where_sv, "next token ???");
10539 else if (yychar == -2) { /* YYEMPTY */
10540 if (PL_lex_state == LEX_NORMAL ||
10541 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10542 sv_catpvs(where_sv, "at end of line");
10543 else if (PL_lex_inpat)
10544 sv_catpvs(where_sv, "within pattern");
10546 sv_catpvs(where_sv, "within string");
10549 sv_catpvs(where_sv, "next char ");
10551 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10552 else if (isPRINT_LC(yychar)) {
10553 const char string = yychar;
10554 sv_catpvn(where_sv, &string, 1);
10557 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10559 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10560 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10561 OutCopFILE(PL_curcop),
10562 (IV)(PL_parser->preambling == NOLINE
10563 ? CopLINE(PL_curcop)
10564 : PL_parser->preambling));
10566 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10567 UTF8fARG(UTF, contlen, context));
10569 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10570 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10571 Perl_sv_catpvf(aTHX_ msg,
10572 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10573 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10576 if (PL_in_eval & EVAL_WARNONLY) {
10577 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10581 if (PL_error_count >= 10) {
10583 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10584 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10585 SVfARG(errsv), OutCopFILE(PL_curcop));
10587 Perl_croak(aTHX_ "%s has too many errors.\n",
10588 OutCopFILE(PL_curcop));
10591 PL_in_my_stash = NULL;
10596 S_swallow_bom(pTHX_ U8 *s)
10598 const STRLEN slen = SvCUR(PL_linestr);
10600 PERL_ARGS_ASSERT_SWALLOW_BOM;
10604 if (s[1] == 0xFE) {
10605 /* UTF-16 little-endian? (or UTF-32LE?) */
10606 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10607 /* diag_listed_as: Unsupported script encoding %s */
10608 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10609 #ifndef PERL_NO_UTF16_FILTER
10610 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10612 if (PL_bufend > (char*)s) {
10613 s = add_utf16_textfilter(s, TRUE);
10616 /* diag_listed_as: Unsupported script encoding %s */
10617 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10622 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10623 #ifndef PERL_NO_UTF16_FILTER
10624 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10626 if (PL_bufend > (char *)s) {
10627 s = add_utf16_textfilter(s, FALSE);
10630 /* diag_listed_as: Unsupported script encoding %s */
10631 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10635 case BOM_UTF8_FIRST_BYTE: {
10636 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10637 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10638 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10639 s += len + 1; /* UTF-8 */
10646 if (s[2] == 0xFE && s[3] == 0xFF) {
10647 /* UTF-32 big-endian */
10648 /* diag_listed_as: Unsupported script encoding %s */
10649 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10652 else if (s[2] == 0 && s[3] != 0) {
10655 * are a good indicator of UTF-16BE. */
10656 #ifndef PERL_NO_UTF16_FILTER
10657 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10658 s = add_utf16_textfilter(s, FALSE);
10660 /* diag_listed_as: Unsupported script encoding %s */
10661 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10668 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10671 * are a good indicator of UTF-16LE. */
10672 #ifndef PERL_NO_UTF16_FILTER
10673 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10674 s = add_utf16_textfilter(s, TRUE);
10676 /* diag_listed_as: Unsupported script encoding %s */
10677 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10685 #ifndef PERL_NO_UTF16_FILTER
10687 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10689 SV *const filter = FILTER_DATA(idx);
10690 /* We re-use this each time round, throwing the contents away before we
10692 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10693 SV *const utf8_buffer = filter;
10694 IV status = IoPAGE(filter);
10695 const bool reverse = cBOOL(IoLINES(filter));
10698 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10700 /* As we're automatically added, at the lowest level, and hence only called
10701 from this file, we can be sure that we're not called in block mode. Hence
10702 don't bother writing code to deal with block mode. */
10704 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10707 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10709 DEBUG_P(PerlIO_printf(Perl_debug_log,
10710 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10711 FPTR2DPTR(void *, S_utf16_textfilter),
10712 reverse ? 'l' : 'b', idx, maxlen, status,
10713 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10720 /* First, look in our buffer of existing UTF-8 data: */
10721 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10725 } else if (status == 0) {
10727 IoPAGE(filter) = 0;
10728 nl = SvEND(utf8_buffer);
10731 STRLEN got = nl - SvPVX(utf8_buffer);
10732 /* Did we have anything to append? */
10734 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10735 /* Everything else in this code works just fine if SVp_POK isn't
10736 set. This, however, needs it, and we need it to work, else
10737 we loop infinitely because the buffer is never consumed. */
10738 sv_chop(utf8_buffer, nl);
10742 /* OK, not a complete line there, so need to read some more UTF-16.
10743 Read an extra octect if the buffer currently has an odd number. */
10747 if (SvCUR(utf16_buffer) >= 2) {
10748 /* Location of the high octet of the last complete code point.
10749 Gosh, UTF-16 is a pain. All the benefits of variable length,
10750 *coupled* with all the benefits of partial reads and
10752 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10753 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10755 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10759 /* We have the first half of a surrogate. Read more. */
10760 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10763 status = FILTER_READ(idx + 1, utf16_buffer,
10764 160 + (SvCUR(utf16_buffer) & 1));
10765 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10766 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10769 IoPAGE(filter) = status;
10774 chars = SvCUR(utf16_buffer) >> 1;
10775 have = SvCUR(utf8_buffer);
10776 SvGROW(utf8_buffer, have + chars * 3 + 1);
10779 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10780 (U8*)SvPVX_const(utf8_buffer) + have,
10781 chars * 2, &newlen);
10783 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10784 (U8*)SvPVX_const(utf8_buffer) + have,
10785 chars * 2, &newlen);
10787 SvCUR_set(utf8_buffer, have + newlen);
10790 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10791 it's private to us, and utf16_to_utf8{,reversed} take a
10792 (pointer,length) pair, rather than a NUL-terminated string. */
10793 if(SvCUR(utf16_buffer) & 1) {
10794 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10795 SvCUR_set(utf16_buffer, 1);
10797 SvCUR_set(utf16_buffer, 0);
10800 DEBUG_P(PerlIO_printf(Perl_debug_log,
10801 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10803 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10804 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10809 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10811 SV *filter = filter_add(S_utf16_textfilter, NULL);
10813 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10815 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10816 sv_setpvs(filter, "");
10817 IoLINES(filter) = reversed;
10818 IoPAGE(filter) = 1; /* Not EOF */
10820 /* Sadly, we have to return a valid pointer, come what may, so we have to
10821 ignore any error return from this. */
10822 SvCUR_set(PL_linestr, 0);
10823 if (FILTER_READ(0, PL_linestr, 0)) {
10824 SvUTF8_on(PL_linestr);
10826 SvUTF8_on(PL_linestr);
10828 PL_bufend = SvEND(PL_linestr);
10829 return (U8*)SvPVX(PL_linestr);
10834 Returns a pointer to the next character after the parsed
10835 vstring, as well as updating the passed in sv.
10837 Function must be called like
10839 sv = sv_2mortal(newSV(5));
10840 s = scan_vstring(s,e,sv);
10842 where s and e are the start and end of the string.
10843 The sv should already be large enough to store the vstring
10844 passed in, for performance reasons.
10846 This function may croak if fatal warnings are enabled in the
10847 calling scope, hence the sv_2mortal in the example (to prevent
10848 a leak). Make sure to do SvREFCNT_inc afterwards if you use
10854 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10856 const char *pos = s;
10857 const char *start = s;
10859 PERL_ARGS_ASSERT_SCAN_VSTRING;
10861 if (*pos == 'v') pos++; /* get past 'v' */
10862 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10864 if ( *pos != '.') {
10865 /* this may not be a v-string if followed by => */
10866 const char *next = pos;
10867 while (next < e && isSPACE(*next))
10869 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10870 /* return string not v-string */
10871 sv_setpvn(sv,(char *)s,pos-s);
10872 return (char *)pos;
10876 if (!isALPHA(*pos)) {
10877 U8 tmpbuf[UTF8_MAXBYTES+1];
10880 s++; /* get past 'v' */
10885 /* this is atoi() that tolerates underscores */
10888 const char *end = pos;
10890 while (--end >= s) {
10892 const UV orev = rev;
10893 rev += (*end - '0') * mult;
10896 /* diag_listed_as: Integer overflow in %s number */
10897 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10898 "Integer overflow in decimal number");
10902 if (rev > 0x7FFFFFFF)
10903 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10905 /* Append native character for the rev point */
10906 tmpend = uvchr_to_utf8(tmpbuf, rev);
10907 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10908 if (!UVCHR_IS_INVARIANT(rev))
10910 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
10916 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10920 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
10927 Perl_keyword_plugin_standard(pTHX_
10928 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
10930 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
10931 PERL_UNUSED_CONTEXT;
10932 PERL_UNUSED_ARG(keyword_ptr);
10933 PERL_UNUSED_ARG(keyword_len);
10934 PERL_UNUSED_ARG(op_ptr);
10935 return KEYWORD_PLUGIN_DECLINE;
10938 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
10940 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
10942 SAVEI32(PL_lex_brackets);
10943 if (PL_lex_brackets > 100)
10944 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
10945 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
10946 SAVEI32(PL_lex_allbrackets);
10947 PL_lex_allbrackets = 0;
10948 SAVEI8(PL_lex_fakeeof);
10949 PL_lex_fakeeof = (U8)fakeeof;
10950 if(yyparse(gramtype) && !PL_parser->error_count)
10951 qerror(Perl_mess(aTHX_ "Parse error"));
10954 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
10956 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
10960 SAVEVPTR(PL_eval_root);
10961 PL_eval_root = NULL;
10962 parse_recdescent(gramtype, fakeeof);
10968 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
10970 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
10973 if (flags & ~PARSE_OPTIONAL)
10974 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
10975 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
10976 if (!exprop && !(flags & PARSE_OPTIONAL)) {
10977 if (!PL_parser->error_count)
10978 qerror(Perl_mess(aTHX_ "Parse error"));
10979 exprop = newOP(OP_NULL, 0);
10985 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
10987 Parse a Perl arithmetic expression. This may contain operators of precedence
10988 down to the bit shift operators. The expression must be followed (and thus
10989 terminated) either by a comparison or lower-precedence operator or by
10990 something that would normally terminate an expression such as semicolon.
10991 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
10992 otherwise it is mandatory. It is up to the caller to ensure that the
10993 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
10994 the source of the code to be parsed and the lexical context for the
10997 The op tree representing the expression is returned. If an optional
10998 expression is absent, a null pointer is returned, otherwise the pointer
11001 If an error occurs in parsing or compilation, in most cases a valid op
11002 tree is returned anyway. The error is reflected in the parser state,
11003 normally resulting in a single exception at the top level of parsing
11004 which covers all the compilation errors that occurred. Some compilation
11005 errors, however, will throw an exception immediately.
11011 Perl_parse_arithexpr(pTHX_ U32 flags)
11013 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11017 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11019 Parse a Perl term expression. This may contain operators of precedence
11020 down to the assignment operators. The expression must be followed (and thus
11021 terminated) either by a comma or lower-precedence operator or by
11022 something that would normally terminate an expression such as semicolon.
11023 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11024 otherwise it is mandatory. It is up to the caller to ensure that the
11025 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11026 the source of the code to be parsed and the lexical context for the
11029 The op tree representing the expression is returned. If an optional
11030 expression is absent, a null pointer is returned, otherwise the pointer
11033 If an error occurs in parsing or compilation, in most cases a valid op
11034 tree is returned anyway. The error is reflected in the parser state,
11035 normally resulting in a single exception at the top level of parsing
11036 which covers all the compilation errors that occurred. Some compilation
11037 errors, however, will throw an exception immediately.
11043 Perl_parse_termexpr(pTHX_ U32 flags)
11045 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11049 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11051 Parse a Perl list expression. This may contain operators of precedence
11052 down to the comma operator. The expression must be followed (and thus
11053 terminated) either by a low-precedence logic operator such as C<or> or by
11054 something that would normally terminate an expression such as semicolon.
11055 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11056 otherwise it is mandatory. It is up to the caller to ensure that the
11057 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11058 the source of the code to be parsed and the lexical context for the
11061 The op tree representing the expression is returned. If an optional
11062 expression is absent, a null pointer is returned, otherwise the pointer
11065 If an error occurs in parsing or compilation, in most cases a valid op
11066 tree is returned anyway. The error is reflected in the parser state,
11067 normally resulting in a single exception at the top level of parsing
11068 which covers all the compilation errors that occurred. Some compilation
11069 errors, however, will throw an exception immediately.
11075 Perl_parse_listexpr(pTHX_ U32 flags)
11077 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11081 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11083 Parse a single complete Perl expression. This allows the full
11084 expression grammar, including the lowest-precedence operators such
11085 as C<or>. The expression must be followed (and thus terminated) by a
11086 token that an expression would normally be terminated by: end-of-file,
11087 closing bracketing punctuation, semicolon, or one of the keywords that
11088 signals a postfix expression-statement modifier. If I<flags> includes
11089 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11090 mandatory. It is up to the caller to ensure that the dynamic parser
11091 state (L</PL_parser> et al) is correctly set to reflect the source of
11092 the code to be parsed and the lexical context for the expression.
11094 The op tree representing the expression is returned. If an optional
11095 expression is absent, a null pointer is returned, otherwise the pointer
11098 If an error occurs in parsing or compilation, in most cases a valid op
11099 tree is returned anyway. The error is reflected in the parser state,
11100 normally resulting in a single exception at the top level of parsing
11101 which covers all the compilation errors that occurred. Some compilation
11102 errors, however, will throw an exception immediately.
11108 Perl_parse_fullexpr(pTHX_ U32 flags)
11110 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11114 =for apidoc Amx|OP *|parse_block|U32 flags
11116 Parse a single complete Perl code block. This consists of an opening
11117 brace, a sequence of statements, and a closing brace. The block
11118 constitutes a lexical scope, so C<my> variables and various compile-time
11119 effects can be contained within it. It is up to the caller to ensure
11120 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11121 reflect the source of the code to be parsed and the lexical context for
11124 The op tree representing the code block is returned. This is always a
11125 real op, never a null pointer. It will normally be a C<lineseq> list,
11126 including C<nextstate> or equivalent ops. No ops to construct any kind
11127 of runtime scope are included by virtue of it being a block.
11129 If an error occurs in parsing or compilation, in most cases a valid op
11130 tree (most likely null) is returned anyway. The error is reflected in
11131 the parser state, normally resulting in a single exception at the top
11132 level of parsing which covers all the compilation errors that occurred.
11133 Some compilation errors, however, will throw an exception immediately.
11135 The I<flags> parameter is reserved for future use, and must always
11142 Perl_parse_block(pTHX_ U32 flags)
11145 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11146 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11150 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11152 Parse a single unadorned Perl statement. This may be a normal imperative
11153 statement or a declaration that has compile-time effect. It does not
11154 include any label or other affixture. It is up to the caller to ensure
11155 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11156 reflect the source of the code to be parsed and the lexical context for
11159 The op tree representing the statement is returned. This may be a
11160 null pointer if the statement is null, for example if it was actually
11161 a subroutine definition (which has compile-time side effects). If not
11162 null, it will be ops directly implementing the statement, suitable to
11163 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11164 equivalent op (except for those embedded in a scope contained entirely
11165 within the statement).
11167 If an error occurs in parsing or compilation, in most cases a valid op
11168 tree (most likely null) is returned anyway. The error is reflected in
11169 the parser state, normally resulting in a single exception at the top
11170 level of parsing which covers all the compilation errors that occurred.
11171 Some compilation errors, however, will throw an exception immediately.
11173 The I<flags> parameter is reserved for future use, and must always
11180 Perl_parse_barestmt(pTHX_ U32 flags)
11183 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11184 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11188 =for apidoc Amx|SV *|parse_label|U32 flags
11190 Parse a single label, possibly optional, of the type that may prefix a
11191 Perl statement. It is up to the caller to ensure that the dynamic parser
11192 state (L</PL_parser> et al) is correctly set to reflect the source of
11193 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11194 label is optional, otherwise it is mandatory.
11196 The name of the label is returned in the form of a fresh scalar. If an
11197 optional label is absent, a null pointer is returned.
11199 If an error occurs in parsing, which can only occur if the label is
11200 mandatory, a valid label is returned anyway. The error is reflected in
11201 the parser state, normally resulting in a single exception at the top
11202 level of parsing which covers all the compilation errors that occurred.
11208 Perl_parse_label(pTHX_ U32 flags)
11210 if (flags & ~PARSE_OPTIONAL)
11211 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11212 if (PL_lex_state == LEX_KNOWNEXT) {
11213 PL_parser->yychar = yylex();
11214 if (PL_parser->yychar == LABEL) {
11215 char * const lpv = pl_yylval.pval;
11216 STRLEN llen = strlen(lpv);
11217 PL_parser->yychar = YYEMPTY;
11218 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11225 STRLEN wlen, bufptr_pos;
11228 if (!isIDFIRST_lazy_if(s, UTF))
11230 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11231 if (word_takes_any_delimeter(s, wlen))
11233 bufptr_pos = s - SvPVX(PL_linestr);
11235 lex_read_space(LEX_KEEP_PREVIOUS);
11237 s = SvPVX(PL_linestr) + bufptr_pos;
11238 if (t[0] == ':' && t[1] != ':') {
11239 PL_oldoldbufptr = PL_oldbufptr;
11242 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11246 if (flags & PARSE_OPTIONAL) {
11249 qerror(Perl_mess(aTHX_ "Parse error"));
11250 return newSVpvs("x");
11257 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11259 Parse a single complete Perl statement. This may be a normal imperative
11260 statement or a declaration that has compile-time effect, and may include
11261 optional labels. It is up to the caller to ensure that the dynamic
11262 parser state (L</PL_parser> et al) is correctly set to reflect the source
11263 of the code to be parsed and the lexical context for the statement.
11265 The op tree representing the statement is returned. This may be a
11266 null pointer if the statement is null, for example if it was actually
11267 a subroutine definition (which has compile-time side effects). If not
11268 null, it will be the result of a L</newSTATEOP> call, normally including
11269 a C<nextstate> or equivalent op.
11271 If an error occurs in parsing or compilation, in most cases a valid op
11272 tree (most likely null) is returned anyway. The error is reflected in
11273 the parser state, normally resulting in a single exception at the top
11274 level of parsing which covers all the compilation errors that occurred.
11275 Some compilation errors, however, will throw an exception immediately.
11277 The I<flags> parameter is reserved for future use, and must always
11284 Perl_parse_fullstmt(pTHX_ U32 flags)
11287 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11288 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11292 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11294 Parse a sequence of zero or more Perl statements. These may be normal
11295 imperative statements, including optional labels, or declarations
11296 that have compile-time effect, or any mixture thereof. The statement
11297 sequence ends when a closing brace or end-of-file is encountered in a
11298 place where a new statement could have validly started. It is up to
11299 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11300 is correctly set to reflect the source of the code to be parsed and the
11301 lexical context for the statements.
11303 The op tree representing the statement sequence is returned. This may
11304 be a null pointer if the statements were all null, for example if there
11305 were no statements or if there were only subroutine definitions (which
11306 have compile-time side effects). If not null, it will be a C<lineseq>
11307 list, normally including C<nextstate> or equivalent ops.
11309 If an error occurs in parsing or compilation, in most cases a valid op
11310 tree is returned anyway. The error is reflected in the parser state,
11311 normally resulting in a single exception at the top level of parsing
11312 which covers all the compilation errors that occurred. Some compilation
11313 errors, however, will throw an exception immediately.
11315 The I<flags> parameter is reserved for future use, and must always
11322 Perl_parse_stmtseq(pTHX_ U32 flags)
11327 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11328 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11329 c = lex_peek_unichar(0);
11330 if (c != -1 && c != /*{*/'}')
11331 qerror(Perl_mess(aTHX_ "Parse error"));
11335 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11337 S_lex_token_boundary(pTHX)
11339 PL_oldoldbufptr = PL_oldbufptr;
11340 PL_oldbufptr = PL_bufptr;
11343 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11345 S_parse_opt_lexvar(pTHX)
11350 lex_token_boundary();
11351 sigil = lex_read_unichar(0);
11352 if (lex_peek_unichar(0) == '#') {
11353 qerror(Perl_mess(aTHX_ "Parse error"));
11357 c = lex_peek_unichar(0);
11358 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11361 d = PL_tokenbuf + 1;
11362 PL_tokenbuf[0] = (char)sigil;
11363 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11365 if (d == PL_tokenbuf+1)
11368 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11369 OPf_MOD | (OPpLVAL_INTRO<<8));
11370 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11375 Perl_parse_subsignature(pTHX)
11378 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11379 OP *initops = NULL;
11381 c = lex_peek_unichar(0);
11382 while (c != /*(*/')') {
11386 if (prev_type == 2)
11387 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11388 var = parse_opt_lexvar();
11390 newBINOP(OP_AELEM, 0,
11391 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11393 newSVOP(OP_CONST, 0, newSViv(pos))) :
11396 c = lex_peek_unichar(0);
11398 lex_token_boundary();
11399 lex_read_unichar(0);
11401 c = lex_peek_unichar(0);
11402 if (c == ',' || c == /*(*/')') {
11404 qerror(Perl_mess(aTHX_ "Optional parameter "
11405 "lacks default expression"));
11407 OP *defexpr = parse_termexpr(0);
11408 if (defexpr->op_type == OP_UNDEF &&
11409 !(defexpr->op_flags & OPf_KIDS)) {
11414 scalar(newUNOP(OP_RV2AV, 0,
11415 newGVOP(OP_GV, 0, PL_defgv))),
11416 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11418 newCONDOP(0, ifop, expr, defexpr) :
11419 newLOGOP(OP_OR, 0, ifop, defexpr);
11424 if (prev_type == 1)
11425 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11426 "follows optional parameter"));
11428 min_arity = pos + 1;
11430 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11432 initops = op_append_list(OP_LINESEQ, initops,
11433 newSTATEOP(0, NULL, expr));
11439 if (prev_type == 2)
11440 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11441 var = parse_opt_lexvar();
11443 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11444 newBINOP(OP_BIT_AND, 0,
11445 scalar(newUNOP(OP_RV2AV, 0,
11446 newGVOP(OP_GV, 0, PL_defgv))),
11447 newSVOP(OP_CONST, 0, newSViv(1))),
11448 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11449 newSVOP(OP_CONST, 0,
11450 newSVpvs("Odd name/value argument "
11451 "for subroutine"))));
11452 if (pos != min_arity)
11453 chkop = newLOGOP(OP_AND, 0,
11455 scalar(newUNOP(OP_RV2AV, 0,
11456 newGVOP(OP_GV, 0, PL_defgv))),
11457 newSVOP(OP_CONST, 0, newSViv(pos))),
11459 initops = op_append_list(OP_LINESEQ,
11460 newSTATEOP(0, NULL, chkop),
11465 op_prepend_elem(OP_ASLICE,
11466 newOP(OP_PUSHMARK, 0),
11467 newLISTOP(OP_ASLICE, 0,
11469 newSVOP(OP_CONST, 0, newSViv(pos)),
11470 newUNOP(OP_AV2ARYLEN, 0,
11471 ref(newUNOP(OP_RV2AV, 0,
11472 newGVOP(OP_GV, 0, PL_defgv)),
11474 ref(newUNOP(OP_RV2AV, 0,
11475 newGVOP(OP_GV, 0, PL_defgv)),
11477 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11478 initops = op_append_list(OP_LINESEQ, initops,
11479 newSTATEOP(0, NULL,
11480 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11487 qerror(Perl_mess(aTHX_ "Parse error"));
11491 c = lex_peek_unichar(0);
11493 case /*(*/')': break;
11496 lex_token_boundary();
11497 lex_read_unichar(0);
11499 c = lex_peek_unichar(0);
11500 } while (c == ',');
11506 if (min_arity != 0) {
11507 initops = op_append_list(OP_LINESEQ,
11508 newSTATEOP(0, NULL,
11511 scalar(newUNOP(OP_RV2AV, 0,
11512 newGVOP(OP_GV, 0, PL_defgv))),
11513 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11514 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11515 newSVOP(OP_CONST, 0,
11516 newSVpvs("Too few arguments for subroutine"))))),
11519 if (max_arity != -1) {
11520 initops = op_append_list(OP_LINESEQ,
11521 newSTATEOP(0, NULL,
11524 scalar(newUNOP(OP_RV2AV, 0,
11525 newGVOP(OP_GV, 0, PL_defgv))),
11526 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11527 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11528 newSVOP(OP_CONST, 0,
11529 newSVpvs("Too many arguments for subroutine"))))),
11537 * c-indentation-style: bsd
11538 * c-basic-offset: 4
11539 * indent-tabs-mode: nil
11542 * ex: set ts=8 sts=4 sw=4 et: