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_expect (PL_parser->lex_expect)
58 #define PL_lex_formbrack (PL_parser->lex_formbrack)
59 #define PL_lex_inpat (PL_parser->lex_inpat)
60 #define PL_lex_inwhat (PL_parser->lex_inwhat)
61 #define PL_lex_op (PL_parser->lex_op)
62 #define PL_lex_repl (PL_parser->lex_repl)
63 #define PL_lex_starts (PL_parser->lex_starts)
64 #define PL_lex_stuff (PL_parser->lex_stuff)
65 #define PL_multi_start (PL_parser->multi_start)
66 #define PL_multi_open (PL_parser->multi_open)
67 #define PL_multi_close (PL_parser->multi_close)
68 #define PL_preambled (PL_parser->preambled)
69 #define PL_sublex_info (PL_parser->sublex_info)
70 #define PL_linestr (PL_parser->linestr)
71 #define PL_expect (PL_parser->expect)
72 #define PL_copline (PL_parser->copline)
73 #define PL_bufptr (PL_parser->bufptr)
74 #define PL_oldbufptr (PL_parser->oldbufptr)
75 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
76 #define PL_linestart (PL_parser->linestart)
77 #define PL_bufend (PL_parser->bufend)
78 #define PL_last_uni (PL_parser->last_uni)
79 #define PL_last_lop (PL_parser->last_lop)
80 #define PL_last_lop_op (PL_parser->last_lop_op)
81 #define PL_lex_state (PL_parser->lex_state)
82 #define PL_rsfp (PL_parser->rsfp)
83 #define PL_rsfp_filters (PL_parser->rsfp_filters)
84 #define PL_in_my (PL_parser->in_my)
85 #define PL_in_my_stash (PL_parser->in_my_stash)
86 #define PL_tokenbuf (PL_parser->tokenbuf)
87 #define PL_multi_end (PL_parser->multi_end)
88 #define PL_error_count (PL_parser->error_count)
90 # define PL_nexttoke (PL_parser->nexttoke)
91 # define PL_nexttype (PL_parser->nexttype)
92 # define PL_nextval (PL_parser->nextval)
94 static const char* const ident_too_long = "Identifier too long";
96 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
98 #define XENUMMASK 0x3f
100 #define XFAKEBRACK 0x80
102 #ifdef USE_UTF8_SCRIPTS
103 # define UTF (!IN_BYTES)
105 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
108 /* The maximum number of characters preceding the unrecognized one to display */
109 #define UNRECOGNIZED_PRECEDE_COUNT 10
111 /* In variables named $^X, these are the legal values for X.
112 * 1999-02-27 mjd-perl-patch@plover.com */
113 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
115 #define SPACE_OR_TAB(c) isBLANK_A(c)
117 /* LEX_* are values for PL_lex_state, the state of the lexer.
118 * They are arranged oddly so that the guard on the switch statement
119 * can get by with a single comparison (if the compiler is smart enough).
121 * These values refer to the various states within a sublex parse,
122 * i.e. within a double quotish string
125 /* #define LEX_NOTPARSING 11 is done in perl.h. */
127 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
128 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
129 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
130 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
131 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
133 /* at end of code, eg "$x" followed by: */
134 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
135 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
137 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
138 string or after \E, $foo, etc */
139 #define LEX_INTERPCONST 2 /* NOT USED */
140 #define LEX_FORMLINE 1 /* expecting a format line */
141 #define LEX_KNOWNEXT 0 /* next token known; just return it */
145 static const char* const lex_state_names[] = {
160 #include "keywords.h"
162 /* CLINE is a macro that ensures PL_copline has a sane value */
164 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
166 # define SKIPSPACE0(s) skipspace(s)
167 # define SKIPSPACE1(s) skipspace(s)
168 # define SKIPSPACE2(s,tsv) skipspace(s)
169 # define PEEKSPACE(s) skipspace(s)
172 * Convenience functions to return different tokens and prime the
173 * lexer for the next token. They all take an argument.
175 * TOKEN : generic token (used for '(', DOLSHARP, etc)
176 * OPERATOR : generic operator
177 * AOPERATOR : assignment operator
178 * PREBLOCK : beginning the block after an if, while, foreach, ...
179 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
180 * PREREF : *EXPR where EXPR is not a simple identifier
181 * TERM : expression term
182 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
183 * LOOPX : loop exiting command (goto, last, dump, etc)
184 * FTST : file test operator
185 * FUN0 : zero-argument function
186 * FUN0OP : zero-argument function, with its op created in this file
187 * FUN1 : not used, except for not, which isn't a UNIOP
188 * BOop : bitwise or or xor
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
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_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
216 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
217 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
218 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
219 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
220 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
221 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
222 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
223 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
224 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
225 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
226 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
227 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
228 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
230 /* This bit of chicanery makes a unary function followed by
231 * a parenthesis into a function with one argument, highest precedence.
232 * The UNIDOR macro is for unary functions that can be followed by the //
233 * operator (such as C<shift // 0>).
235 #define UNI3(f,x,have_x) { \
236 pl_yylval.ival = f; \
237 if (have_x) PL_expect = x; \
239 PL_last_uni = PL_oldbufptr; \
240 PL_last_lop_op = f; \
242 return REPORT( (int)FUNC1 ); \
244 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
246 #define UNI(f) UNI3(f,XTERM,1)
247 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
248 #define UNIPROTO(f,optional) { \
249 if (optional) PL_last_uni = PL_oldbufptr; \
253 #define UNIBRACK(f) UNI3(f,0,0)
255 /* grandfather return to old style */
258 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
259 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
260 pl_yylval.ival = (f); \
266 #define COPLINE_INC_WITH_HERELINES \
268 CopLINE_inc(PL_curcop); \
269 if (PL_parser->herelines) \
270 CopLINE(PL_curcop) += PL_parser->herelines, \
271 PL_parser->herelines = 0; \
273 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
274 * is no sublex_push to follow. */
275 #define COPLINE_SET_FROM_MULTI_END \
277 CopLINE_set(PL_curcop, PL_multi_end); \
278 if (PL_multi_end != PL_multi_start) \
279 PL_parser->herelines = 0; \
285 /* how to interpret the pl_yylval associated with the token */
289 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
294 static struct debug_tokens {
296 enum token_type type;
298 } const debug_tokens[] =
300 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
301 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
302 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
303 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
304 { ARROW, TOKENTYPE_NONE, "ARROW" },
305 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
306 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
307 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
308 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
309 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
310 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
311 { DO, TOKENTYPE_NONE, "DO" },
312 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
313 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
314 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
315 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
316 { ELSE, TOKENTYPE_NONE, "ELSE" },
317 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
318 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
319 { FOR, TOKENTYPE_IVAL, "FOR" },
320 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
321 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
322 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
323 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
324 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
325 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
326 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
327 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
328 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
329 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
330 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
331 { IF, TOKENTYPE_IVAL, "IF" },
332 { LABEL, TOKENTYPE_PVAL, "LABEL" },
333 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
334 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
335 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
336 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
337 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
338 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
339 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
340 { MY, TOKENTYPE_IVAL, "MY" },
341 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
342 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
343 { OROP, TOKENTYPE_IVAL, "OROP" },
344 { OROR, TOKENTYPE_NONE, "OROR" },
345 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
346 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
347 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
348 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
349 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
350 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
351 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
352 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
353 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
354 { PREINC, TOKENTYPE_NONE, "PREINC" },
355 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
356 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
357 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
358 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
359 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
360 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
361 { SUB, TOKENTYPE_NONE, "SUB" },
362 { THING, TOKENTYPE_OPVAL, "THING" },
363 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
364 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
365 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
366 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
367 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
368 { USE, TOKENTYPE_IVAL, "USE" },
369 { WHEN, TOKENTYPE_IVAL, "WHEN" },
370 { WHILE, TOKENTYPE_IVAL, "WHILE" },
371 { WORD, TOKENTYPE_OPVAL, "WORD" },
372 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
373 { 0, TOKENTYPE_NONE, NULL }
376 /* dump the returned token in rv, plus any optional arg in pl_yylval */
379 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
383 PERL_ARGS_ASSERT_TOKEREPORT;
386 const char *name = NULL;
387 enum token_type type = TOKENTYPE_NONE;
388 const struct debug_tokens *p;
389 SV* const report = newSVpvs("<== ");
391 for (p = debug_tokens; p->token; p++) {
392 if (p->token == (int)rv) {
399 Perl_sv_catpv(aTHX_ report, name);
400 else if ((char)rv > ' ' && (char)rv <= '~')
402 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
404 sv_catpvs(report, " (pending identifier)");
407 sv_catpvs(report, "EOF");
409 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
414 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
416 case TOKENTYPE_OPNUM:
417 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
418 PL_op_name[lvalp->ival]);
421 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
423 case TOKENTYPE_OPVAL:
425 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
426 PL_op_name[lvalp->opval->op_type]);
427 if (lvalp->opval->op_type == OP_CONST) {
428 Perl_sv_catpvf(aTHX_ report, " %s",
429 SvPEEK(cSVOPx_sv(lvalp->opval)));
434 sv_catpvs(report, "(opval=null)");
437 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
443 /* print the buffer with suitable escapes */
446 S_printbuf(pTHX_ const char *const fmt, const char *const s)
448 SV* const tmp = newSVpvs("");
450 PERL_ARGS_ASSERT_PRINTBUF;
452 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
453 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
461 S_deprecate_commaless_var_list(pTHX) {
463 deprecate("comma-less variable list");
464 return REPORT(','); /* grandfather non-comma-format format */
470 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
471 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
475 S_ao(pTHX_ int toketype)
478 if (*PL_bufptr == '=') {
480 if (toketype == ANDAND)
481 pl_yylval.ival = OP_ANDASSIGN;
482 else if (toketype == OROR)
483 pl_yylval.ival = OP_ORASSIGN;
484 else if (toketype == DORDOR)
485 pl_yylval.ival = OP_DORASSIGN;
493 * When Perl expects an operator and finds something else, no_op
494 * prints the warning. It always prints "<something> found where
495 * operator expected. It prints "Missing semicolon on previous line?"
496 * if the surprise occurs at the start of the line. "do you need to
497 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
498 * where the compiler doesn't know if foo is a method call or a function.
499 * It prints "Missing operator before end of line" if there's nothing
500 * after the missing operator, or "... before <...>" if there is something
501 * after the missing operator.
505 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)
558 char * const nl = strrchr(s,'\n');
562 else if ((U8) PL_multi_close < 32) {
564 tmpbuf[1] = (char)toCTRL(PL_multi_close);
569 *tmpbuf = (char)PL_multi_close;
573 q = strchr(s,'"') ? '\'' : '"';
574 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
580 * Check whether the named feature is enabled.
583 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
586 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
588 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
590 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
592 if (namelen > MAX_FEATURE_LEN)
594 memcpy(&he_name[8], name, namelen);
596 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
597 REFCOUNTED_HE_EXISTS));
601 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
602 * utf16-to-utf8-reversed.
605 #ifdef PERL_CR_FILTER
609 const char *s = SvPVX_const(sv);
610 const char * const e = s + SvCUR(sv);
612 PERL_ARGS_ASSERT_STRIP_RETURN;
614 /* outer loop optimized to do nothing if there are no CR-LFs */
616 if (*s++ == '\r' && *s == '\n') {
617 /* hit a CR-LF, need to copy the rest */
621 if (*s == '\r' && s[1] == '\n')
632 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
634 const I32 count = FILTER_READ(idx+1, sv, maxlen);
635 if (count > 0 && !maxlen)
642 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
644 Creates and initialises a new lexer/parser state object, supplying
645 a context in which to lex and parse from a new source of Perl code.
646 A pointer to the new state object is placed in L</PL_parser>. An entry
647 is made on the save stack so that upon unwinding the new state object
648 will be destroyed and the former value of L</PL_parser> will be restored.
649 Nothing else need be done to clean up the parsing context.
651 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
652 non-null, provides a string (in SV form) containing code to be parsed.
653 A copy of the string is made, so subsequent modification of I<line>
654 does not affect parsing. I<rsfp>, if non-null, provides an input stream
655 from which code will be read to be parsed. If both are non-null, the
656 code in I<line> comes first and must consist of complete lines of input,
657 and I<rsfp> supplies the remainder of the source.
659 The I<flags> parameter is reserved for future use. Currently it is only
660 used by perl internally, so extensions should always pass zero.
665 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
666 can share filters with the current parser.
667 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
668 caller, hence isn't owned by the parser, so shouldn't be closed on parser
669 destruction. This is used to handle the case of defaulting to reading the
670 script from the standard input because no filename was given on the command
671 line (without getting confused by situation where STDIN has been closed, so
672 the script handle is opened on fd 0) */
675 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
678 const char *s = NULL;
679 yy_parser *parser, *oparser;
680 if (flags && flags & ~LEX_START_FLAGS)
681 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
683 /* create and initialise a parser */
685 Newxz(parser, 1, yy_parser);
686 parser->old_parser = oparser = PL_parser;
689 parser->stack = NULL;
691 parser->stack_size = 0;
693 /* on scope exit, free this parser and restore any outer one */
695 parser->saved_curcop = PL_curcop;
697 /* initialise lexer state */
699 parser->nexttoke = 0;
700 parser->error_count = oparser ? oparser->error_count : 0;
701 parser->copline = parser->preambling = NOLINE;
702 parser->lex_state = LEX_NORMAL;
703 parser->expect = XSTATE;
705 parser->rsfp_filters =
706 !(flags & LEX_START_SAME_FILTER) || !oparser
708 : MUTABLE_AV(SvREFCNT_inc(
709 oparser->rsfp_filters
710 ? oparser->rsfp_filters
711 : (oparser->rsfp_filters = newAV())
714 Newx(parser->lex_brackstack, 120, char);
715 Newx(parser->lex_casestack, 12, char);
716 *parser->lex_casestack = '\0';
717 Newxz(parser->lex_shared, 1, LEXSHARED);
721 s = SvPV_const(line, len);
722 parser->linestr = flags & LEX_START_COPIED
723 ? SvREFCNT_inc_simple_NN(line)
724 : newSVpvn_flags(s, len, SvUTF8(line));
725 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
727 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
729 parser->oldoldbufptr =
732 parser->linestart = SvPVX(parser->linestr);
733 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
734 parser->last_lop = parser->last_uni = NULL;
736 assert(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
737 |LEX_DONT_CLOSE_RSFP));
738 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
739 |LEX_DONT_CLOSE_RSFP));
741 parser->in_pod = parser->filtered = 0;
745 /* delete a parser object */
748 Perl_parser_free(pTHX_ const yy_parser *parser)
750 PERL_ARGS_ASSERT_PARSER_FREE;
752 PL_curcop = parser->saved_curcop;
753 SvREFCNT_dec(parser->linestr);
755 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
756 PerlIO_clearerr(parser->rsfp);
757 else if (parser->rsfp && (!parser->old_parser ||
758 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
759 PerlIO_close(parser->rsfp);
760 SvREFCNT_dec(parser->rsfp_filters);
761 SvREFCNT_dec(parser->lex_stuff);
762 SvREFCNT_dec(parser->sublex_info.repl);
764 Safefree(parser->lex_brackstack);
765 Safefree(parser->lex_casestack);
766 Safefree(parser->lex_shared);
767 PL_parser = parser->old_parser;
772 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
774 I32 nexttoke = parser->nexttoke;
775 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
777 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
778 && parser->nextval[nexttoke].opval
779 && parser->nextval[nexttoke].opval->op_slabbed
780 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
781 op_free(parser->nextval[nexttoke].opval);
782 parser->nextval[nexttoke].opval = NULL;
789 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
791 Buffer scalar containing the chunk currently under consideration of the
792 text currently being lexed. This is always a plain string scalar (for
793 which C<SvPOK> is true). It is not intended to be used as a scalar by
794 normal scalar means; instead refer to the buffer directly by the pointer
795 variables described below.
797 The lexer maintains various C<char*> pointers to things in the
798 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
799 reallocated, all of these pointers must be updated. Don't attempt to
800 do this manually, but rather use L</lex_grow_linestr> if you need to
801 reallocate the buffer.
803 The content of the text chunk in the buffer is commonly exactly one
804 complete line of input, up to and including a newline terminator,
805 but there are situations where it is otherwise. The octets of the
806 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
807 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
808 flag on this scalar, which may disagree with it.
810 For direct examination of the buffer, the variable
811 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
812 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
813 of these pointers is usually preferable to examination of the scalar
814 through normal scalar means.
816 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
818 Direct pointer to the end of the chunk of text currently being lexed, the
819 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
820 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
821 always located at the end of the buffer, and does not count as part of
822 the buffer's contents.
824 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
826 Points to the current position of lexing inside the lexer buffer.
827 Characters around this point may be freely examined, within
828 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
829 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
830 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
832 Lexing code (whether in the Perl core or not) moves this pointer past
833 the characters that it consumes. It is also expected to perform some
834 bookkeeping whenever a newline character is consumed. This movement
835 can be more conveniently performed by the function L</lex_read_to>,
836 which handles newlines appropriately.
838 Interpretation of the buffer's octets can be abstracted out by
839 using the slightly higher-level functions L</lex_peek_unichar> and
840 L</lex_read_unichar>.
842 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
844 Points to the start of the current line inside the lexer buffer.
845 This is useful for indicating at which column an error occurred, and
846 not much else. This must be updated by any lexing code that consumes
847 a newline; the function L</lex_read_to> handles this detail.
853 =for apidoc Amx|bool|lex_bufutf8
855 Indicates whether the octets in the lexer buffer
856 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
857 of Unicode characters. If not, they should be interpreted as Latin-1
858 characters. This is analogous to the C<SvUTF8> flag for scalars.
860 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
861 contains valid UTF-8. Lexing code must be robust in the face of invalid
864 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
865 is significant, but not the whole story regarding the input character
866 encoding. Normally, when a file is being read, the scalar contains octets
867 and its C<SvUTF8> flag is off, but the octets should be interpreted as
868 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
869 however, the scalar may have the C<SvUTF8> flag on, and in this case its
870 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
871 is in effect. This logic may change in the future; use this function
872 instead of implementing the logic yourself.
878 Perl_lex_bufutf8(pTHX)
884 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
886 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
887 at least I<len> octets (including terminating C<NUL>). Returns a
888 pointer to the reallocated buffer. This is necessary before making
889 any direct modification of the buffer that would increase its length.
890 L</lex_stuff_pvn> provides a more convenient way to insert text into
893 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
894 this function updates all of the lexer's variables that point directly
901 Perl_lex_grow_linestr(pTHX_ STRLEN len)
905 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
906 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
907 linestr = PL_parser->linestr;
908 buf = SvPVX(linestr);
909 if (len <= SvLEN(linestr))
911 bufend_pos = PL_parser->bufend - buf;
912 bufptr_pos = PL_parser->bufptr - buf;
913 oldbufptr_pos = PL_parser->oldbufptr - buf;
914 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
915 linestart_pos = PL_parser->linestart - buf;
916 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
917 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
918 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
919 PL_parser->lex_shared->re_eval_start - buf : 0;
921 buf = sv_grow(linestr, len);
923 PL_parser->bufend = buf + bufend_pos;
924 PL_parser->bufptr = buf + bufptr_pos;
925 PL_parser->oldbufptr = buf + oldbufptr_pos;
926 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
927 PL_parser->linestart = buf + linestart_pos;
928 if (PL_parser->last_uni)
929 PL_parser->last_uni = buf + last_uni_pos;
930 if (PL_parser->last_lop)
931 PL_parser->last_lop = buf + last_lop_pos;
932 if (PL_parser->lex_shared->re_eval_start)
933 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
938 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
940 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
941 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
942 reallocating the buffer if necessary. This means that lexing code that
943 runs later will see the characters as if they had appeared in the input.
944 It is not recommended to do this as part of normal parsing, and most
945 uses of this facility run the risk of the inserted characters being
946 interpreted in an unintended manner.
948 The string to be inserted is represented by I<len> octets starting
949 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
950 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
951 The characters are recoded for the lexer buffer, according to how the
952 buffer is currently being interpreted (L</lex_bufutf8>). If a string
953 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
954 function is more convenient.
960 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
964 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
965 if (flags & ~(LEX_STUFF_UTF8))
966 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
968 if (flags & LEX_STUFF_UTF8) {
971 STRLEN highhalf = 0; /* Count of variants */
972 const char *p, *e = pv+len;
973 for (p = pv; p != e; p++) {
974 if (! UTF8_IS_INVARIANT(*p)) {
980 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
981 bufptr = PL_parser->bufptr;
982 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
983 SvCUR_set(PL_parser->linestr,
984 SvCUR(PL_parser->linestr) + len+highhalf);
985 PL_parser->bufend += len+highhalf;
986 for (p = pv; p != e; p++) {
988 if (! UTF8_IS_INVARIANT(c)) {
989 *bufptr++ = UTF8_TWO_BYTE_HI(c);
990 *bufptr++ = UTF8_TWO_BYTE_LO(c);
997 if (flags & LEX_STUFF_UTF8) {
999 const char *p, *e = pv+len;
1000 for (p = pv; p != e; p++) {
1002 if (UTF8_IS_ABOVE_LATIN1(c)) {
1003 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1004 "non-Latin-1 character into Latin-1 input");
1005 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1008 } else if (! UTF8_IS_INVARIANT(c)) {
1009 /* malformed UTF-8 */
1011 SAVESPTR(PL_warnhook);
1012 PL_warnhook = PERL_WARNHOOK_FATAL;
1013 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1019 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1020 bufptr = PL_parser->bufptr;
1021 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1022 SvCUR_set(PL_parser->linestr,
1023 SvCUR(PL_parser->linestr) + len-highhalf);
1024 PL_parser->bufend += len-highhalf;
1027 if (UTF8_IS_INVARIANT(*p)) {
1033 *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1039 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1040 bufptr = PL_parser->bufptr;
1041 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1042 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1043 PL_parser->bufend += len;
1044 Copy(pv, bufptr, len, char);
1050 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1052 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1053 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1054 reallocating the buffer if necessary. This means that lexing code that
1055 runs later will see the characters as if they had appeared in the input.
1056 It is not recommended to do this as part of normal parsing, and most
1057 uses of this facility run the risk of the inserted characters being
1058 interpreted in an unintended manner.
1060 The string to be inserted is represented by octets starting at I<pv>
1061 and continuing to the first nul. These octets are interpreted as either
1062 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1063 in I<flags>. The characters are recoded for the lexer buffer, according
1064 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1065 If it is not convenient to nul-terminate a string to be inserted, the
1066 L</lex_stuff_pvn> function is more appropriate.
1072 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1074 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1075 lex_stuff_pvn(pv, strlen(pv), flags);
1079 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1081 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1082 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1083 reallocating the buffer if necessary. This means that lexing code that
1084 runs later will see the characters as if they had appeared in the input.
1085 It is not recommended to do this as part of normal parsing, and most
1086 uses of this facility run the risk of the inserted characters being
1087 interpreted in an unintended manner.
1089 The string to be inserted is the string value of I<sv>. The characters
1090 are recoded for the lexer buffer, according to how the buffer is currently
1091 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1092 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1093 need to construct a scalar.
1099 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1103 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1105 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1107 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1111 =for apidoc Amx|void|lex_unstuff|char *ptr
1113 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1114 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1115 This hides the discarded text from any lexing code that runs later,
1116 as if the text had never appeared.
1118 This is not the normal way to consume lexed text. For that, use
1125 Perl_lex_unstuff(pTHX_ char *ptr)
1129 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1130 buf = PL_parser->bufptr;
1132 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1135 bufend = PL_parser->bufend;
1137 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 unstuff_len = ptr - buf;
1139 Move(ptr, buf, bufend+1-ptr, char);
1140 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1141 PL_parser->bufend = bufend - unstuff_len;
1145 =for apidoc Amx|void|lex_read_to|char *ptr
1147 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1148 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1149 performing the correct bookkeeping whenever a newline character is passed.
1150 This is the normal way to consume lexed text.
1152 Interpretation of the buffer's octets can be abstracted out by
1153 using the slightly higher-level functions L</lex_peek_unichar> and
1154 L</lex_read_unichar>.
1160 Perl_lex_read_to(pTHX_ char *ptr)
1163 PERL_ARGS_ASSERT_LEX_READ_TO;
1164 s = PL_parser->bufptr;
1165 if (ptr < s || ptr > PL_parser->bufend)
1166 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1167 for (; s != ptr; s++)
1169 COPLINE_INC_WITH_HERELINES;
1170 PL_parser->linestart = s+1;
1172 PL_parser->bufptr = ptr;
1176 =for apidoc Amx|void|lex_discard_to|char *ptr
1178 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1179 up to I<ptr>. The remaining content of the buffer will be moved, and
1180 all pointers into the buffer updated appropriately. I<ptr> must not
1181 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1182 it is not permitted to discard text that has yet to be lexed.
1184 Normally it is not necessarily to do this directly, because it suffices to
1185 use the implicit discarding behaviour of L</lex_next_chunk> and things
1186 based on it. However, if a token stretches across multiple lines,
1187 and the lexing code has kept multiple lines of text in the buffer for
1188 that purpose, then after completion of the token it would be wise to
1189 explicitly discard the now-unneeded earlier lines, to avoid future
1190 multi-line tokens growing the buffer without bound.
1196 Perl_lex_discard_to(pTHX_ char *ptr)
1200 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1201 buf = SvPVX(PL_parser->linestr);
1203 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1206 if (ptr > PL_parser->bufptr)
1207 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1208 discard_len = ptr - buf;
1209 if (PL_parser->oldbufptr < ptr)
1210 PL_parser->oldbufptr = ptr;
1211 if (PL_parser->oldoldbufptr < ptr)
1212 PL_parser->oldoldbufptr = ptr;
1213 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1214 PL_parser->last_uni = NULL;
1215 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1216 PL_parser->last_lop = NULL;
1217 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1218 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1219 PL_parser->bufend -= discard_len;
1220 PL_parser->bufptr -= discard_len;
1221 PL_parser->oldbufptr -= discard_len;
1222 PL_parser->oldoldbufptr -= discard_len;
1223 if (PL_parser->last_uni)
1224 PL_parser->last_uni -= discard_len;
1225 if (PL_parser->last_lop)
1226 PL_parser->last_lop -= discard_len;
1230 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1232 Reads in the next chunk of text to be lexed, appending it to
1233 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1234 looked to the end of the current chunk and wants to know more. It is
1235 usual, but not necessary, for lexing to have consumed the entirety of
1236 the current chunk at this time.
1238 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1239 chunk (i.e., the current chunk has been entirely consumed), normally the
1240 current chunk will be discarded at the same time that the new chunk is
1241 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1242 will not be discarded. If the current chunk has not been entirely
1243 consumed, then it will not be discarded regardless of the flag.
1245 Returns true if some new text was added to the buffer, or false if the
1246 buffer has reached the end of the input text.
1251 #define LEX_FAKE_EOF 0x80000000
1252 #define LEX_NO_TERM 0x40000000
1255 Perl_lex_next_chunk(pTHX_ U32 flags)
1259 STRLEN old_bufend_pos, new_bufend_pos;
1260 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1261 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1262 bool got_some_for_debugger = 0;
1264 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1265 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1266 linestr = PL_parser->linestr;
1267 buf = SvPVX(linestr);
1268 if (!(flags & LEX_KEEP_PREVIOUS) &&
1269 PL_parser->bufptr == PL_parser->bufend) {
1270 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1272 if (PL_parser->last_uni != PL_parser->bufend)
1273 PL_parser->last_uni = NULL;
1274 if (PL_parser->last_lop != PL_parser->bufend)
1275 PL_parser->last_lop = NULL;
1276 last_uni_pos = last_lop_pos = 0;
1280 old_bufend_pos = PL_parser->bufend - buf;
1281 bufptr_pos = PL_parser->bufptr - buf;
1282 oldbufptr_pos = PL_parser->oldbufptr - buf;
1283 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1284 linestart_pos = PL_parser->linestart - buf;
1285 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1286 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1288 if (flags & LEX_FAKE_EOF) {
1290 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1292 } else if (filter_gets(linestr, old_bufend_pos)) {
1294 got_some_for_debugger = 1;
1295 } else if (flags & LEX_NO_TERM) {
1298 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1299 sv_setpvs(linestr, "");
1301 /* End of real input. Close filehandle (unless it was STDIN),
1302 * then add implicit termination.
1304 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1305 PerlIO_clearerr(PL_parser->rsfp);
1306 else if (PL_parser->rsfp)
1307 (void)PerlIO_close(PL_parser->rsfp);
1308 PL_parser->rsfp = NULL;
1309 PL_parser->in_pod = PL_parser->filtered = 0;
1310 if (!PL_in_eval && PL_minus_p) {
1312 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1313 PL_minus_n = PL_minus_p = 0;
1314 } else if (!PL_in_eval && PL_minus_n) {
1315 sv_catpvs(linestr, /*{*/";}");
1318 sv_catpvs(linestr, ";");
1321 buf = SvPVX(linestr);
1322 new_bufend_pos = SvCUR(linestr);
1323 PL_parser->bufend = buf + new_bufend_pos;
1324 PL_parser->bufptr = buf + bufptr_pos;
1325 PL_parser->oldbufptr = buf + oldbufptr_pos;
1326 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1327 PL_parser->linestart = buf + linestart_pos;
1328 if (PL_parser->last_uni)
1329 PL_parser->last_uni = buf + last_uni_pos;
1330 if (PL_parser->last_lop)
1331 PL_parser->last_lop = buf + last_lop_pos;
1332 if (PL_parser->preambling != NOLINE) {
1333 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1334 PL_parser->preambling = NOLINE;
1336 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1337 PL_curstash != PL_debstash) {
1338 /* debugger active and we're not compiling the debugger code,
1339 * so store the line into the debugger's array of lines
1341 update_debugger_info(NULL, buf+old_bufend_pos,
1342 new_bufend_pos-old_bufend_pos);
1348 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1350 Looks ahead one (Unicode) character in the text currently being lexed.
1351 Returns the codepoint (unsigned integer value) of the next character,
1352 or -1 if lexing has reached the end of the input text. To consume the
1353 peeked character, use L</lex_read_unichar>.
1355 If the next character is in (or extends into) the next chunk of input
1356 text, the next chunk will be read in. Normally the current chunk will be
1357 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1358 then the current chunk will not be discarded.
1360 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1361 is encountered, an exception is generated.
1367 Perl_lex_peek_unichar(pTHX_ U32 flags)
1371 if (flags & ~(LEX_KEEP_PREVIOUS))
1372 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1373 s = PL_parser->bufptr;
1374 bufend = PL_parser->bufend;
1380 if (!lex_next_chunk(flags))
1382 s = PL_parser->bufptr;
1383 bufend = PL_parser->bufend;
1386 if (UTF8_IS_INVARIANT(head))
1388 if (UTF8_IS_START(head)) {
1389 len = UTF8SKIP(&head);
1390 while ((STRLEN)(bufend-s) < len) {
1391 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1393 s = PL_parser->bufptr;
1394 bufend = PL_parser->bufend;
1397 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1398 if (retlen == (STRLEN)-1) {
1399 /* malformed UTF-8 */
1401 SAVESPTR(PL_warnhook);
1402 PL_warnhook = PERL_WARNHOOK_FATAL;
1403 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1409 if (!lex_next_chunk(flags))
1411 s = PL_parser->bufptr;
1418 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1420 Reads the next (Unicode) character in the text currently being lexed.
1421 Returns the codepoint (unsigned integer value) of the character read,
1422 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1423 if lexing has reached the end of the input text. To non-destructively
1424 examine the next character, use L</lex_peek_unichar> instead.
1426 If the next character is in (or extends into) the next chunk of input
1427 text, the next chunk will be read in. Normally the current chunk will be
1428 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1429 then the current chunk will not be discarded.
1431 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1432 is encountered, an exception is generated.
1438 Perl_lex_read_unichar(pTHX_ U32 flags)
1441 if (flags & ~(LEX_KEEP_PREVIOUS))
1442 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1443 c = lex_peek_unichar(flags);
1446 COPLINE_INC_WITH_HERELINES;
1448 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1450 ++(PL_parser->bufptr);
1456 =for apidoc Amx|void|lex_read_space|U32 flags
1458 Reads optional spaces, in Perl style, in the text currently being
1459 lexed. The spaces may include ordinary whitespace characters and
1460 Perl-style comments. C<#line> directives are processed if encountered.
1461 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1462 at a non-space character (or the end of the input text).
1464 If spaces extend into the next chunk of input text, the next chunk will
1465 be read in. Normally the current chunk will be discarded at the same
1466 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1467 chunk will not be discarded.
1472 #define LEX_NO_INCLINE 0x40000000
1473 #define LEX_NO_NEXT_CHUNK 0x80000000
1476 Perl_lex_read_space(pTHX_ U32 flags)
1479 const bool can_incline = !(flags & LEX_NO_INCLINE);
1480 bool need_incline = 0;
1481 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1482 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1483 s = PL_parser->bufptr;
1484 bufend = PL_parser->bufend;
1490 } while (!(c == '\n' || (c == 0 && s == bufend)));
1491 } else if (c == '\n') {
1494 PL_parser->linestart = s;
1500 } else if (isSPACE(c)) {
1502 } else if (c == 0 && s == bufend) {
1505 if (flags & LEX_NO_NEXT_CHUNK)
1507 PL_parser->bufptr = s;
1508 l = CopLINE(PL_curcop);
1509 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1510 got_more = lex_next_chunk(flags);
1511 CopLINE_set(PL_curcop, l);
1512 s = PL_parser->bufptr;
1513 bufend = PL_parser->bufend;
1516 if (can_incline && need_incline && PL_parser->rsfp) {
1524 PL_parser->bufptr = s;
1529 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1531 This function performs syntax checking on a prototype, C<proto>.
1532 If C<warn> is true, any illegal characters or mismatched brackets
1533 will trigger illegalproto warnings, declaring that they were
1534 detected in the prototype for C<name>.
1536 The return value is C<true> if this is a valid prototype, and
1537 C<false> if it is not, regardless of whether C<warn> was C<true> or
1540 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1547 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1549 STRLEN len, origlen;
1550 char *p = proto ? SvPV(proto, len) : NULL;
1551 bool bad_proto = FALSE;
1552 bool in_brackets = FALSE;
1553 bool after_slash = FALSE;
1554 char greedy_proto = ' ';
1555 bool proto_after_greedy_proto = FALSE;
1556 bool must_be_last = FALSE;
1557 bool underscore = FALSE;
1558 bool bad_proto_after_underscore = FALSE;
1560 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1566 for (; len--; p++) {
1569 proto_after_greedy_proto = TRUE;
1571 if (!strchr(";@%", *p))
1572 bad_proto_after_underscore = TRUE;
1575 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1582 in_brackets = FALSE;
1583 else if ((*p == '@' || *p == '%') &&
1586 must_be_last = TRUE;
1595 after_slash = FALSE;
1600 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1603 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1604 origlen, UNI_DISPLAY_ISPRINT)
1605 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1607 if (proto_after_greedy_proto)
1608 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1609 "Prototype after '%c' for %"SVf" : %s",
1610 greedy_proto, SVfARG(name), p);
1612 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1613 "Missing ']' in prototype for %"SVf" : %s",
1616 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1617 "Illegal character in prototype for %"SVf" : %s",
1619 if (bad_proto_after_underscore)
1620 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1621 "Illegal character after '_' in prototype for %"SVf" : %s",
1625 return (! (proto_after_greedy_proto || bad_proto) );
1630 * This subroutine has nothing to do with tilting, whether at windmills
1631 * or pinball tables. Its name is short for "increment line". It
1632 * increments the current line number in CopLINE(PL_curcop) and checks
1633 * to see whether the line starts with a comment of the form
1634 * # line 500 "foo.pm"
1635 * If so, it sets the current line number and file to the values in the comment.
1639 S_incline(pTHX_ const char *s)
1647 PERL_ARGS_ASSERT_INCLINE;
1649 COPLINE_INC_WITH_HERELINES;
1650 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1651 && s+1 == PL_bufend && *s == ';') {
1652 /* fake newline in string eval */
1653 CopLINE_dec(PL_curcop);
1658 while (SPACE_OR_TAB(*s))
1660 if (strnEQ(s, "line", 4))
1664 if (SPACE_OR_TAB(*s))
1668 while (SPACE_OR_TAB(*s))
1676 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1678 while (SPACE_OR_TAB(*s))
1680 if (*s == '"' && (t = strchr(s+1, '"'))) {
1686 while (!isSPACE(*t))
1690 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1692 if (*e != '\n' && *e != '\0')
1693 return; /* false alarm */
1695 line_num = atoi(n)-1;
1698 const STRLEN len = t - s;
1700 if (!PL_rsfp && !PL_parser->filtered) {
1701 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1702 * to *{"::_<newfilename"} */
1703 /* However, the long form of evals is only turned on by the
1704 debugger - usually they're "(eval %lu)" */
1705 GV * const cfgv = CopFILEGV(PL_curcop);
1708 STRLEN tmplen2 = len;
1712 if (tmplen2 + 2 <= sizeof smallbuf)
1715 Newx(tmpbuf2, tmplen2 + 2, char);
1720 memcpy(tmpbuf2 + 2, s, tmplen2);
1723 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1725 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1726 /* adjust ${"::_<newfilename"} to store the new file name */
1727 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1728 /* The line number may differ. If that is the case,
1729 alias the saved lines that are in the array.
1730 Otherwise alias the whole array. */
1731 if (CopLINE(PL_curcop) == line_num) {
1732 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1733 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1735 else if (GvAV(cfgv)) {
1736 AV * const av = GvAV(cfgv);
1737 const I32 start = CopLINE(PL_curcop)+1;
1738 I32 items = AvFILLp(av) - start;
1740 AV * const av2 = GvAVn(gv2);
1741 SV **svp = AvARRAY(av) + start;
1742 I32 l = (I32)line_num+1;
1744 av_store(av2, l++, SvREFCNT_inc(*svp++));
1749 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1752 CopFILE_free(PL_curcop);
1753 CopFILE_setn(PL_curcop, s, len);
1755 CopLINE_set(PL_curcop, line_num);
1758 #define skipspace(s) skipspace_flags(s, 0)
1762 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1764 AV *av = CopFILEAVx(PL_curcop);
1767 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1769 sv = *av_fetch(av, 0, 1);
1770 SvUPGRADE(sv, SVt_PVMG);
1772 if (!SvPOK(sv)) sv_setpvs(sv,"");
1774 sv_catsv(sv, orig_sv);
1776 sv_catpvn(sv, buf, len);
1781 if (PL_parser->preambling == NOLINE)
1782 av_store(av, CopLINE(PL_curcop), sv);
1788 * Called to gobble the appropriate amount and type of whitespace.
1789 * Skips comments as well.
1793 S_skipspace_flags(pTHX_ char *s, U32 flags)
1795 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1796 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1797 while (s < PL_bufend && SPACE_OR_TAB(*s))
1800 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1802 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1803 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1804 LEX_NO_NEXT_CHUNK : 0));
1806 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1807 if (PL_linestart > PL_bufptr)
1808 PL_bufptr = PL_linestart;
1816 * Check the unary operators to ensure there's no ambiguity in how they're
1817 * used. An ambiguous piece of code would be:
1819 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1820 * the +5 is its argument.
1830 if (PL_oldoldbufptr != PL_last_uni)
1832 while (isSPACE(*PL_last_uni))
1835 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1837 if ((t = strchr(s, '(')) && t < PL_bufptr)
1840 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1841 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1842 (int)(s - PL_last_uni), PL_last_uni);
1846 * LOP : macro to build a list operator. Its behaviour has been replaced
1847 * with a subroutine, S_lop() for which LOP is just another name.
1850 #define LOP(f,x) return lop(f,x,s)
1854 * Build a list operator (or something that might be one). The rules:
1855 * - if we have a next token, then it's a list operator [why?]
1856 * - if the next thing is an opening paren, then it's a function
1857 * - else it's a list operator
1861 S_lop(pTHX_ I32 f, int x, char *s)
1865 PERL_ARGS_ASSERT_LOP;
1871 PL_last_lop = PL_oldbufptr;
1872 PL_last_lop_op = (OPCODE)f;
1876 return REPORT(FUNC);
1879 return REPORT(FUNC);
1882 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1883 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1884 return REPORT(LSTOP);
1890 * When the lexer realizes it knows the next token (for instance,
1891 * it is reordering tokens for the parser) then it can call S_force_next
1892 * to know what token to return the next time the lexer is called. Caller
1893 * will need to set PL_nextval[] and possibly PL_expect to ensure
1894 * the lexer handles the token correctly.
1898 S_force_next(pTHX_ I32 type)
1903 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1904 tokereport(type, &NEXTVAL_NEXTTOKE);
1907 PL_nexttype[PL_nexttoke] = type;
1909 if (PL_lex_state != LEX_KNOWNEXT) {
1910 PL_lex_defer = PL_lex_state;
1911 PL_lex_expect = PL_expect;
1912 PL_lex_state = LEX_KNOWNEXT;
1919 * This subroutine handles postfix deref syntax after the arrow has already
1920 * been emitted. @* $* etc. are emitted as two separate token right here.
1921 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1922 * only the first, leaving yylex to find the next.
1926 S_postderef(pTHX_ int const funny, char const next)
1929 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1930 assert(strchr("*[{", next));
1932 PL_expect = XOPERATOR;
1933 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1934 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1935 PL_lex_state = LEX_INTERPEND;
1936 force_next(POSTJOIN);
1942 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1943 && !PL_lex_brackets)
1945 PL_expect = XOPERATOR;
1954 int yyc = PL_parser->yychar;
1955 if (yyc != YYEMPTY) {
1957 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1958 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1959 PL_lex_allbrackets--;
1961 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1962 } else if (yyc == '('/*)*/) {
1963 PL_lex_allbrackets--;
1968 PL_parser->yychar = YYEMPTY;
1973 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1976 SV * const sv = newSVpvn_utf8(start, len,
1979 && !is_ascii_string((const U8*)start, len)
1980 && is_utf8_string((const U8*)start, len));
1986 * When the lexer knows the next thing is a word (for instance, it has
1987 * just seen -> and it knows that the next char is a word char, then
1988 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1992 * char *start : buffer position (must be within PL_linestr)
1993 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1994 * int check_keyword : if true, Perl checks to make sure the word isn't
1995 * a keyword (do this if the word is a label, e.g. goto FOO)
1996 * int allow_pack : if true, : characters will also be allowed (require,
1997 * use, etc. do this)
1998 * int allow_initial_tick : used by the "sub" lexer only.
2002 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2008 PERL_ARGS_ASSERT_FORCE_WORD;
2010 start = SKIPSPACE1(start);
2012 if (isIDFIRST_lazy_if(s,UTF) ||
2013 (allow_pack && *s == ':') )
2015 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2016 if (check_keyword) {
2017 char *s2 = PL_tokenbuf;
2018 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2020 if (keyword(s2, len, 0))
2023 if (token == METHOD) {
2028 PL_expect = XOPERATOR;
2031 NEXTVAL_NEXTTOKE.opval
2032 = (OP*)newSVOP(OP_CONST,0,
2033 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2034 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2042 * Called when the lexer wants $foo *foo &foo etc, but the program
2043 * text only contains the "foo" portion. The first argument is a pointer
2044 * to the "foo", and the second argument is the type symbol to prefix.
2045 * Forces the next token to be a "WORD".
2046 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2050 S_force_ident(pTHX_ const char *s, int kind)
2054 PERL_ARGS_ASSERT_FORCE_IDENT;
2057 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2058 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2059 UTF ? SVf_UTF8 : 0));
2060 NEXTVAL_NEXTTOKE.opval = o;
2063 o->op_private = OPpCONST_ENTERED;
2064 /* XXX see note in pp_entereval() for why we forgo typo
2065 warnings if the symbol must be introduced in an eval.
2067 gv_fetchpvn_flags(s, len,
2068 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2069 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2070 kind == '$' ? SVt_PV :
2071 kind == '@' ? SVt_PVAV :
2072 kind == '%' ? SVt_PVHV :
2080 S_force_ident_maybe_lex(pTHX_ char pit)
2082 NEXTVAL_NEXTTOKE.ival = pit;
2087 Perl_str_to_version(pTHX_ SV *sv)
2092 const char *start = SvPV_const(sv,len);
2093 const char * const end = start + len;
2094 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2096 PERL_ARGS_ASSERT_STR_TO_VERSION;
2098 while (start < end) {
2102 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2107 retval += ((NV)n)/nshift;
2116 * Forces the next token to be a version number.
2117 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2118 * and if "guessing" is TRUE, then no new token is created (and the caller
2119 * must use an alternative parsing method).
2123 S_force_version(pTHX_ char *s, int guessing)
2129 PERL_ARGS_ASSERT_FORCE_VERSION;
2137 while (isDIGIT(*d) || *d == '_' || *d == '.')
2139 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2141 s = scan_num(s, &pl_yylval);
2142 version = pl_yylval.opval;
2143 ver = cSVOPx(version)->op_sv;
2144 if (SvPOK(ver) && !SvNIOK(ver)) {
2145 SvUPGRADE(ver, SVt_PVNV);
2146 SvNV_set(ver, str_to_version(ver));
2147 SvNOK_on(ver); /* hint that it is a version */
2150 else if (guessing) {
2155 /* NOTE: The parser sees the package name and the VERSION swapped */
2156 NEXTVAL_NEXTTOKE.opval = version;
2163 * S_force_strict_version
2164 * Forces the next token to be a version number using strict syntax rules.
2168 S_force_strict_version(pTHX_ char *s)
2172 const char *errstr = NULL;
2174 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2176 while (isSPACE(*s)) /* leading whitespace */
2179 if (is_STRICT_VERSION(s,&errstr)) {
2181 s = (char *)scan_version(s, ver, 0);
2182 version = newSVOP(OP_CONST, 0, ver);
2184 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2185 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2189 yyerror(errstr); /* version required */
2193 /* NOTE: The parser sees the package name and the VERSION swapped */
2194 NEXTVAL_NEXTTOKE.opval = version;
2202 * Tokenize a quoted string passed in as an SV. It finds the next
2203 * chunk, up to end of string or a backslash. It may make a new
2204 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2209 S_tokeq(pTHX_ SV *sv)
2217 PERL_ARGS_ASSERT_TOKEQ;
2221 assert (!SvIsCOW(sv));
2222 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2226 /* This is relying on the SV being "well formed" with a trailing '\0' */
2227 while (s < send && !(*s == '\\' && s[1] == '\\'))
2232 if ( PL_hints & HINT_NEW_STRING ) {
2233 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2234 SVs_TEMP | SvUTF8(sv));
2238 if (s + 1 < send && (s[1] == '\\'))
2239 s++; /* all that, just for this */
2244 SvCUR_set(sv, d - SvPVX_const(sv));
2246 if ( PL_hints & HINT_NEW_STRING )
2247 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2252 * Now come three functions related to double-quote context,
2253 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2254 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2255 * interact with PL_lex_state, and create fake ( ... ) argument lists
2256 * to handle functions and concatenation.
2260 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2265 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2267 * Pattern matching will set PL_lex_op to the pattern-matching op to
2268 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2270 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2272 * Everything else becomes a FUNC.
2274 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2275 * had an OP_CONST or OP_READLINE). This just sets us up for a
2276 * call to S_sublex_push().
2280 S_sublex_start(pTHX)
2283 const I32 op_type = pl_yylval.ival;
2285 if (op_type == OP_NULL) {
2286 pl_yylval.opval = PL_lex_op;
2290 if (op_type == OP_CONST) {
2291 SV *sv = tokeq(PL_lex_stuff);
2293 if (SvTYPE(sv) == SVt_PVIV) {
2294 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2296 const char * const p = SvPV_const(sv, len);
2297 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2301 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2302 PL_lex_stuff = NULL;
2306 PL_sublex_info.super_state = PL_lex_state;
2307 PL_sublex_info.sub_inwhat = (U16)op_type;
2308 PL_sublex_info.sub_op = PL_lex_op;
2309 PL_lex_state = LEX_INTERPPUSH;
2313 pl_yylval.opval = PL_lex_op;
2323 * Create a new scope to save the lexing state. The scope will be
2324 * ended in S_sublex_done. Returns a '(', starting the function arguments
2325 * to the uc, lc, etc. found before.
2326 * Sets PL_lex_state to LEX_INTERPCONCAT.
2334 const bool is_heredoc = PL_multi_close == '<';
2337 PL_lex_state = PL_sublex_info.super_state;
2338 SAVEI8(PL_lex_dojoin);
2339 SAVEI32(PL_lex_brackets);
2340 SAVEI32(PL_lex_allbrackets);
2341 SAVEI32(PL_lex_formbrack);
2342 SAVEI8(PL_lex_fakeeof);
2343 SAVEI32(PL_lex_casemods);
2344 SAVEI32(PL_lex_starts);
2345 SAVEI8(PL_lex_state);
2346 SAVESPTR(PL_lex_repl);
2347 SAVEVPTR(PL_lex_inpat);
2348 SAVEI16(PL_lex_inwhat);
2351 SAVECOPLINE(PL_curcop);
2352 SAVEI32(PL_multi_end);
2353 SAVEI32(PL_parser->herelines);
2354 PL_parser->herelines = 0;
2356 SAVEI8(PL_multi_close);
2357 SAVEPPTR(PL_bufptr);
2358 SAVEPPTR(PL_bufend);
2359 SAVEPPTR(PL_oldbufptr);
2360 SAVEPPTR(PL_oldoldbufptr);
2361 SAVEPPTR(PL_last_lop);
2362 SAVEPPTR(PL_last_uni);
2363 SAVEPPTR(PL_linestart);
2364 SAVESPTR(PL_linestr);
2365 SAVEGENERICPV(PL_lex_brackstack);
2366 SAVEGENERICPV(PL_lex_casestack);
2367 SAVEGENERICPV(PL_parser->lex_shared);
2368 SAVEBOOL(PL_parser->lex_re_reparsing);
2369 SAVEI32(PL_copline);
2371 /* The here-doc parser needs to be able to peek into outer lexing
2372 scopes to find the body of the here-doc. So we put PL_linestr and
2373 PL_bufptr into lex_shared, to ‘share’ those values.
2375 PL_parser->lex_shared->ls_linestr = PL_linestr;
2376 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2378 PL_linestr = PL_lex_stuff;
2379 PL_lex_repl = PL_sublex_info.repl;
2380 PL_lex_stuff = NULL;
2381 PL_sublex_info.repl = NULL;
2383 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2384 = SvPVX(PL_linestr);
2385 PL_bufend += SvCUR(PL_linestr);
2386 PL_last_lop = PL_last_uni = NULL;
2387 SAVEFREESV(PL_linestr);
2388 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2390 PL_lex_dojoin = FALSE;
2391 PL_lex_brackets = PL_lex_formbrack = 0;
2392 PL_lex_allbrackets = 0;
2393 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2394 Newx(PL_lex_brackstack, 120, char);
2395 Newx(PL_lex_casestack, 12, char);
2396 PL_lex_casemods = 0;
2397 *PL_lex_casestack = '\0';
2399 PL_lex_state = LEX_INTERPCONCAT;
2401 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2402 PL_copline = NOLINE;
2404 Newxz(shared, 1, LEXSHARED);
2405 shared->ls_prev = PL_parser->lex_shared;
2406 PL_parser->lex_shared = shared;
2408 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2409 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2410 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2411 PL_lex_inpat = PL_sublex_info.sub_op;
2413 PL_lex_inpat = NULL;
2415 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2416 PL_in_eval &= ~EVAL_RE_REPARSING;
2423 * Restores lexer state after a S_sublex_push.
2430 if (!PL_lex_starts++) {
2431 SV * const sv = newSVpvs("");
2432 if (SvUTF8(PL_linestr))
2434 PL_expect = XOPERATOR;
2435 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2439 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2440 PL_lex_state = LEX_INTERPCASEMOD;
2444 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2445 assert(PL_lex_inwhat != OP_TRANSR);
2447 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2448 PL_linestr = PL_lex_repl;
2450 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2451 PL_bufend += SvCUR(PL_linestr);
2452 PL_last_lop = PL_last_uni = NULL;
2453 PL_lex_dojoin = FALSE;
2454 PL_lex_brackets = 0;
2455 PL_lex_allbrackets = 0;
2456 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2457 PL_lex_casemods = 0;
2458 *PL_lex_casestack = '\0';
2460 if (SvEVALED(PL_lex_repl)) {
2461 PL_lex_state = LEX_INTERPNORMAL;
2463 /* we don't clear PL_lex_repl here, so that we can check later
2464 whether this is an evalled subst; that means we rely on the
2465 logic to ensure sublex_done() is called again only via the
2466 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2469 PL_lex_state = LEX_INTERPCONCAT;
2472 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2473 CopLINE(PL_curcop) +=
2474 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2475 + PL_parser->herelines;
2476 PL_parser->herelines = 0;
2481 const line_t l = CopLINE(PL_curcop);
2483 if (PL_multi_close == '<')
2484 PL_parser->herelines += l - PL_multi_end;
2485 PL_bufend = SvPVX(PL_linestr);
2486 PL_bufend += SvCUR(PL_linestr);
2487 PL_expect = XOPERATOR;
2488 PL_sublex_info.sub_inwhat = 0;
2493 PERL_STATIC_INLINE SV*
2494 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2496 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2497 * interior, hence to the "}". Finds what the name resolves to, returning
2498 * an SV* containing it; NULL if no valid one found */
2500 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2507 const U8* first_bad_char_loc;
2508 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2510 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2512 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2514 &first_bad_char_loc))
2516 /* If warnings are on, this will print a more detailed analysis of what
2517 * is wrong than the error message below */
2518 utf8n_to_uvchr(first_bad_char_loc,
2519 e - ((char *) first_bad_char_loc),
2522 /* We deliberately don't try to print the malformed character, which
2523 * might not print very well; it also may be just the first of many
2524 * malformations, so don't print what comes after it */
2525 yyerror(Perl_form(aTHX_
2526 "Malformed UTF-8 character immediately after '%.*s'",
2527 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2531 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2532 /* include the <}> */
2533 e - backslash_ptr + 1);
2535 SvREFCNT_dec_NN(res);
2539 /* See if the charnames handler is the Perl core's, and if so, we can skip
2540 * the validation needed for a user-supplied one, as Perl's does its own
2542 table = GvHV(PL_hintgv); /* ^H */
2543 cvp = hv_fetchs(table, "charnames", FALSE);
2544 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2545 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2547 const char * const name = HvNAME(stash);
2548 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2549 && strEQ(name, "_charnames")) {
2554 /* Here, it isn't Perl's charname handler. We can't rely on a
2555 * user-supplied handler to validate the input name. For non-ut8 input,
2556 * look to see that the first character is legal. Then loop through the
2557 * rest checking that each is a continuation */
2559 /* This code makes the reasonable assumption that the only Latin1-range
2560 * characters that begin a character name alias are alphabetic, otherwise
2561 * would have to create a isCHARNAME_BEGIN macro */
2564 if (! isALPHAU(*s)) {
2569 if (! isCHARNAME_CONT(*s)) {
2572 if (*s == ' ' && *(s-1) == ' ') {
2575 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2576 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2577 "NO-BREAK SPACE in a charnames "
2578 "alias definition is deprecated");
2584 /* Similarly for utf8. For invariants can check directly; for other
2585 * Latin1, can calculate their code point and check; otherwise use a
2587 if (UTF8_IS_INVARIANT(*s)) {
2588 if (! isALPHAU(*s)) {
2592 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2593 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2599 if (! PL_utf8_charname_begin) {
2600 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2601 PL_utf8_charname_begin = _core_swash_init("utf8",
2602 "_Perl_Charname_Begin",
2604 1, 0, NULL, &flags);
2606 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2613 if (UTF8_IS_INVARIANT(*s)) {
2614 if (! isCHARNAME_CONT(*s)) {
2617 if (*s == ' ' && *(s-1) == ' ') {
2622 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2623 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2627 if (*s == *NBSP_UTF8
2628 && *(s+1) == *(NBSP_UTF8+1)
2629 && ckWARN_d(WARN_DEPRECATED))
2631 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2632 "NO-BREAK SPACE in a charnames "
2633 "alias definition is deprecated");
2638 if (! PL_utf8_charname_continue) {
2639 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2640 PL_utf8_charname_continue = _core_swash_init("utf8",
2641 "_Perl_Charname_Continue",
2643 1, 0, NULL, &flags);
2645 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2652 if (*(s-1) == ' ') {
2655 "charnames alias definitions may not contain trailing "
2656 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2657 (int)(s - backslash_ptr + 1), backslash_ptr,
2658 (int)(e - s + 1), s + 1
2660 UTF ? SVf_UTF8 : 0);
2664 if (SvUTF8(res)) { /* Don't accept malformed input */
2665 const U8* first_bad_char_loc;
2667 const char* const str = SvPV_const(res, len);
2668 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2669 /* If warnings are on, this will print a more detailed analysis of
2670 * what is wrong than the error message below */
2671 utf8n_to_uvchr(first_bad_char_loc,
2672 (char *) first_bad_char_loc - str,
2675 /* We deliberately don't try to print the malformed character,
2676 * which might not print very well; it also may be just the first
2677 * of many malformations, so don't print what comes after it */
2680 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2681 (int) (e - backslash_ptr + 1), backslash_ptr,
2682 (int) ((char *) first_bad_char_loc - str), str
2693 /* The final %.*s makes sure that should the trailing NUL be missing
2694 * that this print won't run off the end of the string */
2697 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2698 (int)(s - backslash_ptr + 1), backslash_ptr,
2699 (int)(e - s + 1), s + 1
2701 UTF ? SVf_UTF8 : 0);
2708 "charnames alias definitions may not contain a sequence of "
2709 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2710 (int)(s - backslash_ptr + 1), backslash_ptr,
2711 (int)(e - s + 1), s + 1
2713 UTF ? SVf_UTF8 : 0);
2720 Extracts the next constant part of a pattern, double-quoted string,
2721 or transliteration. This is terrifying code.
2723 For example, in parsing the double-quoted string "ab\x63$d", it would
2724 stop at the '$' and return an OP_CONST containing 'abc'.
2726 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2727 processing a pattern (PL_lex_inpat is true), a transliteration
2728 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2730 Returns a pointer to the character scanned up to. If this is
2731 advanced from the start pointer supplied (i.e. if anything was
2732 successfully parsed), will leave an OP_CONST for the substring scanned
2733 in pl_yylval. Caller must intuit reason for not parsing further
2734 by looking at the next characters herself.
2738 \N{FOO} => \N{U+hex_for_character_FOO}
2739 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2742 all other \-char, including \N and \N{ apart from \N{ABC}
2745 @ and $ where it appears to be a var, but not for $ as tail anchor
2750 In transliterations:
2751 characters are VERY literal, except for - not at the start or end
2752 of the string, which indicates a range. If the range is in bytes,
2753 scan_const expands the range to the full set of intermediate
2754 characters. If the range is in utf8, the hyphen is replaced with
2755 a certain range mark which will be handled by pmtrans() in op.c.
2757 In double-quoted strings:
2759 double-quoted style: \r and \n
2760 constants: \x31, etc.
2761 deprecated backrefs: \1 (in substitution replacements)
2762 case and quoting: \U \Q \E
2765 scan_const does *not* construct ops to handle interpolated strings.
2766 It stops processing as soon as it finds an embedded $ or @ variable
2767 and leaves it to the caller to work out what's going on.
2769 embedded arrays (whether in pattern or not) could be:
2770 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2772 $ in double-quoted strings must be the symbol of an embedded scalar.
2774 $ in pattern could be $foo or could be tail anchor. Assumption:
2775 it's a tail anchor if $ is the last thing in the string, or if it's
2776 followed by one of "()| \r\n\t"
2778 \1 (backreferences) are turned into $1 in substitutions
2780 The structure of the code is
2781 while (there's a character to process) {
2782 handle transliteration ranges
2783 skip regexp comments /(?#comment)/ and codes /(?{code})/
2784 skip #-initiated comments in //x patterns
2785 check for embedded arrays
2786 check for embedded scalars
2788 deprecate \1 in substitution replacements
2789 handle string-changing backslashes \l \U \Q \E, etc.
2790 switch (what was escaped) {
2791 handle \- in a transliteration (becomes a literal -)
2792 if a pattern and not \N{, go treat as regular character
2793 handle \132 (octal characters)
2794 handle \x15 and \x{1234} (hex characters)
2795 handle \N{name} (named characters, also \N{3,5} in a pattern)
2796 handle \cV (control characters)
2797 handle printf-style backslashes (\f, \r, \n, etc)
2800 } (end if backslash)
2801 handle regular character
2802 } (end while character to read)
2807 S_scan_const(pTHX_ char *start)
2810 char *send = PL_bufend; /* end of the constant */
2811 SV *sv = newSV(send - start); /* sv for the constant. See
2812 note below on sizing. */
2813 char *s = start; /* start of the constant */
2814 char *d = SvPVX(sv); /* destination for copies */
2815 bool dorange = FALSE; /* are we in a translit range? */
2816 bool didrange = FALSE; /* did we just finish a range? */
2817 bool in_charclass = FALSE; /* within /[...]/ */
2818 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2819 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2820 to be UTF8? But, this can
2821 show as true when the source
2822 isn't utf8, as for example
2823 when it is entirely composed
2825 SV *res; /* result from charnames */
2827 /* Note on sizing: The scanned constant is placed into sv, which is
2828 * initialized by newSV() assuming one byte of output for every byte of
2829 * input. This routine expects newSV() to allocate an extra byte for a
2830 * trailing NUL, which this routine will append if it gets to the end of
2831 * the input. There may be more bytes of input than output (eg., \N{LATIN
2832 * CAPITAL LETTER A}), or more output than input if the constant ends up
2833 * recoded to utf8, but each time a construct is found that might increase
2834 * the needed size, SvGROW() is called. Its size parameter each time is
2835 * based on the best guess estimate at the time, namely the length used so
2836 * far, plus the length the current construct will occupy, plus room for
2837 * the trailing NUL, plus one byte for every input byte still unscanned */
2839 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2842 UV literal_endpoint = 0;
2843 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2846 PERL_ARGS_ASSERT_SCAN_CONST;
2848 assert(PL_lex_inwhat != OP_TRANSR);
2849 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2850 /* If we are doing a trans and we know we want UTF8 set expectation */
2851 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2852 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2855 /* Protect sv from errors and fatal warnings. */
2856 ENTER_with_name("scan_const");
2859 while (s < send || dorange) {
2861 /* get transliterations out of the way (they're most literal) */
2862 if (PL_lex_inwhat == OP_TRANS) {
2863 /* expand a range A-Z to the full set of characters. AIE! */
2865 I32 i; /* current expanded character */
2866 I32 min; /* first character in range */
2867 I32 max; /* last character in range */
2878 char * const c = (char*)utf8_hop((U8*)d, -1);
2882 *c = (char) ILLEGAL_UTF8_BYTE;
2883 /* mark the range as done, and continue */
2889 i = d - SvPVX_const(sv); /* remember current offset */
2892 SvLEN(sv) + (has_utf8 ?
2893 (512 - UTF_CONTINUATION_MARK +
2896 /* How many two-byte within 0..255: 128 in UTF-8,
2897 * 96 in UTF-8-mod. */
2899 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2901 d = SvPVX(sv) + i; /* refresh d after realloc */
2905 for (j = 0; j <= 1; j++) {
2906 char * const c = (char*)utf8_hop((U8*)d, -1);
2907 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2913 max = (U8)0xff; /* only to \xff */
2914 uvmax = uv; /* \x{100} to uvmax */
2916 d = c; /* eat endpoint chars */
2921 d -= 2; /* eat the first char and the - */
2922 min = (U8)*d; /* first char in range */
2923 max = (U8)d[1]; /* last char in range */
2930 "Invalid range \"%c-%c\" in transliteration operator",
2931 (char)min, (char)max);
2935 if (literal_endpoint == 2 &&
2936 ((isLOWER_A(min) && isLOWER_A(max)) ||
2937 (isUPPER_A(min) && isUPPER_A(max))))
2939 for (i = min; i <= max; i++) {
2946 for (i = min; i <= max; i++)
2949 append_utf8_from_native_byte(i, &d);
2957 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2959 *d++ = (char) ILLEGAL_UTF8_BYTE;
2961 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2965 /* mark the range as done, and continue */
2969 literal_endpoint = 0;
2974 /* range begins (ignore - as first or last char) */
2975 else if (*s == '-' && s+1 < send && s != start) {
2977 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2984 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2994 literal_endpoint = 0;
2995 native_range = TRUE;
3000 /* if we get here, we're not doing a transliteration */
3002 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3005 while (s1 >= start && *s1-- == '\\')
3008 in_charclass = TRUE;
3011 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3014 while (s1 >= start && *s1-- == '\\')
3017 in_charclass = FALSE;
3020 /* skip for regexp comments /(?#comment)/, except for the last
3021 * char, which will be done separately.
3022 * Stop on (?{..}) and friends */
3024 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3026 while (s+1 < send && *s != ')')
3029 else if (!PL_lex_casemods &&
3030 ( s[2] == '{' /* This should match regcomp.c */
3031 || (s[2] == '?' && s[3] == '{')))
3037 /* likewise skip #-initiated comments in //x patterns */
3038 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3039 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3040 while (s+1 < send && *s != '\n')
3044 /* no further processing of single-quoted regex */
3045 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3046 goto default_action;
3048 /* check for embedded arrays
3049 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3051 else if (*s == '@' && s[1]) {
3052 if (isWORDCHAR_lazy_if(s+1,UTF))
3054 if (strchr(":'{$", s[1]))
3056 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3057 break; /* in regexp, neither @+ nor @- are interpolated */
3060 /* check for embedded scalars. only stop if we're sure it's a
3063 else if (*s == '$') {
3064 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3066 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3068 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3069 "Possible unintended interpolation of $\\ in regex");
3071 break; /* in regexp, $ might be tail anchor */
3075 /* End of else if chain - OP_TRANS rejoin rest */
3078 if (*s == '\\' && s+1 < send) {
3079 char* e; /* Can be used for ending '}', etc. */
3083 /* warn on \1 - \9 in substitution replacements, but note that \11
3084 * is an octal; and \19 is \1 followed by '9' */
3085 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3086 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3088 /* diag_listed_as: \%d better written as $%d */
3089 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3094 /* string-change backslash escapes */
3095 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3099 /* In a pattern, process \N, but skip any other backslash escapes.
3100 * This is because we don't want to translate an escape sequence
3101 * into a meta symbol and have the regex compiler use the meta
3102 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3103 * in spite of this, we do have to process \N here while the proper
3104 * charnames handler is in scope. See bugs #56444 and #62056.
3105 * There is a complication because \N in a pattern may also stand
3106 * for 'match a non-nl', and not mean a charname, in which case its
3107 * processing should be deferred to the regex compiler. To be a
3108 * charname it must be followed immediately by a '{', and not look
3109 * like \N followed by a curly quantifier, i.e., not something like
3110 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3112 else if (PL_lex_inpat
3115 || regcurly(s + 1)))
3118 goto default_action;
3123 /* quoted - in transliterations */
3125 if (PL_lex_inwhat == OP_TRANS) {
3132 if ((isALPHANUMERIC(*s)))
3133 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3134 "Unrecognized escape \\%c passed through",
3136 /* default action is to copy the quoted character */
3137 goto default_action;
3140 /* eg. \132 indicates the octal constant 0132 */
3141 case '0': case '1': case '2': case '3':
3142 case '4': case '5': case '6': case '7':
3144 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3146 uv = grok_oct(s, &len, &flags, NULL);
3148 if (len < 3 && s < send && isDIGIT(*s)
3149 && ckWARN(WARN_MISC))
3151 Perl_warner(aTHX_ packWARN(WARN_MISC),
3152 "%s", form_short_octal_warning(s, len));
3155 goto NUM_ESCAPE_INSERT;
3157 /* eg. \o{24} indicates the octal constant \024 */
3162 bool valid = grok_bslash_o(&s, &uv, &error,
3163 TRUE, /* Output warning */
3164 FALSE, /* Not strict */
3165 TRUE, /* Output warnings for
3172 goto NUM_ESCAPE_INSERT;
3175 /* eg. \x24 indicates the hex constant 0x24 */
3180 bool valid = grok_bslash_x(&s, &uv, &error,
3181 TRUE, /* Output warning */
3182 FALSE, /* Not strict */
3183 TRUE, /* Output warnings for
3193 /* Insert oct or hex escaped character. There will always be
3194 * enough room in sv since such escapes will be longer than any
3195 * UTF-8 sequence they can end up as, except if they force us
3196 * to recode the rest of the string into utf8 */
3198 /* Here uv is the ordinal of the next character being added */
3199 if (!UVCHR_IS_INVARIANT(uv)) {
3200 if (!has_utf8 && uv > 255) {
3201 /* Might need to recode whatever we have accumulated so
3202 * far if it contains any chars variant in utf8 or
3205 SvCUR_set(sv, d - SvPVX_const(sv));
3208 /* See Note on sizing above. */
3209 sv_utf8_upgrade_flags_grow(sv,
3210 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3211 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3212 d = SvPVX(sv) + SvCUR(sv);
3217 d = (char*)uvchr_to_utf8((U8*)d, uv);
3218 if (PL_lex_inwhat == OP_TRANS &&
3219 PL_sublex_info.sub_op) {
3220 PL_sublex_info.sub_op->op_private |=
3221 (PL_lex_repl ? OPpTRANS_FROM_UTF
3225 if (uv > 255 && !dorange)
3226 native_range = FALSE;
3239 /* In a non-pattern \N must be a named character, like \N{LATIN
3240 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3241 * mean to match a non-newline. For non-patterns, named
3242 * characters are converted to their string equivalents. In
3243 * patterns, named characters are not converted to their
3244 * ultimate forms for the same reasons that other escapes
3245 * aren't. Instead, they are converted to the \N{U+...} form
3246 * to get the value from the charnames that is in effect right
3247 * now, while preserving the fact that it was a named character
3248 * so that the regex compiler knows this */
3250 /* The structure of this section of code (besides checking for
3251 * errors and upgrading to utf8) is:
3252 * Further disambiguate between the two meanings of \N, and if
3253 * not a charname, go process it elsewhere
3254 * If of form \N{U+...}, pass it through if a pattern;
3255 * otherwise convert to utf8
3256 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3257 * pattern; otherwise convert to utf8 */
3259 /* Here, s points to the 'N'; the test below is guaranteed to
3260 * succeed if we are being called on a pattern as we already
3261 * know from a test above that the next character is a '{'.
3262 * On a non-pattern \N must mean 'named sequence, which
3263 * requires braces */
3266 yyerror("Missing braces on \\N{}");
3271 /* If there is no matching '}', it is an error. */
3272 if (! (e = strchr(s, '}'))) {
3273 if (! PL_lex_inpat) {
3274 yyerror("Missing right brace on \\N{}");
3276 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3281 /* Here it looks like a named character */
3283 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3284 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3285 | PERL_SCAN_DISALLOW_PREFIX;
3288 /* For \N{U+...}, the '...' is a unicode value even on
3289 * EBCDIC machines */
3290 s += 2; /* Skip to next char after the 'U+' */
3292 uv = grok_hex(s, &len, &flags, NULL);
3293 if (len == 0 || len != (STRLEN)(e - s)) {
3294 yyerror("Invalid hexadecimal number in \\N{U+...}");
3301 /* On non-EBCDIC platforms, pass through to the regex
3302 * compiler unchanged. The reason we evaluated the
3303 * number above is to make sure there wasn't a syntax
3304 * error. But on EBCDIC we convert to native so
3305 * downstream code can continue to assume it's native
3307 s -= 5; /* Include the '\N{U+' */
3309 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3312 (unsigned int) UNI_TO_NATIVE(uv));
3314 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3318 else { /* Not a pattern: convert the hex to string */
3320 /* If destination is not in utf8, unconditionally
3321 * recode it to be so. This is because \N{} implies
3322 * Unicode semantics, and scalars have to be in utf8
3323 * to guarantee those semantics */
3325 SvCUR_set(sv, d - SvPVX_const(sv));
3328 /* See Note on sizing above. */
3329 sv_utf8_upgrade_flags_grow(
3331 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3332 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3333 d = SvPVX(sv) + SvCUR(sv);
3337 /* Add the (Unicode) code point to the output. */
3338 if (UNI_IS_INVARIANT(uv)) {
3339 *d++ = (char) LATIN1_TO_NATIVE(uv);
3342 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3346 else /* Here is \N{NAME} but not \N{U+...}. */
3347 if ((res = get_and_check_backslash_N_name(s, e)))
3350 const char *str = SvPV_const(res, len);
3353 if (! len) { /* The name resolved to an empty string */
3354 Copy("\\N{}", d, 4, char);
3358 /* In order to not lose information for the regex
3359 * compiler, pass the result in the specially made
3360 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3361 * the code points in hex of each character
3362 * returned by charnames */
3364 const char *str_end = str + len;
3365 const STRLEN off = d - SvPVX_const(sv);
3367 if (! SvUTF8(res)) {
3368 /* For the non-UTF-8 case, we can determine the
3369 * exact length needed without having to parse
3370 * through the string. Each character takes up
3371 * 2 hex digits plus either a trailing dot or
3373 d = off + SvGROW(sv, off
3375 + 6 /* For the "\N{U+", and
3377 + (STRLEN)(send - e));
3378 Copy("\\N{U+", d, 5, char);
3380 while (str < str_end) {
3382 my_snprintf(hex_string, sizeof(hex_string),
3383 "%02X.", (U8) *str);
3384 Copy(hex_string, d, 3, char);
3388 d--; /* We will overwrite below the final
3389 dot with a right brace */
3392 STRLEN char_length; /* cur char's byte length */
3394 /* and the number of bytes after this is
3395 * translated into hex digits */
3396 STRLEN output_length;
3398 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3399 * for max('U+', '.'); and 1 for NUL */
3400 char hex_string[2 * UTF8_MAXBYTES + 5];
3402 /* Get the first character of the result. */
3403 U32 uv = utf8n_to_uvchr((U8 *) str,
3407 /* Convert first code point to hex, including
3408 * the boiler plate before it. */
3410 my_snprintf(hex_string, sizeof(hex_string),
3414 /* Make sure there is enough space to hold it */
3415 d = off + SvGROW(sv, off
3417 + (STRLEN)(send - e)
3418 + 2); /* '}' + NUL */
3420 Copy(hex_string, d, output_length, char);
3423 /* For each subsequent character, append dot and
3424 * its ordinal in hex */
3425 while ((str += char_length) < str_end) {
3426 const STRLEN off = d - SvPVX_const(sv);
3427 U32 uv = utf8n_to_uvchr((U8 *) str,
3432 my_snprintf(hex_string,
3437 d = off + SvGROW(sv, off
3439 + (STRLEN)(send - e)
3440 + 2); /* '}' + NUL */
3441 Copy(hex_string, d, output_length, char);
3446 *d++ = '}'; /* Done. Add the trailing brace */
3449 else { /* Here, not in a pattern. Convert the name to a
3452 /* If destination is not in utf8, unconditionally
3453 * recode it to be so. This is because \N{} implies
3454 * Unicode semantics, and scalars have to be in utf8
3455 * to guarantee those semantics */
3457 SvCUR_set(sv, d - SvPVX_const(sv));
3460 /* See Note on sizing above. */
3461 sv_utf8_upgrade_flags_grow(sv,
3462 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3463 len + (STRLEN)(send - s) + 1);
3464 d = SvPVX(sv) + SvCUR(sv);
3466 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3468 /* See Note on sizing above. (NOTE: SvCUR() is not
3469 * set correctly here). */
3470 const STRLEN off = d - SvPVX_const(sv);
3471 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3473 if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
3474 sv_utf8_upgrade(res);
3475 str = SvPV_const(res, len);
3477 Copy(str, d, len, char);
3483 } /* End \N{NAME} */
3486 native_range = FALSE; /* \N{} is defined to be Unicode */
3488 s = e + 1; /* Point to just after the '}' */
3491 /* \c is a control character */
3495 *d++ = grok_bslash_c(*s++, 1);
3498 yyerror("Missing control char name in \\c");
3502 /* printf-style backslashes, formfeeds, newlines, etc */
3519 *d++ = ASCII_TO_NATIVE('\033');
3528 } /* end if (backslash) */
3535 /* If we started with encoded form, or already know we want it,
3536 then encode the next character */
3537 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3541 /* One might think that it is wasted effort in the case of the
3542 * source being utf8 (this_utf8 == TRUE) to take the next character
3543 * in the source, convert it to an unsigned value, and then convert
3544 * it back again. But the source has not been validated here. The
3545 * routine that does the conversion checks for errors like
3548 const UV nextuv = (this_utf8)
3549 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3551 const STRLEN need = UNISKIP(nextuv);
3553 SvCUR_set(sv, d - SvPVX_const(sv));
3556 /* See Note on sizing above. */
3557 sv_utf8_upgrade_flags_grow(sv,
3558 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3559 need + (STRLEN)(send - s) + 1);
3560 d = SvPVX(sv) + SvCUR(sv);
3562 } else if (need > len) {
3563 /* encoded value larger than old, may need extra space (NOTE:
3564 * SvCUR() is not set correctly here). See Note on sizing
3566 const STRLEN off = d - SvPVX_const(sv);
3567 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3571 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3573 if (uv > 255 && !dorange)
3574 native_range = FALSE;
3580 } /* while loop to process each character */
3582 /* terminate the string and set up the sv */
3584 SvCUR_set(sv, d - SvPVX_const(sv));
3585 if (SvCUR(sv) >= SvLEN(sv))
3586 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3587 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3590 if (PL_encoding && !has_utf8) {
3591 sv_recode_to_utf8(sv, PL_encoding);
3597 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3598 PL_sublex_info.sub_op->op_private |=
3599 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3603 /* shrink the sv if we allocated more than we used */
3604 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3605 SvPV_shrink_to_cur(sv);
3608 /* return the substring (via pl_yylval) only if we parsed anything */
3611 for (; s2 < s; s2++) {
3613 COPLINE_INC_WITH_HERELINES;
3615 SvREFCNT_inc_simple_void_NN(sv);
3616 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3617 && ! PL_parser->lex_re_reparsing)
3619 const char *const key = PL_lex_inpat ? "qr" : "q";
3620 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3624 if (PL_lex_inwhat == OP_TRANS) {
3627 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3630 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3638 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3641 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3643 LEAVE_with_name("scan_const");
3648 * Returns TRUE if there's more to the expression (e.g., a subscript),
3651 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3653 * ->[ and ->{ return TRUE
3654 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3655 * { and [ outside a pattern are always subscripts, so return TRUE
3656 * if we're outside a pattern and it's not { or [, then return FALSE
3657 * if we're in a pattern and the first char is a {
3658 * {4,5} (any digits around the comma) returns FALSE
3659 * if we're in a pattern and the first char is a [
3661 * [SOMETHING] has a funky algorithm to decide whether it's a
3662 * character class or not. It has to deal with things like
3663 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3664 * anything else returns TRUE
3667 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3670 S_intuit_more(pTHX_ char *s)
3674 PERL_ARGS_ASSERT_INTUIT_MORE;
3676 if (PL_lex_brackets)
3678 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3680 if (*s == '-' && s[1] == '>'
3681 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3682 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3683 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3685 if (*s != '{' && *s != '[')
3690 /* In a pattern, so maybe we have {n,m}. */
3698 /* On the other hand, maybe we have a character class */
3701 if (*s == ']' || *s == '^')
3704 /* this is terrifying, and it works */
3707 const char * const send = strchr(s,']');
3708 unsigned char un_char, last_un_char;
3709 char tmpbuf[sizeof PL_tokenbuf * 4];
3711 if (!send) /* has to be an expression */
3713 weight = 2; /* let's weigh the evidence */
3717 else if (isDIGIT(*s)) {
3719 if (isDIGIT(s[1]) && s[2] == ']')
3725 Zero(seen,256,char);
3727 for (; s < send; s++) {
3728 last_un_char = un_char;
3729 un_char = (unsigned char)*s;
3734 weight -= seen[un_char] * 10;
3735 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3737 char *tmp = PL_bufend;
3738 PL_bufend = (char*)send;
3739 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3741 len = (int)strlen(tmpbuf);
3742 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3743 UTF ? SVf_UTF8 : 0, SVt_PV))
3748 else if (*s == '$' && s[1] &&
3749 strchr("[#!%*<>()-=",s[1])) {
3750 if (/*{*/ strchr("])} =",s[2]))
3759 if (strchr("wds]",s[1]))
3761 else if (seen[(U8)'\''] || seen[(U8)'"'])
3763 else if (strchr("rnftbxcav",s[1]))
3765 else if (isDIGIT(s[1])) {
3767 while (s[1] && isDIGIT(s[1]))
3777 if (strchr("aA01! ",last_un_char))
3779 if (strchr("zZ79~",s[1]))
3781 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3782 weight -= 5; /* cope with negative subscript */
3785 if (!isWORDCHAR(last_un_char)
3786 && !(last_un_char == '$' || last_un_char == '@'
3787 || last_un_char == '&')
3788 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3793 if (keyword(tmpbuf, d - tmpbuf, 0))
3796 if (un_char == last_un_char + 1)
3798 weight -= seen[un_char];
3803 if (weight >= 0) /* probably a character class */
3813 * Does all the checking to disambiguate
3815 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3816 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3818 * First argument is the stuff after the first token, e.g. "bar".
3820 * Not a method if foo is a filehandle.
3821 * Not a method if foo is a subroutine prototyped to take a filehandle.
3822 * Not a method if it's really "Foo $bar"
3823 * Method if it's "foo $bar"
3824 * Not a method if it's really "print foo $bar"
3825 * Method if it's really "foo package::" (interpreted as package->foo)
3826 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3827 * Not a method if bar is a filehandle or package, but is quoted with
3832 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3835 char *s = start + (*start == '$');
3836 char tmpbuf[sizeof PL_tokenbuf];
3840 PERL_ARGS_ASSERT_INTUIT_METHOD;
3842 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3844 if (cv && SvPOK(cv)) {
3845 const char *proto = CvPROTO(cv);
3847 while (*proto && (isSPACE(*proto) || *proto == ';'))
3854 if (*start == '$') {
3855 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3856 isUPPER(*PL_tokenbuf))
3861 return *s == '(' ? FUNCMETH : METHOD;
3864 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3865 /* start is the beginning of the possible filehandle/object,
3866 * and s is the end of it
3867 * tmpbuf is a copy of it (but with single quotes as double colons)
3870 if (!keyword(tmpbuf, len, 0)) {
3871 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3876 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3877 if (indirgv && GvCVu(indirgv))
3879 /* filehandle or package name makes it a method */
3880 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3882 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3883 return 0; /* no assumptions -- "=>" quotes bareword */
3885 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3886 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3887 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3891 return *s == '(' ? FUNCMETH : METHOD;
3897 /* Encoded script support. filter_add() effectively inserts a
3898 * 'pre-processing' function into the current source input stream.
3899 * Note that the filter function only applies to the current source file
3900 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3902 * The datasv parameter (which may be NULL) can be used to pass
3903 * private data to this instance of the filter. The filter function
3904 * can recover the SV using the FILTER_DATA macro and use it to
3905 * store private buffers and state information.
3907 * The supplied datasv parameter is upgraded to a PVIO type
3908 * and the IoDIRP/IoANY field is used to store the function pointer,
3909 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3910 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3911 * private use must be set using malloc'd pointers.
3915 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3924 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3925 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3927 if (!PL_rsfp_filters)
3928 PL_rsfp_filters = newAV();
3931 SvUPGRADE(datasv, SVt_PVIO);
3932 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3933 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3934 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3935 FPTR2DPTR(void *, IoANY(datasv)),
3936 SvPV_nolen(datasv)));
3937 av_unshift(PL_rsfp_filters, 1);
3938 av_store(PL_rsfp_filters, 0, datasv) ;
3940 !PL_parser->filtered
3941 && PL_parser->lex_flags & LEX_EVALBYTES
3942 && PL_bufptr < PL_bufend
3944 const char *s = PL_bufptr;
3945 while (s < PL_bufend) {
3947 SV *linestr = PL_parser->linestr;
3948 char *buf = SvPVX(linestr);
3949 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3950 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3951 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3952 STRLEN const linestart_pos = PL_parser->linestart - buf;
3953 STRLEN const last_uni_pos =
3954 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3955 STRLEN const last_lop_pos =
3956 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3957 av_push(PL_rsfp_filters, linestr);
3958 PL_parser->linestr =
3959 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3960 buf = SvPVX(PL_parser->linestr);
3961 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3962 PL_parser->bufptr = buf + bufptr_pos;
3963 PL_parser->oldbufptr = buf + oldbufptr_pos;
3964 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3965 PL_parser->linestart = buf + linestart_pos;
3966 if (PL_parser->last_uni)
3967 PL_parser->last_uni = buf + last_uni_pos;
3968 if (PL_parser->last_lop)
3969 PL_parser->last_lop = buf + last_lop_pos;
3970 SvLEN(linestr) = SvCUR(linestr);
3971 SvCUR(linestr) = s-SvPVX(linestr);
3972 PL_parser->filtered = 1;
3982 /* Delete most recently added instance of this filter function. */
3984 Perl_filter_del(pTHX_ filter_t funcp)
3989 PERL_ARGS_ASSERT_FILTER_DEL;
3992 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3993 FPTR2DPTR(void*, funcp)));
3995 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3997 /* if filter is on top of stack (usual case) just pop it off */
3998 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3999 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4000 sv_free(av_pop(PL_rsfp_filters));
4004 /* we need to search for the correct entry and clear it */
4005 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4009 /* Invoke the idxth filter function for the current rsfp. */
4010 /* maxlen 0 = read one text line */
4012 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4017 /* This API is bad. It should have been using unsigned int for maxlen.
4018 Not sure if we want to change the API, but if not we should sanity
4019 check the value here. */
4020 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4022 PERL_ARGS_ASSERT_FILTER_READ;
4024 if (!PL_parser || !PL_rsfp_filters)
4026 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4027 /* Provide a default input filter to make life easy. */
4028 /* Note that we append to the line. This is handy. */
4029 DEBUG_P(PerlIO_printf(Perl_debug_log,
4030 "filter_read %d: from rsfp\n", idx));
4031 if (correct_length) {
4034 const int old_len = SvCUR(buf_sv);
4036 /* ensure buf_sv is large enough */
4037 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4038 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4039 correct_length)) <= 0) {
4040 if (PerlIO_error(PL_rsfp))
4041 return -1; /* error */
4043 return 0 ; /* end of file */
4045 SvCUR_set(buf_sv, old_len + len) ;
4046 SvPVX(buf_sv)[old_len + len] = '\0';
4049 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4050 if (PerlIO_error(PL_rsfp))
4051 return -1; /* error */
4053 return 0 ; /* end of file */
4056 return SvCUR(buf_sv);
4058 /* Skip this filter slot if filter has been deleted */
4059 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4060 DEBUG_P(PerlIO_printf(Perl_debug_log,
4061 "filter_read %d: skipped (filter deleted)\n",
4063 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4065 if (SvTYPE(datasv) != SVt_PVIO) {
4066 if (correct_length) {
4068 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4069 if (!remainder) return 0; /* eof */
4070 if (correct_length > remainder) correct_length = remainder;
4071 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4072 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4075 const char *s = SvEND(datasv);
4076 const char *send = SvPVX(datasv) + SvLEN(datasv);
4084 if (s == send) return 0; /* eof */
4085 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4086 SvCUR_set(datasv, s-SvPVX(datasv));
4088 return SvCUR(buf_sv);
4090 /* Get function pointer hidden within datasv */
4091 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4092 DEBUG_P(PerlIO_printf(Perl_debug_log,
4093 "filter_read %d: via function %p (%s)\n",
4094 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4095 /* Call function. The function is expected to */
4096 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4097 /* Return: <0:error, =0:eof, >0:not eof */
4098 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4102 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4106 PERL_ARGS_ASSERT_FILTER_GETS;
4108 #ifdef PERL_CR_FILTER
4109 if (!PL_rsfp_filters) {
4110 filter_add(S_cr_textfilter,NULL);
4113 if (PL_rsfp_filters) {
4115 SvCUR_set(sv, 0); /* start with empty line */
4116 if (FILTER_READ(0, sv, 0) > 0)
4117 return ( SvPVX(sv) ) ;
4122 return (sv_gets(sv, PL_rsfp, append));
4126 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4131 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4133 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4137 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4138 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4140 return GvHV(gv); /* Foo:: */
4143 /* use constant CLASS => 'MyClass' */
4144 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4145 if (gv && GvCV(gv)) {
4146 SV * const sv = cv_const_sv(GvCV(gv));
4148 pkgname = SvPV_const(sv, len);
4151 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4156 S_tokenize_use(pTHX_ int is_use, char *s) {
4159 PERL_ARGS_ASSERT_TOKENIZE_USE;
4161 if (PL_expect != XSTATE)
4162 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4163 is_use ? "use" : "no"));
4166 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4167 s = force_version(s, TRUE);
4168 if (*s == ';' || *s == '}'
4169 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4170 NEXTVAL_NEXTTOKE.opval = NULL;
4173 else if (*s == 'v') {
4174 s = force_word(s,WORD,FALSE,TRUE);
4175 s = force_version(s, FALSE);
4179 s = force_word(s,WORD,FALSE,TRUE);
4180 s = force_version(s, FALSE);
4182 pl_yylval.ival = is_use;
4186 static const char* const exp_name[] =
4187 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4188 "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR"
4192 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4194 S_word_takes_any_delimeter(char *p, STRLEN len)
4196 return (len == 1 && strchr("msyq", p[0])) ||
4198 (p[0] == 't' && p[1] == 'r') ||
4199 (p[0] == 'q' && strchr("qwxr", p[1]))));
4203 S_check_scalar_slice(pTHX_ char *s)
4206 while (*s == ' ' || *s == '\t') s++;
4207 if (*s == 'q' && s[1] == 'w'
4208 && !isWORDCHAR_lazy_if(s+2,UTF))
4210 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4211 s += UTF ? UTF8SKIP(s) : 1;
4212 if (*s == '}' || *s == ']')
4213 pl_yylval.ival = OPpSLICEWARNING;
4219 Works out what to call the token just pulled out of the input
4220 stream. The yacc parser takes care of taking the ops we return and
4221 stitching them into a tree.
4224 The type of the next token
4227 Switch based on the current state:
4228 - if we already built the token before, use it
4229 - if we have a case modifier in a string, deal with that
4230 - handle other cases of interpolation inside a string
4231 - scan the next line if we are inside a format
4232 In the normal state switch on the next character:
4234 if alphabetic, go to key lookup
4235 unrecoginized character - croak
4236 - 0/4/26: handle end-of-line or EOF
4237 - cases for whitespace
4238 - \n and #: handle comments and line numbers
4239 - various operators, brackets and sigils
4242 - 'v': vstrings (or go to key lookup)
4243 - 'x' repetition operator (or go to key lookup)
4244 - other ASCII alphanumerics (key lookup begins here):
4247 scan built-in keyword (but do nothing with it yet)
4248 check for statement label
4249 check for lexical subs
4250 goto just_a_word if there is one
4251 see whether built-in keyword is overridden
4252 switch on keyword number:
4253 - default: just_a_word:
4254 not a built-in keyword; handle bareword lookup
4255 disambiguate between method and sub call
4256 fall back to bareword
4257 - cases for built-in keywords
4265 char *s = PL_bufptr;
4269 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4273 /* orig_keyword, gvp, and gv are initialized here because
4274 * jump to the label just_a_word_zero can bypass their
4275 * initialization later. */
4276 I32 orig_keyword = 0;
4281 SV* tmp = newSVpvs("");
4282 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4283 (IV)CopLINE(PL_curcop),
4284 lex_state_names[PL_lex_state],
4285 exp_name[PL_expect],
4286 pv_display(tmp, s, strlen(s), 0, 60));
4290 switch (PL_lex_state) {
4292 case LEX_INTERPNORMAL:
4295 /* when we've already built the next token, just pull it out of the queue */
4298 pl_yylval = PL_nextval[PL_nexttoke];
4300 PL_lex_state = PL_lex_defer;
4301 PL_expect = PL_lex_expect;
4302 PL_lex_defer = LEX_NORMAL;
4306 next_type = PL_nexttype[PL_nexttoke];
4307 if (next_type & (7<<24)) {
4308 if (next_type & (1<<24)) {
4309 if (PL_lex_brackets > 100)
4310 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4311 PL_lex_brackstack[PL_lex_brackets++] =
4312 (char) ((next_type >> 16) & 0xff);
4314 if (next_type & (2<<24))
4315 PL_lex_allbrackets++;
4316 if (next_type & (4<<24))
4317 PL_lex_allbrackets--;
4318 next_type &= 0xffff;
4320 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4323 /* interpolated case modifiers like \L \U, including \Q and \E.
4324 when we get here, PL_bufptr is at the \
4326 case LEX_INTERPCASEMOD:
4328 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4330 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4331 PL_bufptr, PL_bufend, *PL_bufptr);
4333 /* handle \E or end of string */
4334 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4336 if (PL_lex_casemods) {
4337 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4338 PL_lex_casestack[PL_lex_casemods] = '\0';
4340 if (PL_bufptr != PL_bufend
4341 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4342 || oldmod == 'F')) {
4344 PL_lex_state = LEX_INTERPCONCAT;
4346 PL_lex_allbrackets--;
4349 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4350 /* Got an unpaired \E */
4351 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4352 "Useless use of \\E");
4354 if (PL_bufptr != PL_bufend)
4356 PL_lex_state = LEX_INTERPCONCAT;
4360 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4361 "### Saw case modifier\n"); });
4363 if (s[1] == '\\' && s[2] == 'E') {
4365 PL_lex_state = LEX_INTERPCONCAT;
4370 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4371 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4372 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4373 (strchr(PL_lex_casestack, 'L')
4374 || strchr(PL_lex_casestack, 'U')
4375 || strchr(PL_lex_casestack, 'F'))) {
4376 PL_lex_casestack[--PL_lex_casemods] = '\0';
4377 PL_lex_allbrackets--;
4380 if (PL_lex_casemods > 10)
4381 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4382 PL_lex_casestack[PL_lex_casemods++] = *s;
4383 PL_lex_casestack[PL_lex_casemods] = '\0';
4384 PL_lex_state = LEX_INTERPCONCAT;
4385 NEXTVAL_NEXTTOKE.ival = 0;
4386 force_next((2<<24)|'(');
4388 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4390 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4392 NEXTVAL_NEXTTOKE.ival = OP_LC;
4394 NEXTVAL_NEXTTOKE.ival = OP_UC;
4396 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4398 NEXTVAL_NEXTTOKE.ival = OP_FC;
4400 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4404 if (PL_lex_starts) {
4407 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4408 if (PL_lex_casemods == 1 && PL_lex_inpat)
4417 case LEX_INTERPPUSH:
4418 return REPORT(sublex_push());
4420 case LEX_INTERPSTART:
4421 if (PL_bufptr == PL_bufend)
4422 return REPORT(sublex_done());
4423 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4424 "### Interpolated variable\n"); });
4426 /* for /@a/, we leave the joining for the regex engine to do
4427 * (unless we're within \Q etc) */
4428 PL_lex_dojoin = (*PL_bufptr == '@'
4429 && (!PL_lex_inpat || PL_lex_casemods));
4430 PL_lex_state = LEX_INTERPNORMAL;
4431 if (PL_lex_dojoin) {
4432 NEXTVAL_NEXTTOKE.ival = 0;
4434 force_ident("\"", '$');
4435 NEXTVAL_NEXTTOKE.ival = 0;
4437 NEXTVAL_NEXTTOKE.ival = 0;
4438 force_next((2<<24)|'(');
4439 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4442 /* Convert (?{...}) and friends to 'do {...}' */
4443 if (PL_lex_inpat && *PL_bufptr == '(') {
4444 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4446 if (*PL_bufptr != '{')
4448 PL_expect = XTERMBLOCK;
4452 if (PL_lex_starts++) {
4454 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4455 if (!PL_lex_casemods && PL_lex_inpat)
4462 case LEX_INTERPENDMAYBE:
4463 if (intuit_more(PL_bufptr)) {
4464 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4470 if (PL_lex_dojoin) {
4471 const U8 dojoin_was = PL_lex_dojoin;
4472 PL_lex_dojoin = FALSE;
4473 PL_lex_state = LEX_INTERPCONCAT;
4474 PL_lex_allbrackets--;
4475 return REPORT(dojoin_was == 1 ? ')' : POSTJOIN);
4477 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4478 && SvEVALED(PL_lex_repl))
4480 if (PL_bufptr != PL_bufend)
4481 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4484 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4485 re_eval_str. If the here-doc body’s length equals the previous
4486 value of re_eval_start, re_eval_start will now be null. So
4487 check re_eval_str as well. */
4488 if (PL_parser->lex_shared->re_eval_start
4489 || PL_parser->lex_shared->re_eval_str) {
4491 if (*PL_bufptr != ')')
4492 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4494 /* having compiled a (?{..}) expression, return the original
4495 * text too, as a const */
4496 if (PL_parser->lex_shared->re_eval_str) {
4497 sv = PL_parser->lex_shared->re_eval_str;
4498 PL_parser->lex_shared->re_eval_str = NULL;
4500 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4501 SvPV_shrink_to_cur(sv);
4503 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4504 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4505 NEXTVAL_NEXTTOKE.opval =
4506 (OP*)newSVOP(OP_CONST, 0,
4509 PL_parser->lex_shared->re_eval_start = NULL;
4515 case LEX_INTERPCONCAT:
4517 if (PL_lex_brackets)
4518 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4519 (long) PL_lex_brackets);
4521 if (PL_bufptr == PL_bufend)
4522 return REPORT(sublex_done());
4524 /* m'foo' still needs to be parsed for possible (?{...}) */
4525 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4526 SV *sv = newSVsv(PL_linestr);
4528 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4532 s = scan_const(PL_bufptr);
4534 PL_lex_state = LEX_INTERPCASEMOD;
4536 PL_lex_state = LEX_INTERPSTART;
4539 if (s != PL_bufptr) {
4540 NEXTVAL_NEXTTOKE = pl_yylval;
4543 if (PL_lex_starts++) {
4544 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4545 if (!PL_lex_casemods && PL_lex_inpat)
4558 s = scan_formline(PL_bufptr);
4559 if (!PL_lex_formbrack)
4568 /* We really do *not* want PL_linestr ever becoming a COW. */
4569 assert (!SvIsCOW(PL_linestr));
4571 PL_oldoldbufptr = PL_oldbufptr;
4573 PL_parser->saw_infix_sigil = 0;
4578 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
4581 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4582 const char *c = UTF ? sv_uni_display(dsv, newSVpvn_flags(s,
4584 SVs_TEMP | SVf_UTF8),
4585 10, UNI_DISPLAY_ISPRINT)
4586 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4587 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4588 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4589 d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4593 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"UTF8f"<-- HERE near column %d", c,
4594 UTF8fARG(UTF, (s - d), d),
4599 goto fake_eof; /* emulate EOF on ^D or ^Z */
4601 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4604 if (PL_lex_brackets &&
4605 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4606 yyerror((const char *)
4608 ? "Format not terminated"
4609 : "Missing right curly or square bracket"));
4611 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4612 "### Tokener got EOF\n");
4616 if (s++ < PL_bufend)
4617 goto retry; /* ignore stray nulls */
4620 if (!PL_in_eval && !PL_preambled) {
4621 PL_preambled = TRUE;
4623 /* Generate a string of Perl code to load the debugger.
4624 * If PERL5DB is set, it will return the contents of that,
4625 * otherwise a compile-time require of perl5db.pl. */
4627 const char * const pdb = PerlEnv_getenv("PERL5DB");
4630 sv_setpv(PL_linestr, pdb);
4631 sv_catpvs(PL_linestr,";");
4633 SETERRNO(0,SS_NORMAL);
4634 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4636 PL_parser->preambling = CopLINE(PL_curcop);
4638 sv_setpvs(PL_linestr,"");
4639 if (PL_preambleav) {
4640 SV **svp = AvARRAY(PL_preambleav);
4641 SV **const end = svp + AvFILLp(PL_preambleav);
4643 sv_catsv(PL_linestr, *svp);
4645 sv_catpvs(PL_linestr, ";");
4647 sv_free(MUTABLE_SV(PL_preambleav));
4648 PL_preambleav = NULL;
4651 sv_catpvs(PL_linestr,
4652 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4653 if (PL_minus_n || PL_minus_p) {
4654 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4656 sv_catpvs(PL_linestr,"chomp;");
4659 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4660 || *PL_splitstr == '"')
4661 && strchr(PL_splitstr + 1, *PL_splitstr))
4662 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4664 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4665 bytes can be used as quoting characters. :-) */
4666 const char *splits = PL_splitstr;
4667 sv_catpvs(PL_linestr, "our @F=split(q\0");
4670 if (*splits == '\\')
4671 sv_catpvn(PL_linestr, splits, 1);
4672 sv_catpvn(PL_linestr, splits, 1);
4673 } while (*splits++);
4674 /* This loop will embed the trailing NUL of
4675 PL_linestr as the last thing it does before
4677 sv_catpvs(PL_linestr, ");");
4681 sv_catpvs(PL_linestr,"our @F=split(' ');");
4684 sv_catpvs(PL_linestr, "\n");
4685 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4686 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4687 PL_last_lop = PL_last_uni = NULL;
4688 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4689 update_debugger_info(PL_linestr, NULL, 0);
4694 bof = PL_rsfp ? TRUE : FALSE;
4697 fake_eof = LEX_FAKE_EOF;
4699 PL_bufptr = PL_bufend;
4700 COPLINE_INC_WITH_HERELINES;
4701 if (!lex_next_chunk(fake_eof)) {
4702 CopLINE_dec(PL_curcop);
4704 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4706 CopLINE_dec(PL_curcop);
4708 /* If it looks like the start of a BOM or raw UTF-16,
4709 * check if it in fact is. */
4710 if (bof && PL_rsfp &&
4712 *(U8*)s == BOM_UTF8_FIRST_BYTE ||
4715 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4716 bof = (offset == (Off_t)SvCUR(PL_linestr));
4717 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4718 /* offset may include swallowed CR */
4720 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4723 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4724 s = swallow_bom((U8*)s);
4727 if (PL_parser->in_pod) {
4728 /* Incest with pod. */
4729 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4730 sv_setpvs(PL_linestr, "");
4731 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4732 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4733 PL_last_lop = PL_last_uni = NULL;
4734 PL_parser->in_pod = 0;
4737 if (PL_rsfp || PL_parser->filtered)
4739 } while (PL_parser->in_pod);
4740 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4741 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4742 PL_last_lop = PL_last_uni = NULL;
4743 if (CopLINE(PL_curcop) == 1) {
4744 while (s < PL_bufend && isSPACE(*s))
4746 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4750 if (*s == '#' && *(s+1) == '!')
4752 #ifdef ALTERNATE_SHEBANG
4754 static char const as[] = ALTERNATE_SHEBANG;
4755 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4756 d = s + (sizeof(as) - 1);
4758 #endif /* ALTERNATE_SHEBANG */
4767 while (*d && !isSPACE(*d))
4771 #ifdef ARG_ZERO_IS_SCRIPT
4772 if (ipathend > ipath) {
4774 * HP-UX (at least) sets argv[0] to the script name,
4775 * which makes $^X incorrect. And Digital UNIX and Linux,
4776 * at least, set argv[0] to the basename of the Perl
4777 * interpreter. So, having found "#!", we'll set it right.
4779 SV* copfilesv = CopFILESV(PL_curcop);
4782 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4784 assert(SvPOK(x) || SvGMAGICAL(x));
4785 if (sv_eq(x, copfilesv)) {
4786 sv_setpvn(x, ipath, ipathend - ipath);
4792 const char *bstart = SvPV_const(copfilesv, blen);
4793 const char * const lstart = SvPV_const(x, llen);
4795 bstart += blen - llen;
4796 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4797 sv_setpvn(x, ipath, ipathend - ipath);
4804 /* Anything to do if no copfilesv? */
4806 TAINT_NOT; /* $^X is always tainted, but that's OK */
4808 #endif /* ARG_ZERO_IS_SCRIPT */
4813 d = instr(s,"perl -");
4815 d = instr(s,"perl");
4817 /* avoid getting into infinite loops when shebang
4818 * line contains "Perl" rather than "perl" */
4820 for (d = ipathend-4; d >= ipath; --d) {
4821 if ((*d == 'p' || *d == 'P')
4822 && !ibcmp(d, "perl", 4))
4832 #ifdef ALTERNATE_SHEBANG
4834 * If the ALTERNATE_SHEBANG on this system starts with a
4835 * character that can be part of a Perl expression, then if
4836 * we see it but not "perl", we're probably looking at the
4837 * start of Perl code, not a request to hand off to some
4838 * other interpreter. Similarly, if "perl" is there, but
4839 * not in the first 'word' of the line, we assume the line
4840 * contains the start of the Perl program.
4842 if (d && *s != '#') {
4843 const char *c = ipath;
4844 while (*c && !strchr("; \t\r\n\f\v#", *c))
4847 d = NULL; /* "perl" not in first word; ignore */
4849 *s = '#'; /* Don't try to parse shebang line */
4851 #endif /* ALTERNATE_SHEBANG */
4856 !instr(s,"indir") &&
4857 instr(PL_origargv[0],"perl"))
4864 while (s < PL_bufend && isSPACE(*s))
4866 if (s < PL_bufend) {
4867 Newx(newargv,PL_origargc+3,char*);
4869 while (s < PL_bufend && !isSPACE(*s))
4872 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4875 newargv = PL_origargv;
4878 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4880 Perl_croak(aTHX_ "Can't exec %s", ipath);
4883 while (*d && !isSPACE(*d))
4885 while (SPACE_OR_TAB(*d))
4889 const bool switches_done = PL_doswitches;
4890 const U32 oldpdb = PL_perldb;
4891 const bool oldn = PL_minus_n;
4892 const bool oldp = PL_minus_p;
4896 bool baduni = FALSE;
4898 const char *d2 = d1 + 1;
4899 if (parse_unicode_opts((const char **)&d2)
4903 if (baduni || *d1 == 'M' || *d1 == 'm') {
4904 const char * const m = d1;
4905 while (*d1 && !isSPACE(*d1))
4907 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4910 d1 = moreswitches(d1);
4912 if (PL_doswitches && !switches_done) {
4913 int argc = PL_origargc;
4914 char **argv = PL_origargv;
4917 } while (argc && argv[0][0] == '-' && argv[0][1]);
4918 init_argv_symbols(argc,argv);
4920 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4921 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4922 /* if we have already added "LINE: while (<>) {",
4923 we must not do it again */
4925 sv_setpvs(PL_linestr, "");
4926 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4927 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4928 PL_last_lop = PL_last_uni = NULL;
4929 PL_preambled = FALSE;
4930 if (PERLDB_LINE || PERLDB_SAVESRC)
4931 (void)gv_fetchfile(PL_origfilename);
4938 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4939 PL_lex_state = LEX_FORMLINE;
4940 NEXTVAL_NEXTTOKE.ival = 0;
4941 force_next(FORMRBRACK);
4946 #ifdef PERL_STRICT_CR
4947 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4949 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4951 case ' ': case '\t': case '\f': case 013:
4956 if (PL_lex_state != LEX_NORMAL ||
4957 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
4958 const bool in_comment = *s == '#';
4959 if (*s == '#' && s == PL_linestart && PL_in_eval
4960 && !PL_rsfp && !PL_parser->filtered) {
4961 /* handle eval qq[#line 1 "foo"\n ...] */
4962 CopLINE_dec(PL_curcop);
4966 while (d < PL_bufend && *d != '\n')
4970 else if (d > PL_bufend)
4971 /* Found by Ilya: feed random input to Perl. */
4972 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
4975 if (in_comment && d == PL_bufend
4976 && PL_lex_state == LEX_INTERPNORMAL
4977 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
4978 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
4981 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4982 PL_lex_state = LEX_FORMLINE;
4983 NEXTVAL_NEXTTOKE.ival = 0;
4984 force_next(FORMRBRACK);
4989 while (s < PL_bufend && *s != '\n')
4997 else if (s > PL_bufend)
4998 /* Found by Ilya: feed random input to Perl. */
4999 Perl_croak(aTHX_ "panic: input overflow");
5003 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5011 while (s < PL_bufend && SPACE_OR_TAB(*s))
5014 if (strnEQ(s,"=>",2)) {
5015 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5016 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5017 OPERATOR('-'); /* unary minus */
5020 case 'r': ftst = OP_FTEREAD; break;
5021 case 'w': ftst = OP_FTEWRITE; break;
5022 case 'x': ftst = OP_FTEEXEC; break;
5023 case 'o': ftst = OP_FTEOWNED; break;
5024 case 'R': ftst = OP_FTRREAD; break;
5025 case 'W': ftst = OP_FTRWRITE; break;
5026 case 'X': ftst = OP_FTREXEC; break;
5027 case 'O': ftst = OP_FTROWNED; break;
5028 case 'e': ftst = OP_FTIS; break;
5029 case 'z': ftst = OP_FTZERO; break;
5030 case 's': ftst = OP_FTSIZE; break;
5031 case 'f': ftst = OP_FTFILE; break;
5032 case 'd': ftst = OP_FTDIR; break;
5033 case 'l': ftst = OP_FTLINK; break;
5034 case 'p': ftst = OP_FTPIPE; break;
5035 case 'S': ftst = OP_FTSOCK; break;
5036 case 'u': ftst = OP_FTSUID; break;
5037 case 'g': ftst = OP_FTSGID; break;
5038 case 'k': ftst = OP_FTSVTX; break;
5039 case 'b': ftst = OP_FTBLK; break;
5040 case 'c': ftst = OP_FTCHR; break;
5041 case 't': ftst = OP_FTTTY; break;
5042 case 'T': ftst = OP_FTTEXT; break;
5043 case 'B': ftst = OP_FTBINARY; break;
5044 case 'M': case 'A': case 'C':
5045 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5047 case 'M': ftst = OP_FTMTIME; break;
5048 case 'A': ftst = OP_FTATIME; break;
5049 case 'C': ftst = OP_FTCTIME; break;
5057 PL_last_uni = PL_oldbufptr;
5058 PL_last_lop_op = (OPCODE)ftst;
5059 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5060 "### Saw file test %c\n", (int)tmp);
5065 /* Assume it was a minus followed by a one-letter named
5066 * subroutine call (or a -bareword), then. */
5067 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5068 "### '-%c' looked like a file test but was not\n",
5075 const char tmp = *s++;
5078 if (PL_expect == XOPERATOR)
5083 else if (*s == '>') {
5086 if (FEATURE_POSTDEREF_IS_ENABLED && (
5087 ((*s == '$' || *s == '&') && s[1] == '*')
5088 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5089 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5090 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5093 Perl_ck_warner_d(aTHX_
5094 packWARN(WARN_EXPERIMENTAL__POSTDEREF),
5095 "Postfix dereference is experimental"
5097 PL_expect = XPOSTDEREF;
5100 if (isIDFIRST_lazy_if(s,UTF)) {
5101 s = force_word(s,METHOD,FALSE,TRUE);
5109 if (PL_expect == XOPERATOR) {
5110 if (*s == '=' && !PL_lex_allbrackets &&
5111 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5118 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5120 OPERATOR('-'); /* unary minus */
5126 const char tmp = *s++;
5129 if (PL_expect == XOPERATOR)
5134 if (PL_expect == XOPERATOR) {
5135 if (*s == '=' && !PL_lex_allbrackets &&
5136 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5143 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5150 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5151 if (PL_expect != XOPERATOR) {
5152 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5153 PL_expect = XOPERATOR;
5154 force_ident(PL_tokenbuf, '*');
5162 if (*s == '=' && !PL_lex_allbrackets &&
5163 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5169 if (*s == '=' && !PL_lex_allbrackets &&
5170 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5174 PL_parser->saw_infix_sigil = 1;
5179 if (PL_expect == XOPERATOR) {
5180 if (s[1] == '=' && !PL_lex_allbrackets &&
5181 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5184 PL_parser->saw_infix_sigil = 1;
5187 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5188 PL_tokenbuf[0] = '%';
5189 s = scan_ident(s, PL_tokenbuf + 1,
5190 sizeof PL_tokenbuf - 1, FALSE);
5192 if (!PL_tokenbuf[1]) {
5195 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5197 PL_tokenbuf[0] = '@';
5199 PL_expect = XOPERATOR;
5200 force_ident_maybe_lex('%');
5204 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5205 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5210 if (PL_lex_brackets > 100)
5211 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5212 PL_lex_brackstack[PL_lex_brackets++] = 0;
5213 PL_lex_allbrackets++;
5215 const char tmp = *s++;
5220 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5222 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5225 Perl_ck_warner_d(aTHX_
5226 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5227 "Smartmatch is experimental");
5233 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5240 goto just_a_word_zero_gv;
5246 switch (PL_expect) {
5248 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5250 PL_bufptr = s; /* update in case we back off */
5253 "Use of := for an empty attribute list is not allowed");
5260 PL_expect = XTERMBLOCK;
5264 while (isIDFIRST_lazy_if(s,UTF)) {
5267 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5268 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5269 if (tmp < 0) tmp = -tmp;
5284 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5286 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5287 COPLINE_SET_FROM_MULTI_END;
5289 /* MUST advance bufptr here to avoid bogus
5290 "at end of line" context messages from yyerror().
5292 PL_bufptr = s + len;
5293 yyerror("Unterminated attribute parameter in attribute list");
5297 return REPORT(0); /* EOF indicator */
5301 sv_catsv(sv, PL_lex_stuff);
5302 attrs = op_append_elem(OP_LIST, attrs,
5303 newSVOP(OP_CONST, 0, sv));
5304 SvREFCNT_dec(PL_lex_stuff);
5305 PL_lex_stuff = NULL;
5308 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5310 if (PL_in_my == KEY_our) {
5311 deprecate(":unique");
5314 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5317 /* NOTE: any CV attrs applied here need to be part of
5318 the CVf_BUILTIN_ATTRS define in cv.h! */
5319 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5321 CvLVALUE_on(PL_compcv);
5323 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5325 deprecate(":locked");
5327 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5329 CvMETHOD_on(PL_compcv);
5331 /* After we've set the flags, it could be argued that
5332 we don't need to do the attributes.pm-based setting
5333 process, and shouldn't bother appending recognized
5334 flags. To experiment with that, uncomment the
5335 following "else". (Note that's already been
5336 uncommented. That keeps the above-applied built-in
5337 attributes from being intercepted (and possibly
5338 rejected) by a package's attribute routines, but is
5339 justified by the performance win for the common case
5340 of applying only built-in attributes.) */
5342 attrs = op_append_elem(OP_LIST, attrs,
5343 newSVOP(OP_CONST, 0,
5347 if (*s == ':' && s[1] != ':')
5350 break; /* require real whitespace or :'s */
5351 /* XXX losing whitespace on sequential attributes here */
5354 if (*s != ';' && *s != '}' &&
5355 !(PL_expect == XOPERATOR
5356 ? (*s == '=' || *s == ')')
5357 : (*s == '{' || *s == '('))) {
5358 const char q = ((*s == '\'') ? '"' : '\'');
5359 /* If here for an expression, and parsed no attrs, back
5361 if (PL_expect == XOPERATOR && !attrs) {
5365 /* MUST advance bufptr here to avoid bogus "at end of line"
5366 context messages from yyerror().
5369 yyerror( (const char *)
5371 ? Perl_form(aTHX_ "Invalid separator character "
5372 "%c%c%c in attribute list", q, *s, q)
5373 : "Unterminated attribute list" ) );
5381 NEXTVAL_NEXTTOKE.opval = attrs;
5387 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5391 PL_lex_allbrackets--;
5395 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5396 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5400 PL_lex_allbrackets++;
5403 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5409 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5412 PL_lex_allbrackets--;
5418 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5421 if (PL_lex_brackets <= 0)
5422 /* diag_listed_as: Unmatched right %s bracket */
5423 yyerror("Unmatched right square bracket");
5426 PL_lex_allbrackets--;
5427 if (PL_lex_state == LEX_INTERPNORMAL) {
5428 if (PL_lex_brackets == 0) {
5429 if (*s == '-' && s[1] == '>')
5430 PL_lex_state = LEX_INTERPENDMAYBE;
5431 else if (*s != '[' && *s != '{')
5432 PL_lex_state = LEX_INTERPEND;
5439 if (PL_lex_brackets > 100) {
5440 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5442 switch (PL_expect) {
5444 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5445 PL_lex_allbrackets++;
5446 OPERATOR(HASHBRACK);
5448 while (s < PL_bufend && SPACE_OR_TAB(*s))
5451 PL_tokenbuf[0] = '\0';
5452 if (d < PL_bufend && *d == '-') {
5453 PL_tokenbuf[0] = '-';
5455 while (d < PL_bufend && SPACE_OR_TAB(*d))
5458 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5459 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5461 while (d < PL_bufend && SPACE_OR_TAB(*d))
5464 const char minus = (PL_tokenbuf[0] == '-');
5465 s = force_word(s + minus, WORD, FALSE, TRUE);
5473 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5474 PL_lex_allbrackets++;
5479 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5480 PL_lex_allbrackets++;
5485 if (PL_oldoldbufptr == PL_last_lop)
5486 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5488 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5489 PL_lex_allbrackets++;
5492 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5494 /* This hack is to get the ${} in the message. */
5496 yyerror("syntax error");
5499 OPERATOR(HASHBRACK);
5501 /* This hack serves to disambiguate a pair of curlies
5502 * as being a block or an anon hash. Normally, expectation
5503 * determines that, but in cases where we're not in a
5504 * position to expect anything in particular (like inside
5505 * eval"") we have to resolve the ambiguity. This code
5506 * covers the case where the first term in the curlies is a
5507 * quoted string. Most other cases need to be explicitly
5508 * disambiguated by prepending a "+" before the opening
5509 * curly in order to force resolution as an anon hash.
5511 * XXX should probably propagate the outer expectation
5512 * into eval"" to rely less on this hack, but that could
5513 * potentially break current behavior of eval"".
5517 if (*s == '\'' || *s == '"' || *s == '`') {
5518 /* common case: get past first string, handling escapes */
5519 for (t++; t < PL_bufend && *t != *s;)
5520 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5524 else if (*s == 'q') {
5527 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5528 && !isWORDCHAR(*t))))
5530 /* skip q//-like construct */
5532 char open, close, term;
5535 while (t < PL_bufend && isSPACE(*t))
5537 /* check for q => */
5538 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5539 OPERATOR(HASHBRACK);
5543 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5547 for (t++; t < PL_bufend; t++) {
5548 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5550 else if (*t == open)
5554 for (t++; t < PL_bufend; t++) {
5555 if (*t == '\\' && t+1 < PL_bufend)
5557 else if (*t == close && --brackets <= 0)
5559 else if (*t == open)
5566 /* skip plain q word */
5567 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5570 else if (isWORDCHAR_lazy_if(t,UTF)) {
5572 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
5575 while (t < PL_bufend && isSPACE(*t))
5577 /* if comma follows first term, call it an anon hash */
5578 /* XXX it could be a comma expression with loop modifiers */
5579 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5580 || (*t == '=' && t[1] == '>')))
5581 OPERATOR(HASHBRACK);
5582 if (PL_expect == XREF)
5585 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5591 pl_yylval.ival = CopLINE(PL_curcop);
5592 if (isSPACE(*s) || *s == '#')
5593 PL_copline = NOLINE; /* invalidate current command line number */
5594 TOKEN(formbrack ? '=' : '{');
5596 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5600 if (PL_lex_brackets <= 0)
5601 /* diag_listed_as: Unmatched right %s bracket */
5602 yyerror("Unmatched right curly bracket");
5604 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5605 PL_lex_allbrackets--;
5606 if (PL_lex_state == LEX_INTERPNORMAL) {
5607 if (PL_lex_brackets == 0) {
5608 if (PL_expect & XFAKEBRACK) {
5609 PL_expect &= XENUMMASK;
5610 PL_lex_state = LEX_INTERPEND;
5612 return yylex(); /* ignore fake brackets */
5614 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5615 && SvEVALED(PL_lex_repl))
5616 PL_lex_state = LEX_INTERPEND;
5617 else if (*s == '-' && s[1] == '>')
5618 PL_lex_state = LEX_INTERPENDMAYBE;
5619 else if (*s != '[' && *s != '{')
5620 PL_lex_state = LEX_INTERPEND;
5623 if (PL_expect & XFAKEBRACK) {
5624 PL_expect &= XENUMMASK;
5626 return yylex(); /* ignore fake brackets */
5628 force_next(formbrack ? '.' : '}');
5629 if (formbrack) LEAVE;
5630 if (formbrack == 2) { /* means . where arguments were expected */
5636 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
5639 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5640 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5647 if (PL_expect == XOPERATOR) {
5648 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5649 && isIDFIRST_lazy_if(s,UTF))
5651 CopLINE_dec(PL_curcop);
5652 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5653 CopLINE_inc(PL_curcop);
5655 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5656 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5660 PL_parser->saw_infix_sigil = 1;
5664 PL_tokenbuf[0] = '&';
5665 s = scan_ident(s - 1, PL_tokenbuf + 1,
5666 sizeof PL_tokenbuf - 1, TRUE);
5667 if (PL_tokenbuf[1]) {
5668 PL_expect = XOPERATOR;
5669 force_ident_maybe_lex('&');
5673 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5679 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5680 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5687 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5688 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5696 const char tmp = *s++;
5698 if (!PL_lex_allbrackets &&
5699 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5706 if (!PL_lex_allbrackets &&
5707 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5715 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5716 && strchr("+-*/%.^&|<",tmp))
5717 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5718 "Reversed %c= operator",(int)tmp);
5720 if (PL_expect == XSTATE && isALPHA(tmp) &&
5721 (s == PL_linestart+1 || s[-2] == '\n') )
5723 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
5724 || PL_lex_state != LEX_NORMAL) {
5729 if (strnEQ(s,"=cut",4)) {
5743 PL_parser->in_pod = 1;
5747 if (PL_expect == XBLOCK) {
5749 #ifdef PERL_STRICT_CR
5750 while (SPACE_OR_TAB(*t))
5752 while (SPACE_OR_TAB(*t) || *t == '\r')
5755 if (*t == '\n' || *t == '#') {
5758 SAVEI8(PL_parser->form_lex_state);
5759 SAVEI32(PL_lex_formbrack);
5760 PL_parser->form_lex_state = PL_lex_state;
5761 PL_lex_formbrack = PL_lex_brackets + 1;
5765 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5774 const char tmp = *s++;
5776 /* was this !=~ where !~ was meant?
5777 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5779 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5780 const char *t = s+1;
5782 while (t < PL_bufend && isSPACE(*t))
5785 if (*t == '/' || *t == '?' ||
5786 ((*t == 'm' || *t == 's' || *t == 'y')
5787 && !isWORDCHAR(t[1])) ||
5788 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
5789 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5790 "!=~ should be !~");
5792 if (!PL_lex_allbrackets &&
5793 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5805 if (PL_expect != XOPERATOR) {
5806 if (s[1] != '<' && !strchr(s,'>'))
5809 s = scan_heredoc(s);
5811 s = scan_inputsymbol(s);
5812 PL_expect = XOPERATOR;
5813 TOKEN(sublex_start());
5819 if (*s == '=' && !PL_lex_allbrackets &&
5820 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5824 SHop(OP_LEFT_SHIFT);
5829 if (!PL_lex_allbrackets &&
5830 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5837 if (!PL_lex_allbrackets &&
5838 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5846 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5854 const char tmp = *s++;
5856 if (*s == '=' && !PL_lex_allbrackets &&
5857 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5861 SHop(OP_RIGHT_SHIFT);
5863 else if (tmp == '=') {
5864 if (!PL_lex_allbrackets &&
5865 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5873 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5882 if (PL_expect == XOPERATOR) {
5883 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5884 return deprecate_commaless_var_list();
5887 else if (PL_expect == XPOSTDEREF) {
5890 POSTDEREF(DOLSHARP);
5895 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
5896 PL_tokenbuf[0] = '@';
5897 s = scan_ident(s + 1, PL_tokenbuf + 1,
5898 sizeof PL_tokenbuf - 1, FALSE);
5899 if (PL_expect == XOPERATOR)
5900 no_op("Array length", s);
5901 if (!PL_tokenbuf[1])
5903 PL_expect = XOPERATOR;
5904 force_ident_maybe_lex('#');
5908 PL_tokenbuf[0] = '$';
5909 s = scan_ident(s, PL_tokenbuf + 1,
5910 sizeof PL_tokenbuf - 1, FALSE);
5911 if (PL_expect == XOPERATOR)
5913 if (!PL_tokenbuf[1]) {
5915 yyerror("Final $ should be \\$ or $name");
5921 const char tmp = *s;
5922 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5925 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5926 && intuit_more(s)) {
5928 PL_tokenbuf[0] = '@';
5929 if (ckWARN(WARN_SYNTAX)) {
5932 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
5935 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5936 while (t < PL_bufend && *t != ']')
5938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5939 "Multidimensional syntax %.*s not supported",
5940 (int)((t - PL_bufptr) + 1), PL_bufptr);
5944 else if (*s == '{') {
5946 PL_tokenbuf[0] = '%';
5947 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
5948 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
5950 char tmpbuf[sizeof PL_tokenbuf];
5953 } while (isSPACE(*t));
5954 if (isIDFIRST_lazy_if(t,UTF)) {
5956 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5961 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
5962 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5963 "You need to quote \"%"UTF8f"\"",
5964 UTF8fARG(UTF, len, tmpbuf));
5970 PL_expect = XOPERATOR;
5971 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
5972 const bool islop = (PL_last_lop == PL_oldoldbufptr);
5973 if (!islop || PL_last_lop_op == OP_GREPSTART)
5974 PL_expect = XOPERATOR;
5975 else if (strchr("$@\"'`q", *s))
5976 PL_expect = XTERM; /* e.g. print $fh "foo" */
5977 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
5978 PL_expect = XTERM; /* e.g. print $fh &sub */
5979 else if (isIDFIRST_lazy_if(s,UTF)) {
5980 char tmpbuf[sizeof PL_tokenbuf];
5982 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5983 if ((t2 = keyword(tmpbuf, len, 0))) {
5984 /* binary operators exclude handle interpretations */
5996 PL_expect = XTERM; /* e.g. print $fh length() */
6001 PL_expect = XTERM; /* e.g. print $fh subr() */
6004 else if (isDIGIT(*s))
6005 PL_expect = XTERM; /* e.g. print $fh 3 */
6006 else if (*s == '.' && isDIGIT(s[1]))
6007 PL_expect = XTERM; /* e.g. print $fh .3 */
6008 else if ((*s == '?' || *s == '-' || *s == '+')
6009 && !isSPACE(s[1]) && s[1] != '=')
6010 PL_expect = XTERM; /* e.g. print $fh -1 */
6011 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6013 PL_expect = XTERM; /* e.g. print $fh /.../
6014 XXX except DORDOR operator
6016 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6018 PL_expect = XTERM; /* print $fh <<"EOF" */
6021 force_ident_maybe_lex('$');
6025 if (PL_expect == XOPERATOR)
6027 else if (PL_expect == XPOSTDEREF) POSTDEREF('@');
6028 PL_tokenbuf[0] = '@';
6029 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6031 if (!PL_tokenbuf[1]) {
6034 if (PL_lex_state == LEX_NORMAL)
6036 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6038 PL_tokenbuf[0] = '%';
6040 /* Warn about @ where they meant $. */
6041 if (*s == '[' || *s == '{') {
6042 if (ckWARN(WARN_SYNTAX)) {
6043 S_check_scalar_slice(aTHX_ s);
6047 PL_expect = XOPERATOR;
6048 force_ident_maybe_lex('@');
6051 case '/': /* may be division, defined-or, or pattern */
6052 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6053 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6054 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6059 else if (PL_expect == XOPERATOR) {
6061 if (*s == '=' && !PL_lex_allbrackets &&
6062 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6069 /* Disable warning on "study /blah/" */
6070 if (PL_oldoldbufptr == PL_last_uni
6071 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6072 || memNE(PL_last_uni, "study", 5)
6073 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6076 s = scan_pat(s,OP_MATCH);
6077 TERM(sublex_start());
6080 case '?': /* conditional */
6082 if (!PL_lex_allbrackets &&
6083 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6087 PL_lex_allbrackets++;
6091 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6092 #ifdef PERL_STRICT_CR
6095 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6097 && (s == PL_linestart || s[-1] == '\n') )
6100 formbrack = 2; /* dot seen where arguments expected */
6103 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6107 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6110 if (!PL_lex_allbrackets &&
6111 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6118 pl_yylval.ival = OPf_SPECIAL;
6124 if (*s == '=' && !PL_lex_allbrackets &&
6125 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6132 case '0': case '1': case '2': case '3': case '4':
6133 case '5': case '6': case '7': case '8': case '9':
6134 s = scan_num(s, &pl_yylval);
6135 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6136 if (PL_expect == XOPERATOR)
6141 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6144 COPLINE_SET_FROM_MULTI_END;
6145 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6146 if (PL_expect == XOPERATOR) {
6147 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6148 return deprecate_commaless_var_list();
6153 pl_yylval.ival = OP_CONST;
6154 TERM(sublex_start());
6157 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6160 printbuf("### Saw string before %s\n", s);
6162 PerlIO_printf(Perl_debug_log,
6163 "### Saw unterminated string\n");
6165 if (PL_expect == XOPERATOR) {
6166 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6167 return deprecate_commaless_var_list();
6174 pl_yylval.ival = OP_CONST;
6175 /* FIXME. I think that this can be const if char *d is replaced by
6176 more localised variables. */
6177 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6178 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6179 pl_yylval.ival = OP_STRINGIFY;
6183 if (pl_yylval.ival == OP_CONST)
6184 COPLINE_SET_FROM_MULTI_END;
6185 TERM(sublex_start());
6188 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6189 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6190 if (PL_expect == XOPERATOR)
6191 no_op("Backticks",s);
6194 pl_yylval.ival = OP_BACKTICK;
6195 TERM(sublex_start());
6199 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6201 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6203 if (PL_expect == XOPERATOR)
6204 no_op("Backslash",s);
6208 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6209 char *start = s + 2;
6210 while (isDIGIT(*start) || *start == '_')
6212 if (*start == '.' && isDIGIT(start[1])) {
6213 s = scan_num(s, &pl_yylval);
6216 else if ((*start == ':' && start[1] == ':')
6217 || (PL_expect == XSTATE && *start == ':'))
6219 else if (PL_expect == XSTATE) {
6221 while (d < PL_bufend && isSPACE(*d)) d++;
6222 if (*d == ':') goto keylookup;
6224 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6225 if (!isALPHA(*start) && (PL_expect == XTERM
6226 || PL_expect == XREF || PL_expect == XSTATE
6227 || PL_expect == XTERMORDORDOR)) {
6228 GV *const gv = gv_fetchpvn_flags(s, start - s,
6229 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6231 s = scan_num(s, &pl_yylval);
6238 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6291 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6293 /* Some keywords can be followed by any delimiter, including ':' */
6294 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6296 /* x::* is just a word, unless x is "CORE" */
6297 if (!anydelim && *s == ':' && s[1] == ':') {
6298 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
6303 while (d < PL_bufend && isSPACE(*d))
6304 d++; /* no comments skipped here, or s### is misparsed */
6306 /* Is this a word before a => operator? */
6307 if (*d == '=' && d[1] == '>') {
6311 = (OP*)newSVOP(OP_CONST, 0,
6312 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6313 pl_yylval.opval->op_private = OPpCONST_BARE;
6317 /* Check for plugged-in keyword */
6321 char *saved_bufptr = PL_bufptr;
6323 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6325 if (result == KEYWORD_PLUGIN_DECLINE) {
6326 /* not a plugged-in keyword */
6327 PL_bufptr = saved_bufptr;
6328 } else if (result == KEYWORD_PLUGIN_STMT) {
6329 pl_yylval.opval = o;
6332 return REPORT(PLUGSTMT);
6333 } else if (result == KEYWORD_PLUGIN_EXPR) {
6334 pl_yylval.opval = o;
6336 PL_expect = XOPERATOR;
6337 return REPORT(PLUGEXPR);
6339 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6344 /* Check for built-in keyword */
6345 tmp = keyword(PL_tokenbuf, len, 0);
6347 /* Is this a label? */
6348 if (!anydelim && PL_expect == XSTATE
6349 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6351 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6352 pl_yylval.pval[len] = '\0';
6353 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6358 /* Check for lexical sub */
6359 if (PL_expect != XOPERATOR) {
6360 char tmpbuf[sizeof PL_tokenbuf + 1];
6362 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6363 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
6364 if (off != NOT_IN_PAD) {
6365 assert(off); /* we assume this is boolean-true below */
6366 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6367 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6368 HEK * const stashname = HvNAME_HEK(stash);
6369 sv = newSVhek(stashname);
6370 sv_catpvs(sv, "::");
6371 sv_catpvn_flags(sv, PL_tokenbuf, len,
6372 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6373 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6383 rv2cv_op = newOP(OP_PADANY, 0);
6384 rv2cv_op->op_targ = off;
6385 cv = find_lexical_cv(off);
6393 if (tmp < 0) { /* second-class keyword? */
6394 GV *ogv = NULL; /* override (winner) */
6395 GV *hgv = NULL; /* hidden (loser) */
6396 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6398 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6399 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
6403 if (GvIMPORTED_CV(gv))
6405 else if (! CvMETHOD(cv))
6409 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6413 ? GvCVu(gv) && GvIMPORTED_CV(gv)
6414 : SvPCS_IMPORTED(gv)
6415 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
6424 tmp = 0; /* overridden by import or by GLOBAL */
6427 && -tmp==KEY_lock /* XXX generalizable kludge */
6430 tmp = 0; /* any sub overrides "weak" keyword */
6432 else { /* no override */
6434 if (tmp == KEY_dump) {
6435 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6436 "dump() better written as CORE::dump()");
6440 if (hgv && tmp != KEY_x) /* never ambiguous */
6441 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6442 "Ambiguous call resolved as CORE::%s(), "
6443 "qualify as such or use &",
6448 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
6449 && (!anydelim || *s != '#')) {
6450 /* no override, and not s### either; skipspace is safe here
6451 * check for => on following line */
6453 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
6454 STRLEN soff = s - SvPVX(PL_linestr);
6455 s = skipspace_flags(s, LEX_NO_INCLINE);
6456 arrow = *s == '=' && s[1] == '>';
6457 PL_bufptr = SvPVX(PL_linestr) + bufoff;
6458 s = SvPVX(PL_linestr) + soff;
6466 default: /* not a keyword */
6467 /* Trade off - by using this evil construction we can pull the
6468 variable gv into the block labelled keylookup. If not, then
6469 we have to give it function scope so that the goto from the
6470 earlier ':' case doesn't bypass the initialisation. */
6472 just_a_word_zero_gv:
6484 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6485 const char penultchar =
6486 lastchar && PL_bufptr - 2 >= PL_linestart
6491 /* Get the rest if it looks like a package qualifier */
6493 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6495 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6498 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
6499 UTF8fARG(UTF, len, PL_tokenbuf),
6500 *s == '\'' ? "'" : "::");
6505 if (PL_expect == XOPERATOR) {
6506 if (PL_bufptr == PL_linestart) {
6507 CopLINE_dec(PL_curcop);
6508 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6509 CopLINE_inc(PL_curcop);
6512 no_op("Bareword",s);
6515 /* Look for a subroutine with this name in current package,
6516 unless this is a lexical sub, or name is "Foo::",
6517 in which case Foo is a bareword
6518 (and a package name). */
6521 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6523 if (ckWARN(WARN_BAREWORD)
6524 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6525 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6526 "Bareword \"%"UTF8f"\" refers to nonexistent package",
6527 UTF8fARG(UTF, len, PL_tokenbuf));
6529 PL_tokenbuf[len] = '\0';
6535 /* Mustn't actually add anything to a symbol table.
6536 But also don't want to "initialise" any placeholder
6537 constants that might already be there into full
6538 blown PVGVs with attached PVCV. */
6539 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6540 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
6546 /* if we saw a global override before, get the right name */
6549 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6550 len ? len : strlen(PL_tokenbuf));
6552 SV * const tmp_sv = sv;
6553 sv = newSVpvs("CORE::GLOBAL::");
6554 sv_catsv(sv, tmp_sv);
6555 SvREFCNT_dec(tmp_sv);
6559 /* Presume this is going to be a bareword of some sort. */
6561 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6562 pl_yylval.opval->op_private = OPpCONST_BARE;
6564 /* And if "Foo::", then that's what it certainly is. */
6570 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6571 const_op->op_private = OPpCONST_BARE;
6572 rv2cv_op = newCVREF(0, const_op);
6573 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
6576 /* See if it's the indirect object for a list operator. */
6578 if (PL_oldoldbufptr &&
6579 PL_oldoldbufptr < PL_bufptr &&
6580 (PL_oldoldbufptr == PL_last_lop
6581 || PL_oldoldbufptr == PL_last_uni) &&
6582 /* NO SKIPSPACE BEFORE HERE! */
6583 (PL_expect == XREF ||
6584 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6586 bool immediate_paren = *s == '(';
6588 /* (Now we can afford to cross potential line boundary.) */
6589 s = SKIPSPACE2(s,nextPL_nextwhite);
6591 /* Two barewords in a row may indicate method call. */
6593 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6594 (tmp = intuit_method(s, gv, cv))) {
6596 if (tmp == METHOD && !PL_lex_allbrackets &&
6597 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6598 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6602 /* If not a declared subroutine, it's an indirect object. */
6603 /* (But it's an indir obj regardless for sort.) */
6604 /* Also, if "_" follows a filetest operator, it's a bareword */
6607 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6609 (PL_last_lop_op != OP_MAPSTART &&
6610 PL_last_lop_op != OP_GREPSTART))))
6611 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6612 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6615 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6620 PL_expect = XOPERATOR;
6623 /* Is this a word before a => operator? */
6624 if (*s == '=' && s[1] == '>' && !pkgname) {
6627 /* This is our own scalar, created a few lines above,
6629 SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
6630 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6631 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6632 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6633 SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
6637 /* If followed by a paren, it's certainly a subroutine. */
6642 while (SPACE_OR_TAB(*d))
6644 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
6649 NEXTVAL_NEXTTOKE.opval =
6650 off ? rv2cv_op : pl_yylval.opval;
6651 PL_expect = XOPERATOR;
6653 op_free(pl_yylval.opval), force_next(PRIVATEREF);
6654 else op_free(rv2cv_op), force_next(WORD);
6659 /* If followed by var or block, call it a method (unless sub) */
6661 if ((*s == '$' || *s == '{') && !cv) {
6663 PL_last_lop = PL_oldbufptr;
6664 PL_last_lop_op = OP_METHOD;
6665 if (!PL_lex_allbrackets &&
6666 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6667 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6671 /* If followed by a bareword, see if it looks like indir obj. */
6674 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6675 && (tmp = intuit_method(s, gv, cv))) {
6677 if (tmp == METHOD && !PL_lex_allbrackets &&
6678 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6679 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6683 /* Not a method, so call it a subroutine (if defined) */
6686 if (lastchar == '-' && penultchar != '-') {
6687 const STRLEN l = len ? len : strlen(PL_tokenbuf);
6688 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6689 "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
6690 UTF8fARG(UTF, l, PL_tokenbuf),
6691 UTF8fARG(UTF, l, PL_tokenbuf));
6693 /* Check for a constant sub */
6694 if ((sv = cv_const_sv_or_av(cv))) {
6697 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6698 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6699 if (SvTYPE(sv) == SVt_PVAV)
6700 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
6703 pl_yylval.opval->op_private = 0;
6704 pl_yylval.opval->op_folded = 1;
6705 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6710 op_free(pl_yylval.opval);
6712 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
6713 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6714 PL_last_lop = PL_oldbufptr;
6715 PL_last_lop_op = OP_ENTERSUB;
6716 /* Is there a prototype? */
6720 STRLEN protolen = CvPROTOLEN(cv);
6721 const char *proto = CvPROTO(cv);
6723 proto = S_strip_spaces(aTHX_ proto, &protolen);
6726 if ((optional = *proto == ';'))
6729 while (*proto == ';');
6733 *proto == '$' || *proto == '_'
6734 || *proto == '*' || *proto == '+'
6739 *proto == '\\' && proto[1] && proto[2] == '\0'
6742 UNIPROTO(UNIOPSUB,optional);
6743 if (*proto == '\\' && proto[1] == '[') {
6744 const char *p = proto + 2;
6745 while(*p && *p != ']')
6747 if(*p == ']' && !p[1])
6748 UNIPROTO(UNIOPSUB,optional);
6750 if (*proto == '&' && *s == '{') {
6752 sv_setpvs(PL_subname, "__ANON__");
6754 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6755 if (!PL_lex_allbrackets &&
6756 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6757 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6761 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6763 force_next(off ? PRIVATEREF : WORD);
6764 if (!PL_lex_allbrackets &&
6765 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6766 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6770 /* Call it a bare word */
6772 if (PL_hints & HINT_STRICT_SUBS)
6773 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6776 /* after "print" and similar functions (corresponding to
6777 * "F? L" in opcode.pl), whatever wasn't already parsed as
6778 * a filehandle should be subject to "strict subs".
6779 * Likewise for the optional indirect-object argument to system
6780 * or exec, which can't be a bareword */
6781 if ((PL_last_lop_op == OP_PRINT
6782 || PL_last_lop_op == OP_PRTF
6783 || PL_last_lop_op == OP_SAY
6784 || PL_last_lop_op == OP_SYSTEM
6785 || PL_last_lop_op == OP_EXEC)
6786 && (PL_hints & HINT_STRICT_SUBS))
6787 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6788 if (lastchar != '-') {
6789 if (ckWARN(WARN_RESERVED)) {
6793 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6795 /* PL_warn_reserved is constant */
6796 GCC_DIAG_IGNORE(-Wformat-nonliteral);
6797 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6807 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
6808 && saw_infix_sigil) {
6809 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6810 "Operator or semicolon missing before %c%"UTF8f,
6812 UTF8fARG(UTF, strlen(PL_tokenbuf),
6814 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6815 "Ambiguous use of %c resolved as operator %c",
6816 lastchar, lastchar);
6823 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6828 (OP*)newSVOP(OP_CONST, 0,
6829 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6832 case KEY___PACKAGE__:
6834 (OP*)newSVOP(OP_CONST, 0,
6836 ? newSVhek(HvNAME_HEK(PL_curstash))
6843 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6844 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6847 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6849 gv_init(gv,stash,"DATA",4,0);
6852 GvIOp(gv) = newIO();
6853 IoIFP(GvIOp(gv)) = PL_rsfp;
6854 #if defined(HAS_FCNTL) && defined(F_SETFD)
6856 const int fd = PerlIO_fileno(PL_rsfp);
6857 fcntl(fd,F_SETFD,fd >= 3);
6860 /* Mark this internal pseudo-handle as clean */
6861 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6862 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6863 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6865 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6866 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6867 /* if the script was opened in binmode, we need to revert
6868 * it to text mode for compatibility; but only iff it has CRs
6869 * XXX this is a questionable hack at best. */
6870 if (PL_bufend-PL_bufptr > 2
6871 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6874 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6875 loc = PerlIO_tell(PL_rsfp);
6876 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6879 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6881 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6882 #endif /* NETWARE */
6884 PerlIO_seek(PL_rsfp, loc, 0);
6888 #ifdef PERLIO_LAYERS
6891 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6892 else if (PL_encoding) {
6898 XPUSHs(PL_encoding);
6900 call_method("name", G_SCALAR);
6904 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
6905 Perl_form(aTHX_ ":encoding(%"SVf")",
6918 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
6927 if (PL_expect == XSTATE) {
6938 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6939 if ((*s == ':' && s[1] == ':')
6940 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
6944 Copy(PL_bufptr, PL_tokenbuf, olen, char);
6948 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
6949 UTF8fARG(UTF, len, PL_tokenbuf));
6952 else if (tmp == KEY_require || tmp == KEY_do
6954 /* that's a way to remember we saw "CORE::" */
6966 LOP(OP_ACCEPT,XTERM);
6969 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
6974 LOP(OP_ATAN2,XTERM);
6980 LOP(OP_BINMODE,XTERM);
6983 LOP(OP_BLESS,XTERM);
6992 /* We have to disambiguate the two senses of
6993 "continue". If the next token is a '{' then
6994 treat it as the start of a continue block;
6995 otherwise treat it as a control operator.
7005 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7015 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7024 if (!PL_cryptseen) {
7025 PL_cryptseen = TRUE;
7029 LOP(OP_CRYPT,XTERM);
7032 LOP(OP_CHMOD,XTERM);
7035 LOP(OP_CHOWN,XTERM);
7038 LOP(OP_CONNECT,XTERM);
7058 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7060 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7061 && !keyword(PL_tokenbuf + 1, len, 0)) {
7064 force_ident_maybe_lex('&');
7069 if (orig_keyword == KEY_do) {
7078 PL_hints |= HINT_BLOCK_SCOPE;
7088 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7089 STR_WITH_LEN("NDBM_File::"),
7090 STR_WITH_LEN("DB_File::"),
7091 STR_WITH_LEN("GDBM_File::"),
7092 STR_WITH_LEN("SDBM_File::"),
7093 STR_WITH_LEN("ODBM_File::"),
7095 LOP(OP_DBMOPEN,XTERM);
7101 PL_expect = XOPERATOR;
7102 s = force_word(s,WORD,TRUE,FALSE);
7109 pl_yylval.ival = CopLINE(PL_curcop);
7113 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7125 if (*s == '{') { /* block eval */
7126 PL_expect = XTERMBLOCK;
7127 UNIBRACK(OP_ENTERTRY);
7129 else { /* string eval */
7131 UNIBRACK(OP_ENTEREVAL);
7136 UNIBRACK(-OP_ENTEREVAL);
7150 case KEY_endhostent:
7156 case KEY_endservent:
7159 case KEY_endprotoent:
7170 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7172 pl_yylval.ival = CopLINE(PL_curcop);
7174 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7177 if ((PL_bufend - p) >= 3 &&
7178 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7180 else if ((PL_bufend - p) >= 4 &&
7181 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7184 /* skip optional package name, as in "for my abc $x (..)" */
7185 if (isIDFIRST_lazy_if(p,UTF)) {
7186 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7190 Perl_croak(aTHX_ "Missing $ on loop variable");
7195 LOP(OP_FORMLINE,XTERM);
7204 LOP(OP_FCNTL,XTERM);
7210 LOP(OP_FLOCK,XTERM);
7213 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7218 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7223 LOP(OP_GREPSTART, XREF);
7226 PL_expect = XOPERATOR;
7227 s = force_word(s,WORD,TRUE,FALSE);
7242 case KEY_getpriority:
7243 LOP(OP_GETPRIORITY,XTERM);
7245 case KEY_getprotobyname:
7248 case KEY_getprotobynumber:
7249 LOP(OP_GPBYNUMBER,XTERM);
7251 case KEY_getprotoent:
7263 case KEY_getpeername:
7264 UNI(OP_GETPEERNAME);
7266 case KEY_gethostbyname:
7269 case KEY_gethostbyaddr:
7270 LOP(OP_GHBYADDR,XTERM);
7272 case KEY_gethostent:
7275 case KEY_getnetbyname:
7278 case KEY_getnetbyaddr:
7279 LOP(OP_GNBYADDR,XTERM);
7284 case KEY_getservbyname:
7285 LOP(OP_GSBYNAME,XTERM);
7287 case KEY_getservbyport:
7288 LOP(OP_GSBYPORT,XTERM);
7290 case KEY_getservent:
7293 case KEY_getsockname:
7294 UNI(OP_GETSOCKNAME);
7296 case KEY_getsockopt:
7297 LOP(OP_GSOCKOPT,XTERM);
7312 pl_yylval.ival = CopLINE(PL_curcop);
7313 Perl_ck_warner_d(aTHX_
7314 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7315 "given is experimental");
7320 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
7328 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7330 pl_yylval.ival = CopLINE(PL_curcop);
7334 LOP(OP_INDEX,XTERM);
7340 LOP(OP_IOCTL,XTERM);
7352 PL_expect = XOPERATOR;
7353 s = force_word(s,WORD,TRUE,FALSE);
7370 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7375 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7389 LOP(OP_LISTEN,XTERM);
7398 s = scan_pat(s,OP_MATCH);
7399 TERM(sublex_start());
7402 LOP(OP_MAPSTART, XREF);
7405 LOP(OP_MKDIR,XTERM);
7408 LOP(OP_MSGCTL,XTERM);
7411 LOP(OP_MSGGET,XTERM);
7414 LOP(OP_MSGRCV,XTERM);
7417 LOP(OP_MSGSND,XTERM);
7422 PL_in_my = (U16)tmp;
7424 if (isIDFIRST_lazy_if(s,UTF)) {
7425 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7426 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7428 if (!FEATURE_LEXSUBS_IS_ENABLED)
7430 "Experimental \"%s\" subs not enabled",
7431 tmp == KEY_my ? "my" :
7432 tmp == KEY_state ? "state" : "our");
7433 Perl_ck_warner_d(aTHX_
7434 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
7435 "The lexical_subs feature is experimental");
7438 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7439 if (!PL_in_my_stash) {
7442 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7443 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7450 PL_expect = XOPERATOR;
7451 s = force_word(s,WORD,TRUE,FALSE);
7455 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7460 s = tokenize_use(0, s);
7464 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7467 if (!PL_lex_allbrackets &&
7468 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7469 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7475 if (isIDFIRST_lazy_if(s,UTF)) {
7477 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
7479 for (t=d; isSPACE(*t);)
7481 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7483 && !(t[0] == '=' && t[1] == '>')
7484 && !(t[0] == ':' && t[1] == ':')
7485 && !keyword(s, d-s, 0)
7487 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7488 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
7489 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
7495 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7497 pl_yylval.ival = OP_OR;
7507 LOP(OP_OPEN_DIR,XTERM);
7510 checkcomma(s,PL_tokenbuf,"filehandle");
7514 checkcomma(s,PL_tokenbuf,"filehandle");
7533 s = force_word(s,WORD,FALSE,TRUE);
7535 s = force_strict_version(s);
7536 PL_lex_expect = XBLOCK;
7540 LOP(OP_PIPE_OP,XTERM);
7543 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7546 COPLINE_SET_FROM_MULTI_END;
7547 pl_yylval.ival = OP_CONST;
7548 TERM(sublex_start());
7555 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7558 COPLINE_SET_FROM_MULTI_END;
7559 PL_expect = XOPERATOR;
7560 if (SvCUR(PL_lex_stuff)) {
7561 int warned_comma = !ckWARN(WARN_QW);
7562 int warned_comment = warned_comma;
7563 d = SvPV_force(PL_lex_stuff, len);
7565 for (; isSPACE(*d) && len; --len, ++d)
7570 if (!warned_comma || !warned_comment) {
7571 for (; !isSPACE(*d) && len; --len, ++d) {
7572 if (!warned_comma && *d == ',') {
7573 Perl_warner(aTHX_ packWARN(WARN_QW),
7574 "Possible attempt to separate words with commas");
7577 else if (!warned_comment && *d == '#') {
7578 Perl_warner(aTHX_ packWARN(WARN_QW),
7579 "Possible attempt to put comments in qw() list");
7585 for (; !isSPACE(*d) && len; --len, ++d)
7588 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7589 words = op_append_elem(OP_LIST, words,
7590 newSVOP(OP_CONST, 0, tokeq(sv)));
7595 words = newNULLLIST();
7597 SvREFCNT_dec(PL_lex_stuff);
7598 PL_lex_stuff = NULL;
7600 PL_expect = XOPERATOR;
7601 pl_yylval.opval = sawparens(words);
7606 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7609 pl_yylval.ival = OP_STRINGIFY;
7610 if (SvIVX(PL_lex_stuff) == '\'')
7611 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7612 TERM(sublex_start());
7615 s = scan_pat(s,OP_QR);
7616 TERM(sublex_start());
7619 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7622 pl_yylval.ival = OP_BACKTICK;
7623 TERM(sublex_start());
7630 PL_expect = XOPERATOR;
7632 s = force_version(s, FALSE);
7634 else if (*s != 'v' || !isDIGIT(s[1])
7635 || (s = force_version(s, TRUE), *s == 'v'))
7637 *PL_tokenbuf = '\0';
7638 s = force_word(s,WORD,TRUE,TRUE);
7639 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7640 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7641 GV_ADD | (UTF ? SVf_UTF8 : 0));
7643 yyerror("<> at require-statement should be quotes");
7645 if (orig_keyword == KEY_require) {
7653 PL_last_uni = PL_oldbufptr;
7654 PL_last_lop_op = OP_REQUIRE;
7656 return REPORT( (int)REQUIRE );
7662 PL_expect = XOPERATOR;
7663 s = force_word(s,WORD,TRUE,FALSE);
7667 LOP(OP_RENAME,XTERM);
7676 LOP(OP_RINDEX,XTERM);
7685 UNIDOR(OP_READLINE);
7688 UNIDOR(OP_BACKTICK);
7697 LOP(OP_REVERSE,XTERM);
7700 UNIDOR(OP_READLINK);
7707 if (pl_yylval.opval)
7708 TERM(sublex_start());
7710 TOKEN(1); /* force error */
7713 checkcomma(s,PL_tokenbuf,"filehandle");
7723 LOP(OP_SELECT,XTERM);
7729 LOP(OP_SEMCTL,XTERM);
7732 LOP(OP_SEMGET,XTERM);
7735 LOP(OP_SEMOP,XTERM);
7741 LOP(OP_SETPGRP,XTERM);
7743 case KEY_setpriority:
7744 LOP(OP_SETPRIORITY,XTERM);
7746 case KEY_sethostent:
7752 case KEY_setservent:
7755 case KEY_setprotoent:
7765 LOP(OP_SEEKDIR,XTERM);
7767 case KEY_setsockopt:
7768 LOP(OP_SSOCKOPT,XTERM);
7774 LOP(OP_SHMCTL,XTERM);
7777 LOP(OP_SHMGET,XTERM);
7780 LOP(OP_SHMREAD,XTERM);
7783 LOP(OP_SHMWRITE,XTERM);
7786 LOP(OP_SHUTDOWN,XTERM);
7795 LOP(OP_SOCKET,XTERM);
7797 case KEY_socketpair:
7798 LOP(OP_SOCKPAIR,XTERM);
7801 checkcomma(s,PL_tokenbuf,"subroutine name");
7804 s = force_word(s,WORD,TRUE,TRUE);
7808 LOP(OP_SPLIT,XTERM);
7811 LOP(OP_SPRINTF,XTERM);
7814 LOP(OP_SPLICE,XTERM);
7829 LOP(OP_SUBSTR,XTERM);
7835 char * const tmpbuf = PL_tokenbuf + 1;
7836 expectation attrful;
7837 bool have_name, have_proto;
7838 const int key = tmp;
7839 SV *format_name = NULL;
7844 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7845 (*s == ':' && s[1] == ':'))
7849 attrful = XATTRBLOCK;
7850 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
7852 if (key == KEY_format)
7853 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
7855 if (memchr(tmpbuf, ':', len) || key != KEY_sub
7857 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
7859 sv_setpvn(PL_subname, tmpbuf, len);
7861 sv_setsv(PL_subname,PL_curstname);
7862 sv_catpvs(PL_subname,"::");
7863 sv_catpvn(PL_subname,tmpbuf,len);
7865 if (SvUTF8(PL_linestr))
7866 SvUTF8_on(PL_subname);
7873 if (key == KEY_my || key == KEY_our || key==KEY_state)
7876 /* diag_listed_as: Missing name in "%s sub" */
7878 "Missing name in \"%s\"", PL_bufptr);
7880 PL_expect = XTERMBLOCK;
7881 attrful = XATTRTERM;
7882 sv_setpvs(PL_subname,"?");
7886 if (key == KEY_format) {
7888 NEXTVAL_NEXTTOKE.opval
7889 = (OP*)newSVOP(OP_CONST,0, format_name);
7890 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
7896 /* Look for a prototype */
7897 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
7898 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7899 COPLINE_SET_FROM_MULTI_END;
7901 Perl_croak(aTHX_ "Prototype not terminated");
7902 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
7910 if (*s == ':' && s[1] != ':')
7911 PL_expect = attrful;
7912 else if ((*s != '{' && *s != '(') && key == KEY_sub) {
7914 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
7915 else if (*s != ';' && *s != '}')
7916 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
7920 NEXTVAL_NEXTTOKE.opval =
7921 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
7922 PL_lex_stuff = NULL;
7927 sv_setpvs(PL_subname, "__ANON__");
7929 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7932 force_ident_maybe_lex('&');
7937 LOP(OP_SYSTEM,XREF);
7940 LOP(OP_SYMLINK,XTERM);
7943 LOP(OP_SYSCALL,XTERM);
7946 LOP(OP_SYSOPEN,XTERM);
7949 LOP(OP_SYSSEEK,XTERM);
7952 LOP(OP_SYSREAD,XTERM);
7955 LOP(OP_SYSWRITE,XTERM);
7960 TERM(sublex_start());
7981 LOP(OP_TRUNCATE,XTERM);
7993 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7995 pl_yylval.ival = CopLINE(PL_curcop);
7999 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8001 pl_yylval.ival = CopLINE(PL_curcop);
8005 LOP(OP_UNLINK,XTERM);
8011 LOP(OP_UNPACK,XTERM);
8014 LOP(OP_UTIME,XTERM);
8020 LOP(OP_UNSHIFT,XTERM);
8023 s = tokenize_use(1, s);
8033 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8035 pl_yylval.ival = CopLINE(PL_curcop);
8036 Perl_ck_warner_d(aTHX_
8037 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8038 "when is experimental");
8042 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8044 pl_yylval.ival = CopLINE(PL_curcop);
8048 PL_hints |= HINT_BLOCK_SCOPE;
8055 LOP(OP_WAITPID,XTERM);
8061 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8062 * we use the same number on EBCDIC */
8063 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8067 if (PL_expect == XOPERATOR) {
8068 if (*s == '=' && !PL_lex_allbrackets &&
8069 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8077 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8079 pl_yylval.ival = OP_XOR;
8088 Looks up an identifier in the pad or in a package
8091 PRIVATEREF if this is a lexical name.
8092 WORD if this belongs to a package.
8095 if we're in a my declaration
8096 croak if they tried to say my($foo::bar)
8097 build the ops for a my() declaration
8098 if it's an access to a my() variable
8099 build ops for access to a my() variable
8100 if in a dq string, and they've said @foo and we can't find @foo
8102 build ops for a bareword
8106 S_pending_ident(pTHX)
8110 const char pit = (char)pl_yylval.ival;
8111 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8112 /* All routes through this function want to know if there is a colon. */
8113 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8115 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8116 "### Pending identifier '%s'\n", PL_tokenbuf); });
8118 /* if we're in a my(), we can't allow dynamics here.
8119 $foo'bar has already been turned into $foo::bar, so
8120 just check for colons.
8122 if it's a legal name, the OP is a PADANY.
8125 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8127 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8128 "variable %s in \"our\"",
8129 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8130 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8134 /* PL_no_myglob is constant */
8135 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8136 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8137 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8138 UTF ? SVf_UTF8 : 0);
8142 pl_yylval.opval = newOP(OP_PADANY, 0);
8143 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8144 UTF ? SVf_UTF8 : 0);
8150 build the ops for accesses to a my() variable.
8155 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8156 UTF ? SVf_UTF8 : 0);
8157 if (tmp != NOT_IN_PAD) {
8158 /* might be an "our" variable" */
8159 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8160 /* build ops for a bareword */
8161 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8162 HEK * const stashname = HvNAME_HEK(stash);
8163 SV * const sym = newSVhek(stashname);
8164 sv_catpvs(sym, "::");
8165 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8166 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8167 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8171 ? (GV_ADDMULTI | GV_ADDINEVAL)
8174 ((PL_tokenbuf[0] == '$') ? SVt_PV
8175 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8180 pl_yylval.opval = newOP(OP_PADANY, 0);
8181 pl_yylval.opval->op_targ = tmp;
8187 Whine if they've said @foo in a doublequoted string,
8188 and @foo isn't a variable we can find in the symbol
8191 if (ckWARN(WARN_AMBIGUOUS) &&
8192 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8193 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8194 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8195 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8196 /* DO NOT warn for @- and @+ */
8197 && !( PL_tokenbuf[2] == '\0' &&
8198 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8201 /* Downgraded from fatal to warning 20000522 mjd */
8202 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8203 "Possible unintended interpolation of %"UTF8f
8205 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8209 /* build ops for a bareword */
8210 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8211 newSVpvn_flags(PL_tokenbuf + 1,
8213 UTF ? SVf_UTF8 : 0 ));
8214 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8216 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8217 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8218 | ( UTF ? SVf_UTF8 : 0 ),
8219 ((PL_tokenbuf[0] == '$') ? SVt_PV
8220 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8226 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8230 PERL_ARGS_ASSERT_CHECKCOMMA;
8232 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8233 if (ckWARN(WARN_SYNTAX)) {
8236 for (w = s+2; *w && level; w++) {
8244 /* the list of chars below is for end of statements or
8245 * block / parens, boolean operators (&&, ||, //) and branch
8246 * constructs (or, and, if, until, unless, while, err, for).
8247 * Not a very solid hack... */
8248 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8249 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8250 "%s (...) interpreted as function",name);
8253 while (s < PL_bufend && isSPACE(*s))
8257 while (s < PL_bufend && isSPACE(*s))
8259 if (isIDFIRST_lazy_if(s,UTF)) {
8260 const char * const w = s;
8261 s += UTF ? UTF8SKIP(s) : 1;
8262 while (isWORDCHAR_lazy_if(s,UTF))
8263 s += UTF ? UTF8SKIP(s) : 1;
8264 while (s < PL_bufend && isSPACE(*s))
8268 if (keyword(w, s - w, 0))
8271 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8272 if (gv && GvCVu(gv))
8274 Perl_croak(aTHX_ "No comma allowed after %s", what);
8279 /* S_new_constant(): do any overload::constant lookup.
8281 Either returns sv, or mortalizes/frees sv and returns a new SV*.
8282 Best used as sv=new_constant(..., sv, ...).
8283 If s, pv are NULL, calls subroutine with one argument,
8284 and <type> is used with error messages only.
8285 <type> is assumed to be well formed UTF-8 */
8288 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8289 SV *sv, SV *pv, const char *type, STRLEN typelen)
8292 HV * table = GvHV(PL_hintgv); /* ^H */
8297 const char *why1 = "", *why2 = "", *why3 = "";
8299 PERL_ARGS_ASSERT_NEW_CONSTANT;
8300 /* We assume that this is true: */
8301 if (*key == 'c') { assert (strEQ(key, "charnames")); }
8304 /* charnames doesn't work well if there have been errors found */
8305 if (PL_error_count > 0 && *key == 'c')
8307 SvREFCNT_dec_NN(sv);
8308 return &PL_sv_undef;
8311 sv_2mortal(sv); /* Parent created it permanently */
8313 || ! (PL_hints & HINT_LOCALIZE_HH)
8314 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8319 /* Here haven't found what we're looking for. If it is charnames,
8320 * perhaps it needs to be loaded. Try doing that before giving up */
8322 Perl_load_module(aTHX_
8324 newSVpvs("_charnames"),
8325 /* version parameter; no need to specify it, as if
8326 * we get too early a version, will fail anyway,
8327 * not being able to find '_charnames' */
8332 assert(sp == PL_stack_sp);
8333 table = GvHV(PL_hintgv);
8335 && (PL_hints & HINT_LOCALIZE_HH)
8336 && (cvp = hv_fetch(table, key, keylen, FALSE))
8342 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8343 msg = Perl_form(aTHX_
8344 "Constant(%.*s) unknown",
8345 (int)(type ? typelen : len),
8351 why3 = "} is not defined";
8354 msg = Perl_form(aTHX_
8355 /* The +3 is for '\N{'; -4 for that, plus '}' */
8356 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
8360 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
8361 (int)(type ? typelen : len),
8362 (type ? type: s), why1, why2, why3);
8365 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
8366 return SvREFCNT_inc_simple_NN(sv);
8371 pv = newSVpvn_flags(s, len, SVs_TEMP);
8373 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8375 typesv = &PL_sv_undef;
8377 PUSHSTACKi(PERLSI_OVERLOAD);
8389 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8393 /* Check the eval first */
8394 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
8396 const char * errstr;
8397 sv_catpvs(errsv, "Propagated");
8398 errstr = SvPV_const(errsv, errlen);
8399 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
8401 res = SvREFCNT_inc_simple_NN(sv);
8405 SvREFCNT_inc_simple_void_NN(res);
8414 why1 = "Call to &{$^H{";
8416 why3 = "}} did not return a defined value";
8418 (void)sv_2mortal(sv);
8425 PERL_STATIC_INLINE void
8426 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
8428 PERL_ARGS_ASSERT_PARSE_IDENT;
8432 Perl_croak(aTHX_ "%s", ident_too_long);
8433 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
8434 /* The UTF-8 case must come first, otherwise things
8435 * like c\N{COMBINING TILDE} would start failing, as the
8436 * isWORDCHAR_A case below would gobble the 'c' up.
8439 char *t = *s + UTF8SKIP(*s);
8440 while (isIDCONT_utf8((U8*)t))
8442 if (*d + (t - *s) > e)
8443 Perl_croak(aTHX_ "%s", ident_too_long);
8444 Copy(*s, *d, t - *s, char);
8448 else if ( isWORDCHAR_A(**s) ) {
8451 } while (isWORDCHAR_A(**s) && *d < e);
8453 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
8458 else if (allow_package && **s == ':' && (*s)[1] == ':'
8459 /* Disallow things like Foo::$bar. For the curious, this is
8460 * the code path that triggers the "Bad name after" warning
8461 * when looking for barewords.
8463 && (*s)[2] != '$') {
8473 /* Returns a NUL terminated string, with the length of the string written to
8477 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8481 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8482 bool is_utf8 = cBOOL(UTF);
8484 PERL_ARGS_ASSERT_SCAN_WORD;
8486 parse_ident(&s, &d, e, allow_package, is_utf8);
8493 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
8496 I32 herelines = PL_parser->herelines;
8497 SSize_t bracket = -1;
8500 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8501 bool is_utf8 = cBOOL(UTF);
8502 I32 orig_copline = 0, tmp_copline = 0;
8504 PERL_ARGS_ASSERT_SCAN_IDENT;
8509 while (isDIGIT(*s)) {
8511 Perl_croak(aTHX_ "%s", ident_too_long);
8516 parse_ident(&s, &d, e, 1, is_utf8);
8521 /* Either a digit variable, or parse_ident() found an identifier
8522 (anything valid as a bareword), so job done and return. */
8523 if (PL_lex_state != LEX_NORMAL)
8524 PL_lex_state = LEX_INTERPENDMAYBE;
8527 if (*s == '$' && s[1] &&
8528 (isIDFIRST_lazy_if(s+1,is_utf8)
8529 || isDIGIT_A((U8)s[1])
8532 || strnEQ(s+1,"::",2)) )
8534 /* Dereferencing a value in a scalar variable.
8535 The alternatives are different syntaxes for a scalar variable.
8536 Using ' as a leading package separator isn't allowed. :: is. */
8539 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
8541 bracket = s - SvPVX(PL_linestr);
8543 orig_copline = CopLINE(PL_curcop);
8544 if (s < PL_bufend && isSPACE(*s)) {
8549 /* Is the byte 'd' a legal single character identifier name? 'u' is true
8550 * iff Unicode semantics are to be used. The legal ones are any of:
8552 * b) ASCII punctuation
8553 * c) When not under Unicode rules, any upper Latin1 character
8554 * d) \c?, \c\, \c^, \c_, and \cA..\cZ, minus the ones that have traditionally
8555 * been matched by \s on ASCII platforms. That is: \c?, plus 1-32, minus
8557 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
8558 || isDIGIT_A((U8)(d)) \
8559 || (!(u) && !isASCII((U8)(d))) \
8560 || ((((U8)(d)) < 32) \
8561 && (((((U8)(d)) >= 14) \
8562 || (((U8)(d)) <= 8 && (d) != 0) \
8563 || (((U8)(d)) == 13)))) \
8564 || (((U8)(d)) == toCTRL('?')))
8566 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
8568 if ( isCNTRL_A((U8)*s) ) {
8569 deprecate("literal control characters in variable names");
8573 const STRLEN skip = UTF8SKIP(s);
8576 for ( i = 0; i < skip; i++ )
8584 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
8585 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8589 /* Warn about ambiguous code after unary operators if {...} notation isn't
8590 used. There's no difference in ambiguity; it's merely a heuristic
8591 about when not to warn. */
8592 else if (ck_uni && bracket == -1)
8594 if (bracket != -1) {
8595 /* If we were processing {...} notation then... */
8596 if (isIDFIRST_lazy_if(d,is_utf8)) {
8597 /* if it starts as a valid identifier, assume that it is one.
8598 (the later check for } being at the expected point will trap
8599 cases where this doesn't pan out.) */
8600 d += is_utf8 ? UTF8SKIP(d) : 1;
8601 parse_ident(&s, &d, e, 1, is_utf8);
8603 tmp_copline = CopLINE(PL_curcop);
8604 if (s < PL_bufend && isSPACE(*s)) {
8607 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8608 /* ${foo[0]} and ${foo{bar}} notation. */
8609 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8610 const char * const brack =
8612 ((*s == '[') ? "[...]" : "{...}");
8613 orig_copline = CopLINE(PL_curcop);
8614 CopLINE_set(PL_curcop, tmp_copline);
8615 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8616 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8617 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8618 funny, dest, brack, funny, dest, brack);
8619 CopLINE_set(PL_curcop, orig_copline);
8622 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8623 PL_lex_allbrackets++;
8627 /* Handle extended ${^Foo} variables
8628 * 1999-02-27 mjd-perl-patch@plover.com */
8629 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
8633 while (isWORDCHAR(*s) && d < e) {
8637 Perl_croak(aTHX_ "%s", ident_too_long);
8642 tmp_copline = CopLINE(PL_curcop);
8643 if (s < PL_bufend && isSPACE(*s)) {
8647 /* Expect to find a closing } after consuming any trailing whitespace.
8651 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8652 PL_lex_state = LEX_INTERPEND;
8655 if (PL_lex_state == LEX_NORMAL) {
8656 if (ckWARN(WARN_AMBIGUOUS) &&
8657 (keyword(dest, d - dest, 0)
8658 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
8660 SV *tmp = newSVpvn_flags( dest, d - dest,
8661 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
8664 orig_copline = CopLINE(PL_curcop);
8665 CopLINE_set(PL_curcop, tmp_copline);
8666 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8667 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
8668 funny, SVfARG(tmp), funny, SVfARG(tmp));
8669 CopLINE_set(PL_curcop, orig_copline);
8674 /* Didn't find the closing } at the point we expected, so restore
8675 state such that the next thing to process is the opening { and */
8676 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
8677 CopLINE_set(PL_curcop, orig_copline);
8678 PL_parser->herelines = herelines;
8682 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8683 PL_lex_state = LEX_INTERPEND;
8688 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8690 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8691 * the parse starting at 's', based on the subset that are valid in this
8692 * context input to this routine in 'valid_flags'. Advances s. Returns
8693 * TRUE if the input should be treated as a valid flag, so the next char
8694 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
8695 * first call on the current regex. This routine will set it to any
8696 * charset modifier found. The caller shouldn't change it. This way,
8697 * another charset modifier encountered in the parse can be detected as an
8698 * error, as we have decided to allow only one */
8701 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
8703 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
8704 if (isWORDCHAR_lazy_if(*s, UTF)) {
8705 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
8706 UTF ? SVf_UTF8 : 0);
8708 /* Pretend that it worked, so will continue processing before
8717 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8718 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8719 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8720 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8721 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8722 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8723 case LOCALE_PAT_MOD:
8725 goto multiple_charsets;
8727 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8730 case UNICODE_PAT_MOD:
8732 goto multiple_charsets;
8734 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8737 case ASCII_RESTRICT_PAT_MOD:
8739 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8743 /* Error if previous modifier wasn't an 'a', but if it was, see
8744 * if, and accept, a second occurrence (only) */
8746 || get_regex_charset(*pmfl)
8747 != REGEX_ASCII_RESTRICTED_CHARSET)
8749 goto multiple_charsets;
8751 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8755 case DEPENDS_PAT_MOD:
8757 goto multiple_charsets;
8759 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8768 if (*charset != c) {
8769 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8771 else if (c == 'a') {
8772 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
8773 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8776 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8779 /* Pretend that it worked, so will continue processing before dieing */
8785 S_scan_pat(pTHX_ char *start, I32 type)
8790 const char * const valid_flags =
8791 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8792 char charset = '\0'; /* character set modifier */
8794 PERL_ARGS_ASSERT_SCAN_PAT;
8796 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
8798 Perl_croak(aTHX_ "Search pattern not terminated");
8800 pm = (PMOP*)newPMOP(type, 0);
8801 if (PL_multi_open == '?') {
8802 /* This is the only point in the code that sets PMf_ONCE: */
8803 pm->op_pmflags |= PMf_ONCE;
8805 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8806 allows us to restrict the list needed by reset to just the ??
8808 assert(type != OP_TRANS);
8810 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8813 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8816 elements = mg->mg_len / sizeof(PMOP**);
8817 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8818 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8819 mg->mg_len = elements * sizeof(PMOP**);
8820 PmopSTASH_set(pm,PL_curstash);
8824 /* if qr/...(?{..}).../, then need to parse the pattern within a new
8825 * anon CV. False positives like qr/[(?{]/ are harmless */
8827 if (type == OP_QR) {
8829 char *e, *p = SvPV(PL_lex_stuff, len);
8831 for (; p < e; p++) {
8832 if (p[0] == '(' && p[1] == '?'
8833 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
8835 pm->op_pmflags |= PMf_HAS_CV;
8839 pm->op_pmflags |= PMf_IS_QR;
8842 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
8843 /* issue a warning if /c is specified,but /g is not */
8844 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8846 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8847 "Use of /c modifier is meaningless without /g" );
8850 PL_lex_op = (OP*)pm;
8851 pl_yylval.ival = OP_MATCH;
8856 S_scan_subst(pTHX_ char *start)
8864 char charset = '\0'; /* character set modifier */
8867 PERL_ARGS_ASSERT_SCAN_SUBST;
8869 pl_yylval.ival = OP_NULL;
8871 s = scan_str(start, TRUE, FALSE, FALSE, &t);
8874 Perl_croak(aTHX_ "Substitution pattern not terminated");
8878 first_start = PL_multi_start;
8879 first_line = CopLINE(PL_curcop);
8880 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8883 SvREFCNT_dec(PL_lex_stuff);
8884 PL_lex_stuff = NULL;
8886 Perl_croak(aTHX_ "Substitution replacement not terminated");
8888 PL_multi_start = first_start; /* so whole substitution is taken together */
8890 pm = (PMOP*)newPMOP(OP_SUBST, 0);
8894 if (*s == EXEC_PAT_MOD) {
8898 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
8904 if ((pm->op_pmflags & PMf_CONTINUE)) {
8905 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
8909 SV * const repl = newSVpvs("");
8912 pm->op_pmflags |= PMf_EVAL;
8915 sv_catpvs(repl, "eval ");
8917 sv_catpvs(repl, "do ");
8919 sv_catpvs(repl, "{");
8920 sv_catsv(repl, PL_sublex_info.repl);
8921 sv_catpvs(repl, "}");
8923 SvREFCNT_dec(PL_sublex_info.repl);
8924 PL_sublex_info.repl = repl;
8926 if (CopLINE(PL_curcop) != first_line) {
8927 sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
8928 ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
8929 CopLINE(PL_curcop) - first_line;
8930 CopLINE_set(PL_curcop, first_line);
8933 PL_lex_op = (OP*)pm;
8934 pl_yylval.ival = OP_SUBST;
8939 S_scan_trans(pTHX_ char *start)
8947 bool nondestruct = 0;
8950 PERL_ARGS_ASSERT_SCAN_TRANS;
8952 pl_yylval.ival = OP_NULL;
8954 s = scan_str(start,FALSE,FALSE,FALSE,&t);
8956 Perl_croak(aTHX_ "Transliteration pattern not terminated");
8960 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8963 SvREFCNT_dec(PL_lex_stuff);
8964 PL_lex_stuff = NULL;
8966 Perl_croak(aTHX_ "Transliteration replacement not terminated");
8969 complement = del = squash = 0;
8973 complement = OPpTRANS_COMPLEMENT;
8976 del = OPpTRANS_DELETE;
8979 squash = OPpTRANS_SQUASH;
8991 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
8992 o->op_private &= ~OPpTRANS_ALL;
8993 o->op_private |= del|squash|complement|
8994 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
8995 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
8998 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9005 Takes a pointer to the first < in <<FOO.
9006 Returns a pointer to the byte following <<FOO.
9008 This function scans a heredoc, which involves different methods
9009 depending on whether we are in a string eval, quoted construct, etc.
9010 This is because PL_linestr could containing a single line of input, or
9011 a whole string being evalled, or the contents of the current quote-
9014 The two basic methods are:
9015 - Steal lines from the input stream
9016 - Scan the heredoc in PL_linestr and remove it therefrom
9018 In a file scope or filtered eval, the first method is used; in a
9019 string eval, the second.
9021 In a quote-like operator, we have to choose between the two,
9022 depending on where we can find a newline. We peek into outer lex-
9023 ing scopes until we find one with a newline in it. If we reach the
9024 outermost lexing scope and it is a file, we use the stream method.
9025 Otherwise it is treated as an eval.
9029 S_scan_heredoc(pTHX_ char *s)
9032 I32 op_type = OP_SCALAR;
9039 const bool infile = PL_rsfp || PL_parser->filtered;
9040 const line_t origline = CopLINE(PL_curcop);
9041 LEXSHARED *shared = PL_parser->lex_shared;
9043 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9046 d = PL_tokenbuf + 1;
9047 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9048 *PL_tokenbuf = '\n';
9050 while (SPACE_OR_TAB(*peek))
9052 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9055 s = delimcpy(d, e, s, PL_bufend, term, &len);
9057 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9063 /* <<\FOO is equivalent to <<'FOO' */
9067 if (!isWORDCHAR_lazy_if(s,UTF))
9068 deprecate("bare << to mean <<\"\"");
9069 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9074 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9075 Perl_croak(aTHX_ "Delimiter for here document is too long");
9078 len = d - PL_tokenbuf;
9080 #ifndef PERL_STRICT_CR
9081 d = strchr(s, '\r');
9083 char * const olds = s;
9085 while (s < PL_bufend) {
9091 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9100 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9105 tmpstr = newSV_type(SVt_PVIV);
9109 SvIV_set(tmpstr, -1);
9111 else if (term == '`') {
9112 op_type = OP_BACKTICK;
9113 SvIV_set(tmpstr, '\\');
9116 PL_multi_start = origline + 1 + PL_parser->herelines;
9117 PL_multi_open = PL_multi_close = '<';
9118 /* inside a string eval or quote-like operator */
9119 if (!infile || PL_lex_inwhat) {
9122 char * const olds = s;
9123 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9124 /* These two fields are not set until an inner lexing scope is
9125 entered. But we need them set here. */
9126 shared->ls_bufptr = s;
9127 shared->ls_linestr = PL_linestr;
9129 /* Look for a newline. If the current buffer does not have one,
9130 peek into the line buffer of the parent lexing scope, going
9131 up as many levels as necessary to find one with a newline
9134 while (!(s = (char *)memchr(
9135 (void *)shared->ls_bufptr, '\n',
9136 SvEND(shared->ls_linestr)-shared->ls_bufptr
9138 shared = shared->ls_prev;
9139 /* shared is only null if we have gone beyond the outermost
9140 lexing scope. In a file, we will have broken out of the
9141 loop in the previous iteration. In an eval, the string buf-
9142 fer ends with "\n;", so the while condition above will have
9143 evaluated to false. So shared can never be null. */
9145 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9146 most lexing scope. In a file, shared->ls_linestr at that
9147 level is just one line, so there is no body to steal. */
9148 if (infile && !shared->ls_prev) {
9154 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9157 linestr = shared->ls_linestr;
9158 bufend = SvEND(linestr);
9160 while (s < bufend - len + 1 &&
9161 memNE(s,PL_tokenbuf,len) ) {
9163 ++PL_parser->herelines;
9165 if (s >= bufend - len + 1) {
9168 sv_setpvn(tmpstr,d+1,s-d);
9170 /* the preceding stmt passes a newline */
9171 PL_parser->herelines++;
9173 /* s now points to the newline after the heredoc terminator.
9174 d points to the newline before the body of the heredoc.
9177 /* We are going to modify linestr in place here, so set
9178 aside copies of the string if necessary for re-evals or
9180 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9181 check shared->re_eval_str. */
9182 if (shared->re_eval_start || shared->re_eval_str) {
9183 /* Set aside the rest of the regexp */
9184 if (!shared->re_eval_str)
9185 shared->re_eval_str =
9186 newSVpvn(shared->re_eval_start,
9187 bufend - shared->re_eval_start);
9188 shared->re_eval_start -= s-d;
9190 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
9191 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
9192 cx->blk_eval.cur_text == linestr)
9194 cx->blk_eval.cur_text = newSVsv(linestr);
9195 SvSCREAM_on(cx->blk_eval.cur_text);
9197 /* Copy everything from s onwards back to d. */
9198 Move(s,d,bufend-s + 1,char);
9199 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9200 /* Setting PL_bufend only applies when we have not dug deeper
9201 into other scopes, because sublex_done sets PL_bufend to
9202 SvEND(PL_linestr). */
9203 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9210 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9211 term = PL_tokenbuf[1];
9213 linestr_save = PL_linestr; /* must restore this afterwards */
9214 d = s; /* and this */
9215 PL_linestr = newSVpvs("");
9216 PL_bufend = SvPVX(PL_linestr);
9218 PL_bufptr = PL_bufend;
9219 CopLINE_set(PL_curcop,
9220 origline + 1 + PL_parser->herelines);
9221 if (!lex_next_chunk(LEX_NO_TERM)
9222 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9223 SvREFCNT_dec(linestr_save);
9226 CopLINE_set(PL_curcop, origline);
9227 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9228 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
9229 /* ^That should be enough to avoid this needing to grow: */
9230 sv_catpvs(PL_linestr, "\n\0");
9231 assert(s == SvPVX(PL_linestr));
9232 PL_bufend = SvEND(PL_linestr);
9235 PL_parser->herelines++;
9236 PL_last_lop = PL_last_uni = NULL;
9237 #ifndef PERL_STRICT_CR
9238 if (PL_bufend - PL_linestart >= 2) {
9239 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9240 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9242 PL_bufend[-2] = '\n';
9244 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9246 else if (PL_bufend[-1] == '\r')
9247 PL_bufend[-1] = '\n';
9249 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9250 PL_bufend[-1] = '\n';
9252 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
9253 SvREFCNT_dec(PL_linestr);
9254 PL_linestr = linestr_save;
9255 PL_linestart = SvPVX(linestr_save);
9256 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9261 sv_catsv(tmpstr,PL_linestr);
9265 PL_multi_end = origline + PL_parser->herelines;
9266 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9267 SvPV_shrink_to_cur(tmpstr);
9270 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9272 else if (PL_encoding)
9273 sv_recode_to_utf8(tmpstr, PL_encoding);
9275 PL_lex_stuff = tmpstr;
9276 pl_yylval.ival = op_type;
9280 SvREFCNT_dec(tmpstr);
9281 CopLINE_set(PL_curcop, origline);
9282 missingterm(PL_tokenbuf + 1);
9286 takes: current position in input buffer
9287 returns: new position in input buffer
9288 side-effects: pl_yylval and lex_op are set.
9293 <FH> read from filehandle
9294 <pkg::FH> read from package qualified filehandle
9295 <pkg'FH> read from package qualified filehandle
9296 <$fh> read from filehandle in $fh
9302 S_scan_inputsymbol(pTHX_ char *start)
9305 char *s = start; /* current position in buffer */
9308 char *d = PL_tokenbuf; /* start of temp holding space */
9309 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9311 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9313 end = strchr(s, '\n');
9316 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9318 /* die if we didn't have space for the contents of the <>,
9319 or if it didn't end, or if we see a newline
9322 if (len >= (I32)sizeof PL_tokenbuf)
9323 Perl_croak(aTHX_ "Excessively long <> operator");
9325 Perl_croak(aTHX_ "Unterminated <> operator");
9330 Remember, only scalar variables are interpreted as filehandles by
9331 this code. Anything more complex (e.g., <$fh{$num}>) will be
9332 treated as a glob() call.
9333 This code makes use of the fact that except for the $ at the front,
9334 a scalar variable and a filehandle look the same.
9336 if (*d == '$' && d[1]) d++;
9338 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9339 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9340 d += UTF ? UTF8SKIP(d) : 1;
9342 /* If we've tried to read what we allow filehandles to look like, and
9343 there's still text left, then it must be a glob() and not a getline.
9344 Use scan_str to pull out the stuff between the <> and treat it
9345 as nothing more than a string.
9348 if (d - PL_tokenbuf != len) {
9349 pl_yylval.ival = OP_GLOB;
9350 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
9352 Perl_croak(aTHX_ "Glob not terminated");
9356 bool readline_overriden = FALSE;
9358 /* we're in a filehandle read situation */
9361 /* turn <> into <ARGV> */
9363 Copy("ARGV",d,5,char);
9365 /* Check whether readline() is overriden */
9366 if ((gv_readline = gv_override("readline",8)))
9367 readline_overriden = TRUE;
9369 /* if <$fh>, create the ops to turn the variable into a
9373 /* try to find it in the pad for this block, otherwise find
9374 add symbol table ops
9376 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9377 if (tmp != NOT_IN_PAD) {
9378 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9379 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9380 HEK * const stashname = HvNAME_HEK(stash);
9381 SV * const sym = sv_2mortal(newSVhek(stashname));
9382 sv_catpvs(sym, "::");
9388 OP * const o = newOP(OP_PADSV, 0);
9390 PL_lex_op = readline_overriden
9391 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9392 op_append_elem(OP_LIST, o,
9393 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9394 : (OP*)newUNOP(OP_READLINE, 0, o);
9403 ? (GV_ADDMULTI | GV_ADDINEVAL)
9404 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
9406 PL_lex_op = readline_overriden
9407 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9408 op_append_elem(OP_LIST,
9409 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9410 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9411 : (OP*)newUNOP(OP_READLINE, 0,
9412 newUNOP(OP_RV2SV, 0,
9413 newGVOP(OP_GV, 0, gv)));
9415 if (!readline_overriden)
9416 PL_lex_op->op_flags |= OPf_SPECIAL;
9417 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9418 pl_yylval.ival = OP_NULL;
9421 /* If it's none of the above, it must be a literal filehandle
9422 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9424 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9425 PL_lex_op = readline_overriden
9426 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9427 op_append_elem(OP_LIST,
9428 newGVOP(OP_GV, 0, gv),
9429 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9430 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9431 pl_yylval.ival = OP_NULL;
9441 start position in buffer
9442 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
9443 only if they are of the open/close form
9444 keep_delims preserve the delimiters around the string
9445 re_reparse compiling a run-time /(?{})/:
9446 collapse // to /, and skip encoding src
9447 delimp if non-null, this is set to the position of
9448 the closing delimiter, or just after it if
9449 the closing and opening delimiters differ
9450 (i.e., the opening delimiter of a substitu-
9452 returns: position to continue reading from buffer
9453 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9454 updates the read buffer.
9456 This subroutine pulls a string out of the input. It is called for:
9457 q single quotes q(literal text)
9458 ' single quotes 'literal text'
9459 qq double quotes qq(interpolate $here please)
9460 " double quotes "interpolate $here please"
9461 qx backticks qx(/bin/ls -l)
9462 ` backticks `/bin/ls -l`
9463 qw quote words @EXPORT_OK = qw( func() $spam )
9464 m// regexp match m/this/
9465 s/// regexp substitute s/this/that/
9466 tr/// string transliterate tr/this/that/
9467 y/// string transliterate y/this/that/
9468 ($*@) sub prototypes sub foo ($)
9469 (stuff) sub attr parameters sub foo : attr(stuff)
9470 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9472 In most of these cases (all but <>, patterns and transliterate)
9473 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9474 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9475 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9478 It skips whitespace before the string starts, and treats the first
9479 character as the delimiter. If the delimiter is one of ([{< then
9480 the corresponding "close" character )]}> is used as the closing
9481 delimiter. It allows quoting of delimiters, and if the string has
9482 balanced delimiters ([{<>}]) it allows nesting.
9484 On success, the SV with the resulting string is put into lex_stuff or,
9485 if that is already non-NULL, into lex_repl. The second case occurs only
9486 when parsing the RHS of the special constructs s/// and tr/// (y///).
9487 For convenience, the terminating delimiter character is stuffed into
9492 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
9497 SV *sv; /* scalar value: string */
9498 const char *tmps; /* temp string, used for delimiter matching */
9499 char *s = start; /* current position in the buffer */
9500 char term; /* terminating character */
9501 char *to; /* current position in the sv's data */
9502 I32 brackets = 1; /* bracket nesting level */
9503 bool has_utf8 = FALSE; /* is there any utf8 content? */
9504 I32 termcode; /* terminating char. code */
9505 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9506 STRLEN termlen; /* length of terminating string */
9507 int last_off = 0; /* last position for nesting bracket */
9510 PERL_ARGS_ASSERT_SCAN_STR;
9512 /* skip space before the delimiter */
9517 /* mark where we are, in case we need to report errors */
9520 /* after skipping whitespace, the next character is the terminator */
9523 termcode = termstr[0] = term;
9527 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
9528 Copy(s, termstr, termlen, U8);
9529 if (!UTF8_IS_INVARIANT(term))
9533 /* mark where we are */
9534 PL_multi_start = CopLINE(PL_curcop);
9535 PL_multi_open = term;
9536 herelines = PL_parser->herelines;
9538 /* find corresponding closing delimiter */
9539 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9540 termcode = termstr[0] = term = tmps[5];
9542 PL_multi_close = term;
9544 if (PL_multi_open == PL_multi_close) {
9545 keep_bracketed_quoted = FALSE;
9548 /* create a new SV to hold the contents. 79 is the SV's initial length.
9549 What a random number. */
9550 sv = newSV_type(SVt_PVIV);
9552 SvIV_set(sv, termcode);
9553 (void)SvPOK_only(sv); /* validate pointer */
9555 /* move past delimiter and try to read a complete string */
9557 sv_catpvn(sv, s, termlen);
9560 if (PL_encoding && !UTF && !re_reparse) {
9564 int offset = s - SvPVX_const(PL_linestr);
9565 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9566 &offset, (char*)termstr, termlen);
9570 if (SvIsCOW(PL_linestr)) {
9571 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
9572 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
9573 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
9574 char *buf = SvPVX(PL_linestr);
9575 bufend_pos = PL_parser->bufend - buf;
9576 bufptr_pos = PL_parser->bufptr - buf;
9577 oldbufptr_pos = PL_parser->oldbufptr - buf;
9578 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
9579 linestart_pos = PL_parser->linestart - buf;
9580 last_uni_pos = PL_parser->last_uni
9581 ? PL_parser->last_uni - buf
9583 last_lop_pos = PL_parser->last_lop
9584 ? PL_parser->last_lop - buf
9587 PL_parser->lex_shared->re_eval_start ?
9588 PL_parser->lex_shared->re_eval_start - buf : 0;
9591 sv_force_normal(PL_linestr);
9593 buf = SvPVX(PL_linestr);
9594 PL_parser->bufend = buf + bufend_pos;
9595 PL_parser->bufptr = buf + bufptr_pos;
9596 PL_parser->oldbufptr = buf + oldbufptr_pos;
9597 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
9598 PL_parser->linestart = buf + linestart_pos;
9599 if (PL_parser->last_uni)
9600 PL_parser->last_uni = buf + last_uni_pos;
9601 if (PL_parser->last_lop)
9602 PL_parser->last_lop = buf + last_lop_pos;
9603 if (PL_parser->lex_shared->re_eval_start)
9604 PL_parser->lex_shared->re_eval_start =
9605 buf + re_eval_start_pos;
9608 ns = SvPVX_const(PL_linestr) + offset;
9609 svlast = SvEND(sv) - 1;
9611 for (; s < ns; s++) {
9612 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9613 COPLINE_INC_WITH_HERELINES;
9616 goto read_more_line;
9618 /* handle quoted delimiters */
9619 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9621 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9623 if ((svlast-1 - t) % 2) {
9624 if (!keep_bracketed_quoted) {
9627 SvCUR_set(sv, SvCUR(sv) - 1);
9632 if (PL_multi_open == PL_multi_close) {
9638 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9639 /* At here, all closes are "was quoted" one,
9640 so we don't check PL_multi_close. */
9642 if (!keep_bracketed_quoted && *(t+1) == PL_multi_open)
9647 else if (*t == PL_multi_open)
9655 SvCUR_set(sv, w - SvPVX_const(sv));
9657 last_off = w - SvPVX(sv);
9658 if (--brackets <= 0)
9664 SvCUR_set(sv, SvCUR(sv) - 1);
9670 /* extend sv if need be */
9671 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9672 /* set 'to' to the next character in the sv's string */
9673 to = SvPVX(sv)+SvCUR(sv);
9675 /* if open delimiter is the close delimiter read unbridle */
9676 if (PL_multi_open == PL_multi_close) {
9677 for (; s < PL_bufend; s++,to++) {
9678 /* embedded newlines increment the current line number */
9679 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9680 COPLINE_INC_WITH_HERELINES;
9681 /* handle quoted delimiters */
9682 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9683 if (!keep_bracketed_quoted
9685 || (re_reparse && s[1] == '\\'))
9688 else /* any other quotes are simply copied straight through */
9691 /* terminate when run out of buffer (the for() condition), or
9692 have found the terminator */
9693 else if (*s == term) {
9696 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9699 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9705 /* if the terminator isn't the same as the start character (e.g.,
9706 matched brackets), we have to allow more in the quoting, and
9707 be prepared for nested brackets.
9710 /* read until we run out of string, or we find the terminator */
9711 for (; s < PL_bufend; s++,to++) {
9712 /* embedded newlines increment the line count */
9713 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9714 COPLINE_INC_WITH_HERELINES;
9715 /* backslashes can escape the open or closing characters */
9716 if (*s == '\\' && s+1 < PL_bufend) {
9717 if (!keep_bracketed_quoted &&
9718 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9725 /* allow nested opens and closes */
9726 else if (*s == PL_multi_close && --brackets <= 0)
9728 else if (*s == PL_multi_open)
9730 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9735 /* terminate the copied string and update the sv's end-of-string */
9737 SvCUR_set(sv, to - SvPVX_const(sv));
9740 * this next chunk reads more into the buffer if we're not done yet
9744 break; /* handle case where we are done yet :-) */
9746 #ifndef PERL_STRICT_CR
9747 if (to - SvPVX_const(sv) >= 2) {
9748 if ((to[-2] == '\r' && to[-1] == '\n') ||
9749 (to[-2] == '\n' && to[-1] == '\r'))
9753 SvCUR_set(sv, to - SvPVX_const(sv));
9755 else if (to[-1] == '\r')
9758 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9763 /* if we're out of file, or a read fails, bail and reset the current
9764 line marker so we can report where the unterminated string began
9766 COPLINE_INC_WITH_HERELINES;
9767 PL_bufptr = PL_bufend;
9768 if (!lex_next_chunk(0)) {
9770 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9776 /* at this point, we have successfully read the delimited string */
9778 if (!PL_encoding || UTF || re_reparse) {
9781 sv_catpvn(sv, s, termlen);
9784 if (has_utf8 || (PL_encoding && !re_reparse))
9787 PL_multi_end = CopLINE(PL_curcop);
9788 CopLINE_set(PL_curcop, PL_multi_start);
9789 PL_parser->herelines = herelines;
9791 /* if we allocated too much space, give some back */
9792 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9793 SvLEN_set(sv, SvCUR(sv) + 1);
9794 SvPV_renew(sv, SvLEN(sv));
9797 /* decide whether this is the first or second quoted string we've read
9802 PL_sublex_info.repl = sv;
9805 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
9811 takes: pointer to position in buffer
9812 returns: pointer to new position in buffer
9813 side-effects: builds ops for the constant in pl_yylval.op
9815 Read a number in any of the formats that Perl accepts:
9817 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9818 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9821 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
9823 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
9826 If it reads a number without a decimal point or an exponent, it will
9827 try converting the number to an integer and see if it can do so
9828 without loss of precision.
9832 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
9835 const char *s = start; /* current position in buffer */
9836 char *d; /* destination in temp buffer */
9837 char *e; /* end of temp buffer */
9838 NV nv; /* number read, as a double */
9839 SV *sv = NULL; /* place to put the converted number */
9840 bool floatit; /* boolean: int or float? */
9841 const char *lastub = NULL; /* position of last underbar */
9842 static const char* const number_too_long = "Number too long";
9844 PERL_ARGS_ASSERT_SCAN_NUM;
9846 /* We use the first character to decide what type of number this is */
9850 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
9852 /* if it starts with a 0, it could be an octal number, a decimal in
9853 0.13 disguise, or a hexadecimal number, or a binary number. */
9857 u holds the "number so far"
9858 shift the power of 2 of the base
9859 (hex == 4, octal == 3, binary == 1)
9860 overflowed was the number more than we can hold?
9862 Shift is used when we add a digit. It also serves as an "are
9863 we in octal/hex/binary?" indicator to disallow hex characters
9869 bool overflowed = FALSE;
9870 bool just_zero = TRUE; /* just plain 0 or binary number? */
9871 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
9872 static const char* const bases[5] =
9873 { "", "binary", "", "octal", "hexadecimal" };
9874 static const char* const Bases[5] =
9875 { "", "Binary", "", "Octal", "Hexadecimal" };
9876 static const char* const maxima[5] =
9878 "0b11111111111111111111111111111111",
9882 const char *base, *Base, *max;
9885 if (s[1] == 'x' || s[1] == 'X') {
9889 } else if (s[1] == 'b' || s[1] == 'B') {
9894 /* check for a decimal in disguise */
9895 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
9897 /* so it must be octal */
9904 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9905 "Misplaced _ in number");
9909 base = bases[shift];
9910 Base = Bases[shift];
9911 max = maxima[shift];
9913 /* read the rest of the number */
9915 /* x is used in the overflow test,
9916 b is the digit we're adding on. */
9921 /* if we don't mention it, we're done */
9925 /* _ are ignored -- but warned about if consecutive */
9927 if (lastub && s == lastub + 1)
9928 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9929 "Misplaced _ in number");
9933 /* 8 and 9 are not octal */
9936 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
9940 case '2': case '3': case '4':
9941 case '5': case '6': case '7':
9943 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
9947 b = *s++ & 15; /* ASCII digit -> value of digit */
9951 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
9952 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
9953 /* make sure they said 0x */
9958 /* Prepare to put the digit we have onto the end
9959 of the number so far. We check for overflows.
9965 x = u << shift; /* make room for the digit */
9967 if ((x >> shift) != u
9968 && !(PL_hints & HINT_NEW_BINARY)) {
9971 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
9972 "Integer overflow in %s number",
9975 u = x | b; /* add the digit to the end */
9978 n *= nvshift[shift];
9979 /* If an NV has not enough bits in its
9980 * mantissa to represent an UV this summing of
9981 * small low-order numbers is a waste of time
9982 * (because the NV cannot preserve the
9983 * low-order bits anyway): we could just
9984 * remember when did we overflow and in the
9985 * end just multiply n by the right
9993 /* if we get here, we had success: make a scalar value from
9998 /* final misplaced underbar check */
10000 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10004 if (n > 4294967295.0)
10005 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10006 "%s number > %s non-portable",
10012 if (u > 0xffffffff)
10013 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10014 "%s number > %s non-portable",
10019 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10020 sv = new_constant(start, s - start, "integer",
10021 sv, NULL, NULL, 0);
10022 else if (PL_hints & HINT_NEW_BINARY)
10023 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10028 handle decimal numbers.
10029 we're also sent here when we read a 0 as the first digit
10031 case '1': case '2': case '3': case '4': case '5':
10032 case '6': case '7': case '8': case '9': case '.':
10035 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10038 /* read next group of digits and _ and copy into d */
10039 while (isDIGIT(*s) || *s == '_') {
10040 /* skip underscores, checking for misplaced ones
10044 if (lastub && s == lastub + 1)
10045 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10046 "Misplaced _ in number");
10050 /* check for end of fixed-length buffer */
10052 Perl_croak(aTHX_ "%s", number_too_long);
10053 /* if we're ok, copy the character */
10058 /* final misplaced underbar check */
10059 if (lastub && s == lastub + 1) {
10060 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10063 /* read a decimal portion if there is one. avoid
10064 3..5 being interpreted as the number 3. followed
10067 if (*s == '.' && s[1] != '.') {
10072 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10073 "Misplaced _ in number");
10077 /* copy, ignoring underbars, until we run out of digits.
10079 for (; isDIGIT(*s) || *s == '_'; s++) {
10080 /* fixed length buffer check */
10082 Perl_croak(aTHX_ "%s", number_too_long);
10084 if (lastub && s == lastub + 1)
10085 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10086 "Misplaced _ in number");
10092 /* fractional part ending in underbar? */
10093 if (s[-1] == '_') {
10094 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10095 "Misplaced _ in number");
10097 if (*s == '.' && isDIGIT(s[1])) {
10098 /* oops, it's really a v-string, but without the "v" */
10104 /* read exponent part, if present */
10105 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10109 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10110 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10112 /* stray preinitial _ */
10114 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10115 "Misplaced _ in number");
10119 /* allow positive or negative exponent */
10120 if (*s == '+' || *s == '-')
10123 /* stray initial _ */
10125 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10126 "Misplaced _ in number");
10130 /* read digits of exponent */
10131 while (isDIGIT(*s) || *s == '_') {
10134 Perl_croak(aTHX_ "%s", number_too_long);
10138 if (((lastub && s == lastub + 1) ||
10139 (!isDIGIT(s[1]) && s[1] != '_')))
10140 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10141 "Misplaced _ in number");
10149 We try to do an integer conversion first if no characters
10150 indicating "float" have been found.
10155 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10157 if (flags == IS_NUMBER_IN_UV) {
10159 sv = newSViv(uv); /* Prefer IVs over UVs. */
10162 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10163 if (uv <= (UV) IV_MIN)
10164 sv = newSViv(-(IV)uv);
10171 STORE_NUMERIC_LOCAL_SET_STANDARD();
10172 /* terminate the string */
10174 nv = Atof(PL_tokenbuf);
10175 RESTORE_NUMERIC_LOCAL();
10180 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10181 const char *const key = floatit ? "float" : "integer";
10182 const STRLEN keylen = floatit ? 5 : 7;
10183 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10184 key, keylen, sv, NULL, NULL, 0);
10188 /* if it starts with a v, it could be a v-string */
10191 sv = newSV(5); /* preallocate storage space */
10192 ENTER_with_name("scan_vstring");
10194 s = scan_vstring(s, PL_bufend, sv);
10195 SvREFCNT_inc_simple_void_NN(sv);
10196 LEAVE_with_name("scan_vstring");
10200 /* make the op for the constant and return */
10203 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10205 lvalp->opval = NULL;
10211 S_scan_formline(pTHX_ char *s)
10216 SV * const stuff = newSVpvs("");
10217 bool needargs = FALSE;
10218 bool eofmt = FALSE;
10220 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10222 while (!needargs) {
10225 #ifdef PERL_STRICT_CR
10226 while (SPACE_OR_TAB(*t))
10229 while (SPACE_OR_TAB(*t) || *t == '\r')
10232 if (*t == '\n' || t == PL_bufend) {
10237 eol = (char *) memchr(s,'\n',PL_bufend-s);
10241 for (t = s; t < eol; t++) {
10242 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10244 goto enough; /* ~~ must be first line in formline */
10246 if (*t == '@' || *t == '^')
10250 sv_catpvn(stuff, s, eol-s);
10251 #ifndef PERL_STRICT_CR
10252 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10253 char *end = SvPVX(stuff) + SvCUR(stuff);
10256 SvCUR_set(stuff, SvCUR(stuff) - 1);
10264 if ((PL_rsfp || PL_parser->filtered)
10265 && PL_parser->form_lex_state == LEX_NORMAL) {
10267 PL_bufptr = PL_bufend;
10268 COPLINE_INC_WITH_HERELINES;
10269 got_some = lex_next_chunk(0);
10270 CopLINE_dec(PL_curcop);
10278 if (!SvCUR(stuff) || needargs)
10279 PL_lex_state = PL_parser->form_lex_state;
10280 if (SvCUR(stuff)) {
10281 PL_expect = XSTATE;
10283 const char *s2 = s;
10284 while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
10288 PL_expect = XTERMBLOCK;
10289 NEXTVAL_NEXTTOKE.ival = 0;
10292 NEXTVAL_NEXTTOKE.ival = 0;
10293 force_next(FORMLBRACK);
10296 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10298 else if (PL_encoding)
10299 sv_recode_to_utf8(stuff, PL_encoding);
10301 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10305 SvREFCNT_dec(stuff);
10307 PL_lex_formbrack = 0;
10313 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10316 const I32 oldsavestack_ix = PL_savestack_ix;
10317 CV* const outsidecv = PL_compcv;
10319 SAVEI32(PL_subline);
10320 save_item(PL_subname);
10321 SAVESPTR(PL_compcv);
10323 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10324 CvFLAGS(PL_compcv) |= flags;
10326 PL_subline = CopLINE(PL_curcop);
10327 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10328 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10329 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10330 if (outsidecv && CvPADLIST(outsidecv))
10331 CvPADLIST(PL_compcv)->xpadl_outid =
10332 PadlistNAMES(CvPADLIST(outsidecv));
10334 return oldsavestack_ix;
10338 S_yywarn(pTHX_ const char *const s, U32 flags)
10342 PERL_ARGS_ASSERT_YYWARN;
10344 PL_in_eval |= EVAL_WARNONLY;
10345 yyerror_pv(s, flags);
10346 PL_in_eval &= ~EVAL_WARNONLY;
10351 Perl_yyerror(pTHX_ const char *const s)
10353 PERL_ARGS_ASSERT_YYERROR;
10354 return yyerror_pvn(s, strlen(s), 0);
10358 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10360 PERL_ARGS_ASSERT_YYERROR_PV;
10361 return yyerror_pvn(s, strlen(s), flags);
10365 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10368 const char *context = NULL;
10371 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10372 int yychar = PL_parser->yychar;
10374 PERL_ARGS_ASSERT_YYERROR_PVN;
10376 if (!yychar || (yychar == ';' && !PL_rsfp))
10377 sv_catpvs(where_sv, "at EOF");
10378 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10379 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10380 PL_oldbufptr != PL_bufptr) {
10383 The code below is removed for NetWare because it abends/crashes on NetWare
10384 when the script has error such as not having the closing quotes like:
10385 if ($var eq "value)
10386 Checking of white spaces is anyway done in NetWare code.
10389 while (isSPACE(*PL_oldoldbufptr))
10392 context = PL_oldoldbufptr;
10393 contlen = PL_bufptr - PL_oldoldbufptr;
10395 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10396 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10399 The code below is removed for NetWare because it abends/crashes on NetWare
10400 when the script has error such as not having the closing quotes like:
10401 if ($var eq "value)
10402 Checking of white spaces is anyway done in NetWare code.
10405 while (isSPACE(*PL_oldbufptr))
10408 context = PL_oldbufptr;
10409 contlen = PL_bufptr - PL_oldbufptr;
10411 else if (yychar > 255)
10412 sv_catpvs(where_sv, "next token ???");
10413 else if (yychar == -2) { /* YYEMPTY */
10414 if (PL_lex_state == LEX_NORMAL ||
10415 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10416 sv_catpvs(where_sv, "at end of line");
10417 else if (PL_lex_inpat)
10418 sv_catpvs(where_sv, "within pattern");
10420 sv_catpvs(where_sv, "within string");
10423 sv_catpvs(where_sv, "next char ");
10425 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10426 else if (isPRINT_LC(yychar)) {
10427 const char string = yychar;
10428 sv_catpvn(where_sv, &string, 1);
10431 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10433 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
10434 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10435 OutCopFILE(PL_curcop),
10436 (IV)(PL_parser->preambling == NOLINE
10437 ? CopLINE(PL_curcop)
10438 : PL_parser->preambling));
10440 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
10441 UTF8fARG(UTF, contlen, context));
10443 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10444 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10445 Perl_sv_catpvf(aTHX_ msg,
10446 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10447 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10450 if (PL_in_eval & EVAL_WARNONLY) {
10451 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10455 if (PL_error_count >= 10) {
10457 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
10458 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10459 SVfARG(errsv), OutCopFILE(PL_curcop));
10461 Perl_croak(aTHX_ "%s has too many errors.\n",
10462 OutCopFILE(PL_curcop));
10465 PL_in_my_stash = NULL;
10470 S_swallow_bom(pTHX_ U8 *s)
10473 const STRLEN slen = SvCUR(PL_linestr);
10475 PERL_ARGS_ASSERT_SWALLOW_BOM;
10479 if (s[1] == 0xFE) {
10480 /* UTF-16 little-endian? (or UTF-32LE?) */
10481 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10482 /* diag_listed_as: Unsupported script encoding %s */
10483 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10484 #ifndef PERL_NO_UTF16_FILTER
10485 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10487 if (PL_bufend > (char*)s) {
10488 s = add_utf16_textfilter(s, TRUE);
10491 /* diag_listed_as: Unsupported script encoding %s */
10492 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10497 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10498 #ifndef PERL_NO_UTF16_FILTER
10499 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10501 if (PL_bufend > (char *)s) {
10502 s = add_utf16_textfilter(s, FALSE);
10505 /* diag_listed_as: Unsupported script encoding %s */
10506 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10510 case BOM_UTF8_FIRST_BYTE: {
10511 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
10512 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
10513 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10514 s += len + 1; /* UTF-8 */
10521 if (s[2] == 0xFE && s[3] == 0xFF) {
10522 /* UTF-32 big-endian */
10523 /* diag_listed_as: Unsupported script encoding %s */
10524 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10527 else if (s[2] == 0 && s[3] != 0) {
10530 * are a good indicator of UTF-16BE. */
10531 #ifndef PERL_NO_UTF16_FILTER
10532 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10533 s = add_utf16_textfilter(s, FALSE);
10535 /* diag_listed_as: Unsupported script encoding %s */
10536 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10543 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10546 * are a good indicator of UTF-16LE. */
10547 #ifndef PERL_NO_UTF16_FILTER
10548 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10549 s = add_utf16_textfilter(s, TRUE);
10551 /* diag_listed_as: Unsupported script encoding %s */
10552 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10560 #ifndef PERL_NO_UTF16_FILTER
10562 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10565 SV *const filter = FILTER_DATA(idx);
10566 /* We re-use this each time round, throwing the contents away before we
10568 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10569 SV *const utf8_buffer = filter;
10570 IV status = IoPAGE(filter);
10571 const bool reverse = cBOOL(IoLINES(filter));
10574 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10576 /* As we're automatically added, at the lowest level, and hence only called
10577 from this file, we can be sure that we're not called in block mode. Hence
10578 don't bother writing code to deal with block mode. */
10580 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10583 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10585 DEBUG_P(PerlIO_printf(Perl_debug_log,
10586 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10587 FPTR2DPTR(void *, S_utf16_textfilter),
10588 reverse ? 'l' : 'b', idx, maxlen, status,
10589 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10596 /* First, look in our buffer of existing UTF-8 data: */
10597 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10601 } else if (status == 0) {
10603 IoPAGE(filter) = 0;
10604 nl = SvEND(utf8_buffer);
10607 STRLEN got = nl - SvPVX(utf8_buffer);
10608 /* Did we have anything to append? */
10610 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10611 /* Everything else in this code works just fine if SVp_POK isn't
10612 set. This, however, needs it, and we need it to work, else
10613 we loop infinitely because the buffer is never consumed. */
10614 sv_chop(utf8_buffer, nl);
10618 /* OK, not a complete line there, so need to read some more UTF-16.
10619 Read an extra octect if the buffer currently has an odd number. */
10623 if (SvCUR(utf16_buffer) >= 2) {
10624 /* Location of the high octet of the last complete code point.
10625 Gosh, UTF-16 is a pain. All the benefits of variable length,
10626 *coupled* with all the benefits of partial reads and
10628 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10629 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10631 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10635 /* We have the first half of a surrogate. Read more. */
10636 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10639 status = FILTER_READ(idx + 1, utf16_buffer,
10640 160 + (SvCUR(utf16_buffer) & 1));
10641 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10642 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10645 IoPAGE(filter) = status;
10650 chars = SvCUR(utf16_buffer) >> 1;
10651 have = SvCUR(utf8_buffer);
10652 SvGROW(utf8_buffer, have + chars * 3 + 1);
10655 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10656 (U8*)SvPVX_const(utf8_buffer) + have,
10657 chars * 2, &newlen);
10659 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10660 (U8*)SvPVX_const(utf8_buffer) + have,
10661 chars * 2, &newlen);
10663 SvCUR_set(utf8_buffer, have + newlen);
10666 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10667 it's private to us, and utf16_to_utf8{,reversed} take a
10668 (pointer,length) pair, rather than a NUL-terminated string. */
10669 if(SvCUR(utf16_buffer) & 1) {
10670 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10671 SvCUR_set(utf16_buffer, 1);
10673 SvCUR_set(utf16_buffer, 0);
10676 DEBUG_P(PerlIO_printf(Perl_debug_log,
10677 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10679 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10680 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10685 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10687 SV *filter = filter_add(S_utf16_textfilter, NULL);
10689 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10691 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10692 sv_setpvs(filter, "");
10693 IoLINES(filter) = reversed;
10694 IoPAGE(filter) = 1; /* Not EOF */
10696 /* Sadly, we have to return a valid pointer, come what may, so we have to
10697 ignore any error return from this. */
10698 SvCUR_set(PL_linestr, 0);
10699 if (FILTER_READ(0, PL_linestr, 0)) {
10700 SvUTF8_on(PL_linestr);
10702 SvUTF8_on(PL_linestr);
10704 PL_bufend = SvEND(PL_linestr);
10705 return (U8*)SvPVX(PL_linestr);
10710 Returns a pointer to the next character after the parsed
10711 vstring, as well as updating the passed in sv.
10713 Function must be called like
10715 sv = sv_2mortal(newSV(5));
10716 s = scan_vstring(s,e,sv);
10718 where s and e are the start and end of the string.
10719 The sv should already be large enough to store the vstring
10720 passed in, for performance reasons.
10722 This function may croak if fatal warnings are enabled in the
10723 calling scope, hence the sv_2mortal in the example (to prevent
10724 a leak). Make sure to do SvREFCNT_inc afterwards if you use
10730 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10733 const char *pos = s;
10734 const char *start = s;
10736 PERL_ARGS_ASSERT_SCAN_VSTRING;
10738 if (*pos == 'v') pos++; /* get past 'v' */
10739 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10741 if ( *pos != '.') {
10742 /* this may not be a v-string if followed by => */
10743 const char *next = pos;
10744 while (next < e && isSPACE(*next))
10746 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10747 /* return string not v-string */
10748 sv_setpvn(sv,(char *)s,pos-s);
10749 return (char *)pos;
10753 if (!isALPHA(*pos)) {
10754 U8 tmpbuf[UTF8_MAXBYTES+1];
10757 s++; /* get past 'v' */
10762 /* this is atoi() that tolerates underscores */
10765 const char *end = pos;
10767 while (--end >= s) {
10769 const UV orev = rev;
10770 rev += (*end - '0') * mult;
10773 /* diag_listed_as: Integer overflow in %s number */
10774 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10775 "Integer overflow in decimal number");
10779 if (rev > 0x7FFFFFFF)
10780 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10782 /* Append native character for the rev point */
10783 tmpend = uvchr_to_utf8(tmpbuf, rev);
10784 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10785 if (!UVCHR_IS_INVARIANT(rev))
10787 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
10793 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10797 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
10804 Perl_keyword_plugin_standard(pTHX_
10805 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
10807 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
10808 PERL_UNUSED_CONTEXT;
10809 PERL_UNUSED_ARG(keyword_ptr);
10810 PERL_UNUSED_ARG(keyword_len);
10811 PERL_UNUSED_ARG(op_ptr);
10812 return KEYWORD_PLUGIN_DECLINE;
10815 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
10817 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
10819 SAVEI32(PL_lex_brackets);
10820 if (PL_lex_brackets > 100)
10821 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
10822 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
10823 SAVEI32(PL_lex_allbrackets);
10824 PL_lex_allbrackets = 0;
10825 SAVEI8(PL_lex_fakeeof);
10826 PL_lex_fakeeof = (U8)fakeeof;
10827 if(yyparse(gramtype) && !PL_parser->error_count)
10828 qerror(Perl_mess(aTHX_ "Parse error"));
10831 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
10833 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
10837 SAVEVPTR(PL_eval_root);
10838 PL_eval_root = NULL;
10839 parse_recdescent(gramtype, fakeeof);
10845 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
10847 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
10850 if (flags & ~PARSE_OPTIONAL)
10851 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
10852 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
10853 if (!exprop && !(flags & PARSE_OPTIONAL)) {
10854 if (!PL_parser->error_count)
10855 qerror(Perl_mess(aTHX_ "Parse error"));
10856 exprop = newOP(OP_NULL, 0);
10862 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
10864 Parse a Perl arithmetic expression. This may contain operators of precedence
10865 down to the bit shift operators. The expression must be followed (and thus
10866 terminated) either by a comparison or lower-precedence operator or by
10867 something that would normally terminate an expression such as semicolon.
10868 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
10869 otherwise it is mandatory. It is up to the caller to ensure that the
10870 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
10871 the source of the code to be parsed and the lexical context for the
10874 The op tree representing the expression is returned. If an optional
10875 expression is absent, a null pointer is returned, otherwise the pointer
10878 If an error occurs in parsing or compilation, in most cases a valid op
10879 tree is returned anyway. The error is reflected in the parser state,
10880 normally resulting in a single exception at the top level of parsing
10881 which covers all the compilation errors that occurred. Some compilation
10882 errors, however, will throw an exception immediately.
10888 Perl_parse_arithexpr(pTHX_ U32 flags)
10890 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
10894 =for apidoc Amx|OP *|parse_termexpr|U32 flags
10896 Parse a Perl term expression. This may contain operators of precedence
10897 down to the assignment operators. The expression must be followed (and thus
10898 terminated) either by a comma or lower-precedence operator or by
10899 something that would normally terminate an expression such as semicolon.
10900 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
10901 otherwise it is mandatory. It is up to the caller to ensure that the
10902 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
10903 the source of the code to be parsed and the lexical context for the
10906 The op tree representing the expression is returned. If an optional
10907 expression is absent, a null pointer is returned, otherwise the pointer
10910 If an error occurs in parsing or compilation, in most cases a valid op
10911 tree is returned anyway. The error is reflected in the parser state,
10912 normally resulting in a single exception at the top level of parsing
10913 which covers all the compilation errors that occurred. Some compilation
10914 errors, however, will throw an exception immediately.
10920 Perl_parse_termexpr(pTHX_ U32 flags)
10922 return parse_expr(LEX_FAKEEOF_COMMA, flags);
10926 =for apidoc Amx|OP *|parse_listexpr|U32 flags
10928 Parse a Perl list expression. This may contain operators of precedence
10929 down to the comma operator. The expression must be followed (and thus
10930 terminated) either by a low-precedence logic operator such as C<or> or by
10931 something that would normally terminate an expression such as semicolon.
10932 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
10933 otherwise it is mandatory. It is up to the caller to ensure that the
10934 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
10935 the source of the code to be parsed and the lexical context for the
10938 The op tree representing the expression is returned. If an optional
10939 expression is absent, a null pointer is returned, otherwise the pointer
10942 If an error occurs in parsing or compilation, in most cases a valid op
10943 tree is returned anyway. The error is reflected in the parser state,
10944 normally resulting in a single exception at the top level of parsing
10945 which covers all the compilation errors that occurred. Some compilation
10946 errors, however, will throw an exception immediately.
10952 Perl_parse_listexpr(pTHX_ U32 flags)
10954 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
10958 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
10960 Parse a single complete Perl expression. This allows the full
10961 expression grammar, including the lowest-precedence operators such
10962 as C<or>. The expression must be followed (and thus terminated) by a
10963 token that an expression would normally be terminated by: end-of-file,
10964 closing bracketing punctuation, semicolon, or one of the keywords that
10965 signals a postfix expression-statement modifier. If I<flags> includes
10966 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
10967 mandatory. It is up to the caller to ensure that the dynamic parser
10968 state (L</PL_parser> et al) is correctly set to reflect the source of
10969 the code to be parsed and the lexical context for the expression.
10971 The op tree representing the expression is returned. If an optional
10972 expression is absent, a null pointer is returned, otherwise the pointer
10975 If an error occurs in parsing or compilation, in most cases a valid op
10976 tree is returned anyway. The error is reflected in the parser state,
10977 normally resulting in a single exception at the top level of parsing
10978 which covers all the compilation errors that occurred. Some compilation
10979 errors, however, will throw an exception immediately.
10985 Perl_parse_fullexpr(pTHX_ U32 flags)
10987 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
10991 =for apidoc Amx|OP *|parse_block|U32 flags
10993 Parse a single complete Perl code block. This consists of an opening
10994 brace, a sequence of statements, and a closing brace. The block
10995 constitutes a lexical scope, so C<my> variables and various compile-time
10996 effects can be contained within it. It is up to the caller to ensure
10997 that the dynamic parser state (L</PL_parser> et al) is correctly set to
10998 reflect the source of the code to be parsed and the lexical context for
11001 The op tree representing the code block is returned. This is always a
11002 real op, never a null pointer. It will normally be a C<lineseq> list,
11003 including C<nextstate> or equivalent ops. No ops to construct any kind
11004 of runtime scope are included by virtue of it being a block.
11006 If an error occurs in parsing or compilation, in most cases a valid op
11007 tree (most likely null) is returned anyway. The error is reflected in
11008 the parser state, normally resulting in a single exception at the top
11009 level of parsing which covers all the compilation errors that occurred.
11010 Some compilation errors, however, will throw an exception immediately.
11012 The I<flags> parameter is reserved for future use, and must always
11019 Perl_parse_block(pTHX_ U32 flags)
11022 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11023 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11027 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11029 Parse a single unadorned Perl statement. This may be a normal imperative
11030 statement or a declaration that has compile-time effect. It does not
11031 include any label or other affixture. It is up to the caller to ensure
11032 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11033 reflect the source of the code to be parsed and the lexical context for
11036 The op tree representing the statement is returned. This may be a
11037 null pointer if the statement is null, for example if it was actually
11038 a subroutine definition (which has compile-time side effects). If not
11039 null, it will be ops directly implementing the statement, suitable to
11040 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11041 equivalent op (except for those embedded in a scope contained entirely
11042 within the statement).
11044 If an error occurs in parsing or compilation, in most cases a valid op
11045 tree (most likely null) is returned anyway. The error is reflected in
11046 the parser state, normally resulting in a single exception at the top
11047 level of parsing which covers all the compilation errors that occurred.
11048 Some compilation errors, however, will throw an exception immediately.
11050 The I<flags> parameter is reserved for future use, and must always
11057 Perl_parse_barestmt(pTHX_ U32 flags)
11060 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11061 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11065 =for apidoc Amx|SV *|parse_label|U32 flags
11067 Parse a single label, possibly optional, of the type that may prefix a
11068 Perl statement. It is up to the caller to ensure that the dynamic parser
11069 state (L</PL_parser> et al) is correctly set to reflect the source of
11070 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11071 label is optional, otherwise it is mandatory.
11073 The name of the label is returned in the form of a fresh scalar. If an
11074 optional label is absent, a null pointer is returned.
11076 If an error occurs in parsing, which can only occur if the label is
11077 mandatory, a valid label is returned anyway. The error is reflected in
11078 the parser state, normally resulting in a single exception at the top
11079 level of parsing which covers all the compilation errors that occurred.
11085 Perl_parse_label(pTHX_ U32 flags)
11087 if (flags & ~PARSE_OPTIONAL)
11088 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11089 if (PL_lex_state == LEX_KNOWNEXT) {
11090 PL_parser->yychar = yylex();
11091 if (PL_parser->yychar == LABEL) {
11092 char * const lpv = pl_yylval.pval;
11093 STRLEN llen = strlen(lpv);
11094 PL_parser->yychar = YYEMPTY;
11095 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
11102 STRLEN wlen, bufptr_pos;
11105 if (!isIDFIRST_lazy_if(s, UTF))
11107 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11108 if (word_takes_any_delimeter(s, wlen))
11110 bufptr_pos = s - SvPVX(PL_linestr);
11112 lex_read_space(LEX_KEEP_PREVIOUS);
11114 s = SvPVX(PL_linestr) + bufptr_pos;
11115 if (t[0] == ':' && t[1] != ':') {
11116 PL_oldoldbufptr = PL_oldbufptr;
11119 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11123 if (flags & PARSE_OPTIONAL) {
11126 qerror(Perl_mess(aTHX_ "Parse error"));
11127 return newSVpvs("x");
11134 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11136 Parse a single complete Perl statement. This may be a normal imperative
11137 statement or a declaration that has compile-time effect, and may include
11138 optional labels. It is up to the caller to ensure that the dynamic
11139 parser state (L</PL_parser> et al) is correctly set to reflect the source
11140 of the code to be parsed and the lexical context for the statement.
11142 The op tree representing the statement is returned. This may be a
11143 null pointer if the statement is null, for example if it was actually
11144 a subroutine definition (which has compile-time side effects). If not
11145 null, it will be the result of a L</newSTATEOP> call, normally including
11146 a C<nextstate> or equivalent op.
11148 If an error occurs in parsing or compilation, in most cases a valid op
11149 tree (most likely null) is returned anyway. The error is reflected in
11150 the parser state, normally resulting in a single exception at the top
11151 level of parsing which covers all the compilation errors that occurred.
11152 Some compilation errors, however, will throw an exception immediately.
11154 The I<flags> parameter is reserved for future use, and must always
11161 Perl_parse_fullstmt(pTHX_ U32 flags)
11164 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11165 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11169 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11171 Parse a sequence of zero or more Perl statements. These may be normal
11172 imperative statements, including optional labels, or declarations
11173 that have compile-time effect, or any mixture thereof. The statement
11174 sequence ends when a closing brace or end-of-file is encountered in a
11175 place where a new statement could have validly started. It is up to
11176 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11177 is correctly set to reflect the source of the code to be parsed and the
11178 lexical context for the statements.
11180 The op tree representing the statement sequence is returned. This may
11181 be a null pointer if the statements were all null, for example if there
11182 were no statements or if there were only subroutine definitions (which
11183 have compile-time side effects). If not null, it will be a C<lineseq>
11184 list, normally including C<nextstate> or equivalent ops.
11186 If an error occurs in parsing or compilation, in most cases a valid op
11187 tree is returned anyway. The error is reflected in the parser state,
11188 normally resulting in a single exception at the top level of parsing
11189 which covers all the compilation errors that occurred. Some compilation
11190 errors, however, will throw an exception immediately.
11192 The I<flags> parameter is reserved for future use, and must always
11199 Perl_parse_stmtseq(pTHX_ U32 flags)
11204 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11205 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11206 c = lex_peek_unichar(0);
11207 if (c != -1 && c != /*{*/'}')
11208 qerror(Perl_mess(aTHX_ "Parse error"));
11212 #define lex_token_boundary() S_lex_token_boundary(aTHX)
11214 S_lex_token_boundary(pTHX)
11216 PL_oldoldbufptr = PL_oldbufptr;
11217 PL_oldbufptr = PL_bufptr;
11220 #define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
11222 S_parse_opt_lexvar(pTHX)
11227 lex_token_boundary();
11228 sigil = lex_read_unichar(0);
11229 if (lex_peek_unichar(0) == '#') {
11230 qerror(Perl_mess(aTHX_ "Parse error"));
11234 c = lex_peek_unichar(0);
11235 if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
11238 d = PL_tokenbuf + 1;
11239 PL_tokenbuf[0] = (char)sigil;
11240 parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
11242 if (d == PL_tokenbuf+1)
11245 var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
11246 OPf_MOD | (OPpLVAL_INTRO<<8));
11247 var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
11252 Perl_parse_subsignature(pTHX)
11255 int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
11256 OP *initops = NULL;
11258 c = lex_peek_unichar(0);
11259 while (c != /*(*/')') {
11263 if (prev_type == 2)
11264 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11265 var = parse_opt_lexvar();
11267 newBINOP(OP_AELEM, 0,
11268 ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
11270 newSVOP(OP_CONST, 0, newSViv(pos))) :
11273 c = lex_peek_unichar(0);
11275 lex_token_boundary();
11276 lex_read_unichar(0);
11278 c = lex_peek_unichar(0);
11279 if (c == ',' || c == /*(*/')') {
11281 qerror(Perl_mess(aTHX_ "Optional parameter "
11282 "lacks default expression"));
11284 OP *defexpr = parse_termexpr(0);
11285 if (defexpr->op_type == OP_UNDEF &&
11286 !(defexpr->op_flags & OPf_KIDS)) {
11291 scalar(newUNOP(OP_RV2AV, 0,
11292 newGVOP(OP_GV, 0, PL_defgv))),
11293 newSVOP(OP_CONST, 0, newSViv(pos+1)));
11295 newCONDOP(0, ifop, expr, defexpr) :
11296 newLOGOP(OP_OR, 0, ifop, defexpr);
11301 if (prev_type == 1)
11302 qerror(Perl_mess(aTHX_ "Mandatory parameter "
11303 "follows optional parameter"));
11305 min_arity = pos + 1;
11307 if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
11309 initops = op_append_list(OP_LINESEQ, initops,
11310 newSTATEOP(0, NULL, expr));
11316 if (prev_type == 2)
11317 qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
11318 var = parse_opt_lexvar();
11320 OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
11321 newBINOP(OP_BIT_AND, 0,
11322 scalar(newUNOP(OP_RV2AV, 0,
11323 newGVOP(OP_GV, 0, PL_defgv))),
11324 newSVOP(OP_CONST, 0, newSViv(1))),
11325 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11326 newSVOP(OP_CONST, 0,
11327 newSVpvs("Odd name/value argument "
11328 "for subroutine"))));
11329 if (pos != min_arity)
11330 chkop = newLOGOP(OP_AND, 0,
11332 scalar(newUNOP(OP_RV2AV, 0,
11333 newGVOP(OP_GV, 0, PL_defgv))),
11334 newSVOP(OP_CONST, 0, newSViv(pos))),
11336 initops = op_append_list(OP_LINESEQ,
11337 newSTATEOP(0, NULL, chkop),
11342 op_prepend_elem(OP_ASLICE,
11343 newOP(OP_PUSHMARK, 0),
11344 newLISTOP(OP_ASLICE, 0,
11346 newSVOP(OP_CONST, 0, newSViv(pos)),
11347 newUNOP(OP_AV2ARYLEN, 0,
11348 ref(newUNOP(OP_RV2AV, 0,
11349 newGVOP(OP_GV, 0, PL_defgv)),
11351 ref(newUNOP(OP_RV2AV, 0,
11352 newGVOP(OP_GV, 0, PL_defgv)),
11354 newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
11355 initops = op_append_list(OP_LINESEQ, initops,
11356 newSTATEOP(0, NULL,
11357 newASSIGNOP(OPf_STACKED, var, 0, slice)));
11364 qerror(Perl_mess(aTHX_ "Parse error"));
11368 c = lex_peek_unichar(0);
11370 case /*(*/')': break;
11373 lex_token_boundary();
11374 lex_read_unichar(0);
11376 c = lex_peek_unichar(0);
11377 } while (c == ',');
11383 if (min_arity != 0) {
11384 initops = op_append_list(OP_LINESEQ,
11385 newSTATEOP(0, NULL,
11388 scalar(newUNOP(OP_RV2AV, 0,
11389 newGVOP(OP_GV, 0, PL_defgv))),
11390 newSVOP(OP_CONST, 0, newSViv(min_arity))),
11391 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11392 newSVOP(OP_CONST, 0,
11393 newSVpvs("Too few arguments for subroutine"))))),
11396 if (max_arity != -1) {
11397 initops = op_append_list(OP_LINESEQ,
11398 newSTATEOP(0, NULL,
11401 scalar(newUNOP(OP_RV2AV, 0,
11402 newGVOP(OP_GV, 0, PL_defgv))),
11403 newSVOP(OP_CONST, 0, newSViv(max_arity))),
11404 newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
11405 newSVOP(OP_CONST, 0,
11406 newSVpvs("Too many arguments for subroutine"))))),
11414 * c-indentation-style: bsd
11415 * c-basic-offset: 4
11416 * indent-tabs-mode: nil
11419 * ex: set ts=8 sts=4 sw=4 et: