3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
42 #include "invlist_inline.h"
44 #define new_constant(a,b,c,d,e,f,g, h) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g, h)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_linestr (PL_parser->linestr)
69 #define PL_expect (PL_parser->expect)
70 #define PL_copline (PL_parser->copline)
71 #define PL_bufptr (PL_parser->bufptr)
72 #define PL_oldbufptr (PL_parser->oldbufptr)
73 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
74 #define PL_linestart (PL_parser->linestart)
75 #define PL_bufend (PL_parser->bufend)
76 #define PL_last_uni (PL_parser->last_uni)
77 #define PL_last_lop (PL_parser->last_lop)
78 #define PL_last_lop_op (PL_parser->last_lop_op)
79 #define PL_lex_state (PL_parser->lex_state)
80 #define PL_rsfp (PL_parser->rsfp)
81 #define PL_rsfp_filters (PL_parser->rsfp_filters)
82 #define PL_in_my (PL_parser->in_my)
83 #define PL_in_my_stash (PL_parser->in_my_stash)
84 #define PL_tokenbuf (PL_parser->tokenbuf)
85 #define PL_multi_end (PL_parser->multi_end)
86 #define PL_error_count (PL_parser->error_count)
88 # define PL_nexttoke (PL_parser->nexttoke)
89 # define PL_nexttype (PL_parser->nexttype)
90 # define PL_nextval (PL_parser->nextval)
93 #define SvEVALED(sv) \
94 (SvTYPE(sv) >= SVt_PVNV \
95 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
97 static const char* const ident_too_long = "Identifier too long";
99 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
101 #define XENUMMASK 0x3f
102 #define XFAKEEOF 0x40
103 #define XFAKEBRACK 0x80
105 #ifdef USE_UTF8_SCRIPTS
106 # define UTF cBOOL(!IN_BYTES)
108 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
111 /* The maximum number of characters preceding the unrecognized one to display */
112 #define UNRECOGNIZED_PRECEDE_COUNT 10
114 /* In variables named $^X, these are the legal values for X.
115 * 1999-02-27 mjd-perl-patch@plover.com */
116 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
118 #define SPACE_OR_TAB(c) isBLANK_A(c)
120 #define HEXFP_PEEK(s) \
122 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
123 isALPHA_FOLD_EQ(s[0], 'p'))
125 /* LEX_* are values for PL_lex_state, the state of the lexer.
126 * They are arranged oddly so that the guard on the switch statement
127 * can get by with a single comparison (if the compiler is smart enough).
129 * These values refer to the various states within a sublex parse,
130 * i.e. within a double quotish string
133 /* #define LEX_NOTPARSING 11 is done in perl.h. */
135 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
136 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
137 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
138 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
139 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
141 /* at end of code, eg "$x" followed by: */
142 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
143 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
145 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
146 string or after \E, $foo, etc */
147 #define LEX_INTERPCONST 2 /* NOT USED */
148 #define LEX_FORMLINE 1 /* expecting a format line */
152 static const char* const lex_state_names[] = {
167 #include "keywords.h"
169 /* CLINE is a macro that ensures PL_copline has a sane value */
171 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
174 * Convenience functions to return different tokens and prime the
175 * lexer for the next token. They all take an argument.
177 * TOKEN : generic token (used for '(', DOLSHARP, etc)
178 * OPERATOR : generic operator
179 * AOPERATOR : assignment operator
180 * PREBLOCK : beginning the block after an if, while, foreach, ...
181 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
182 * PREREF : *EXPR where EXPR is not a simple identifier
183 * TERM : expression term
184 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
185 * LOOPX : loop exiting command (goto, last, dump, etc)
186 * FTST : file test operator
187 * FUN0 : zero-argument function
188 * FUN0OP : zero-argument function, with its op created in this file
189 * FUN1 : not used, except for not, which isn't a UNIOP
190 * BOop : bitwise or or xor
192 * BCop : bitwise complement
193 * SHop : shift operator
194 * PWop : power operator
195 * PMop : pattern-matching operator
196 * Aop : addition-level operator
197 * AopNOASSIGN : addition-level operator that is never part of .=
198 * Mop : multiplication-level operator
199 * Eop : equality-testing operator
200 * Rop : relational operator <= != gt
202 * Also see LOP and lop() below.
205 #ifdef DEBUGGING /* Serve -DT. */
206 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
208 # define REPORT(retval) (retval)
211 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
212 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
213 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
214 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
216 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
217 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
218 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
219 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
221 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
223 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
224 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
225 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
226 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
227 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
228 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
229 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
231 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
232 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
233 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
234 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
235 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
236 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
237 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
238 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
240 /* This bit of chicanery makes a unary function followed by
241 * a parenthesis into a function with one argument, highest precedence.
242 * The UNIDOR macro is for unary functions that can be followed by the //
243 * operator (such as C<shift // 0>).
245 #define UNI3(f,x,have_x) { \
246 pl_yylval.ival = f; \
247 if (have_x) PL_expect = x; \
249 PL_last_uni = PL_oldbufptr; \
250 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
252 return REPORT( (int)FUNC1 ); \
254 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
256 #define UNI(f) UNI3(f,XTERM,1)
257 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
258 #define UNIPROTO(f,optional) { \
259 if (optional) PL_last_uni = PL_oldbufptr; \
263 #define UNIBRACK(f) UNI3(f,0,0)
265 /* grandfather return to old style */
268 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
269 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
270 pl_yylval.ival = (f); \
276 #define COPLINE_INC_WITH_HERELINES \
278 CopLINE_inc(PL_curcop); \
279 if (PL_parser->herelines) \
280 CopLINE(PL_curcop) += PL_parser->herelines, \
281 PL_parser->herelines = 0; \
283 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
284 * is no sublex_push to follow. */
285 #define COPLINE_SET_FROM_MULTI_END \
287 CopLINE_set(PL_curcop, PL_multi_end); \
288 if (PL_multi_end != PL_multi_start) \
289 PL_parser->herelines = 0; \
295 /* how to interpret the pl_yylval associated with the token */
299 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
304 static struct debug_tokens {
306 enum token_type type;
308 } const debug_tokens[] =
310 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
311 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
312 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
313 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
314 { ANON_SIGSUB, TOKENTYPE_IVAL, "ANON_SIGSUB" },
315 { ARROW, TOKENTYPE_NONE, "ARROW" },
316 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
317 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
318 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
319 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
320 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
321 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
322 { DO, TOKENTYPE_NONE, "DO" },
323 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
324 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
325 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
326 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
327 { ELSE, TOKENTYPE_NONE, "ELSE" },
328 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
329 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
330 { FOR, TOKENTYPE_IVAL, "FOR" },
331 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
332 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
333 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
334 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
335 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
336 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
337 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
338 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
339 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
340 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
341 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
342 { IF, TOKENTYPE_IVAL, "IF" },
343 { LABEL, TOKENTYPE_OPVAL, "LABEL" },
344 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
345 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
346 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
347 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
348 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
349 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
350 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
351 { MY, TOKENTYPE_IVAL, "MY" },
352 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
353 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
354 { OROP, TOKENTYPE_IVAL, "OROP" },
355 { OROR, TOKENTYPE_NONE, "OROR" },
356 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
357 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
358 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
359 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
360 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
361 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
362 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
363 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
364 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
365 { PREINC, TOKENTYPE_NONE, "PREINC" },
366 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
367 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
368 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
369 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
370 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
371 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
372 { SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
373 { SUB, TOKENTYPE_NONE, "SUB" },
374 { THING, TOKENTYPE_OPVAL, "THING" },
375 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
376 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
377 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
378 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
379 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
380 { USE, TOKENTYPE_IVAL, "USE" },
381 { WHEN, TOKENTYPE_IVAL, "WHEN" },
382 { WHILE, TOKENTYPE_IVAL, "WHILE" },
383 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
384 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
385 { 0, TOKENTYPE_NONE, NULL }
388 /* dump the returned token in rv, plus any optional arg in pl_yylval */
391 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
393 PERL_ARGS_ASSERT_TOKEREPORT;
396 const char *name = NULL;
397 enum token_type type = TOKENTYPE_NONE;
398 const struct debug_tokens *p;
399 SV* const report = newSVpvs("<== ");
401 for (p = debug_tokens; p->token; p++) {
402 if (p->token == (int)rv) {
409 Perl_sv_catpv(aTHX_ report, name);
410 else if (isGRAPH(rv))
412 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
414 sv_catpvs(report, " (pending identifier)");
417 sv_catpvs(report, "EOF");
419 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
424 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
426 case TOKENTYPE_OPNUM:
427 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
428 PL_op_name[lvalp->ival]);
431 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
433 case TOKENTYPE_OPVAL:
435 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
436 PL_op_name[lvalp->opval->op_type]);
437 if (lvalp->opval->op_type == OP_CONST) {
438 Perl_sv_catpvf(aTHX_ report, " %s",
439 SvPEEK(cSVOPx_sv(lvalp->opval)));
444 sv_catpvs(report, "(opval=null)");
447 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
453 /* print the buffer with suitable escapes */
456 S_printbuf(pTHX_ const char *const fmt, const char *const s)
458 SV* const tmp = newSVpvs("");
460 PERL_ARGS_ASSERT_PRINTBUF;
462 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
463 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
464 GCC_DIAG_RESTORE_STMT;
473 * This subroutine looks for an '=' next to the operator that has just been
474 * parsed and turns it into an ASSIGNOP if it finds one.
478 S_ao(pTHX_ int toketype)
480 if (*PL_bufptr == '=') {
482 if (toketype == ANDAND)
483 pl_yylval.ival = OP_ANDASSIGN;
484 else if (toketype == OROR)
485 pl_yylval.ival = OP_ORASSIGN;
486 else if (toketype == DORDOR)
487 pl_yylval.ival = OP_DORASSIGN;
490 return REPORT(toketype);
495 * When Perl expects an operator and finds something else, no_op
496 * prints the warning. It always prints "<something> found where
497 * operator expected. It prints "Missing semicolon on previous line?"
498 * if the surprise occurs at the start of the line. "do you need to
499 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
500 * where the compiler doesn't know if foo is a method call or a function.
501 * It prints "Missing operator before end of line" if there's nothing
502 * after the missing operator, or "... before <...>" if there is something
503 * after the missing operator.
505 * PL_bufptr is expected to point to the start of the thing that was found,
506 * and s after the next token or partial token.
510 S_no_op(pTHX_ const char *const what, char *s)
512 char * const oldbp = PL_bufptr;
513 const bool is_first = (PL_oldbufptr == PL_linestart);
515 PERL_ARGS_ASSERT_NO_OP;
521 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
522 if (ckWARN_d(WARN_SYNTAX)) {
524 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
525 "\t(Missing semicolon on previous line?)\n");
526 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
531 for (t = PL_oldoldbufptr;
532 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
533 t += UTF ? UTF8SKIP(t) : 1)
537 if (t < PL_bufptr && isSPACE(*t))
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
539 "\t(Do you need to predeclare %" UTF8f "?)\n",
540 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
544 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
545 "\t(Missing operator before %" UTF8f "?)\n",
546 UTF8fARG(UTF, s - oldbp, oldbp));
554 * Complain about missing quote/regexp/heredoc terminator.
555 * If it's called with NULL then it cauterizes the line buffer.
556 * If we're in a delimited string and the delimiter is a control
557 * character, it's reformatted into a two-char sequence like ^C.
562 S_missingterm(pTHX_ char *s, STRLEN len)
564 char tmpbuf[UTF8_MAXBYTES + 1];
569 char * const nl = (char *) my_memrchr(s, '\n', len);
576 else if (PL_multi_close < 32) {
578 tmpbuf[1] = (char)toCTRL(PL_multi_close);
584 if (LIKELY(PL_multi_close < 256)) {
585 *tmpbuf = (char)PL_multi_close;
590 char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close);
597 q = memchr(s, '"', len) ? '\'' : '"';
598 sv = sv_2mortal(newSVpvn(s, len));
601 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c"
602 " anywhere before EOF", q, SVfARG(sv), q);
608 * Check whether the named feature is enabled.
611 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
613 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
615 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
617 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
619 if (namelen > MAX_FEATURE_LEN)
621 memcpy(&he_name[8], name, namelen);
623 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
624 REFCOUNTED_HE_EXISTS));
628 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
629 * utf16-to-utf8-reversed.
632 #ifdef PERL_CR_FILTER
636 const char *s = SvPVX_const(sv);
637 const char * const e = s + SvCUR(sv);
639 PERL_ARGS_ASSERT_STRIP_RETURN;
641 /* outer loop optimized to do nothing if there are no CR-LFs */
643 if (*s++ == '\r' && *s == '\n') {
644 /* hit a CR-LF, need to copy the rest */
648 if (*s == '\r' && s[1] == '\n')
659 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
662 if (count > 0 && !maxlen)
669 =for apidoc lex_start
671 Creates and initialises a new lexer/parser state object, supplying
672 a context in which to lex and parse from a new source of Perl code.
673 A pointer to the new state object is placed in L</PL_parser>. An entry
674 is made on the save stack so that upon unwinding, the new state object
675 will be destroyed and the former value of L</PL_parser> will be restored.
676 Nothing else need be done to clean up the parsing context.
678 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
679 non-null, provides a string (in SV form) containing code to be parsed.
680 A copy of the string is made, so subsequent modification of C<line>
681 does not affect parsing. C<rsfp>, if non-null, provides an input stream
682 from which code will be read to be parsed. If both are non-null, the
683 code in C<line> comes first and must consist of complete lines of input,
684 and C<rsfp> supplies the remainder of the source.
686 The C<flags> parameter is reserved for future use. Currently it is only
687 used by perl internally, so extensions should always pass zero.
692 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
693 can share filters with the current parser.
694 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
695 caller, hence isn't owned by the parser, so shouldn't be closed on parser
696 destruction. This is used to handle the case of defaulting to reading the
697 script from the standard input because no filename was given on the command
698 line (without getting confused by situation where STDIN has been closed, so
699 the script handle is opened on fd 0) */
702 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
704 const char *s = NULL;
705 yy_parser *parser, *oparser;
707 if (flags && flags & ~LEX_START_FLAGS)
708 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
710 /* create and initialise a parser */
712 Newxz(parser, 1, yy_parser);
713 parser->old_parser = oparser = PL_parser;
716 parser->stack = NULL;
717 parser->stack_max1 = NULL;
720 /* on scope exit, free this parser and restore any outer one */
722 parser->saved_curcop = PL_curcop;
724 /* initialise lexer state */
726 parser->nexttoke = 0;
727 parser->error_count = oparser ? oparser->error_count : 0;
728 parser->copline = parser->preambling = NOLINE;
729 parser->lex_state = LEX_NORMAL;
730 parser->expect = XSTATE;
732 parser->recheck_utf8_validity = TRUE;
733 parser->rsfp_filters =
734 !(flags & LEX_START_SAME_FILTER) || !oparser
736 : MUTABLE_AV(SvREFCNT_inc(
737 oparser->rsfp_filters
738 ? oparser->rsfp_filters
739 : (oparser->rsfp_filters = newAV())
742 Newx(parser->lex_brackstack, 120, char);
743 Newx(parser->lex_casestack, 12, char);
744 *parser->lex_casestack = '\0';
745 Newxz(parser->lex_shared, 1, LEXSHARED);
749 const U8* first_bad_char_loc;
751 s = SvPV_const(line, len);
754 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
756 &first_bad_char_loc)))
758 _force_out_malformed_utf8_message(first_bad_char_loc,
759 (U8 *) s + SvCUR(line),
761 1 /* 1 means die */ );
762 NOT_REACHED; /* NOTREACHED */
765 parser->linestr = flags & LEX_START_COPIED
766 ? SvREFCNT_inc_simple_NN(line)
767 : newSVpvn_flags(s, len, SvUTF8(line));
769 sv_catpvs(parser->linestr, "\n;");
771 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
774 parser->oldoldbufptr =
777 parser->linestart = SvPVX(parser->linestr);
778 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
779 parser->last_lop = parser->last_uni = NULL;
781 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
782 |LEX_DONT_CLOSE_RSFP));
783 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
784 |LEX_DONT_CLOSE_RSFP));
786 parser->in_pod = parser->filtered = 0;
790 /* delete a parser object */
793 Perl_parser_free(pTHX_ const yy_parser *parser)
795 PERL_ARGS_ASSERT_PARSER_FREE;
797 PL_curcop = parser->saved_curcop;
798 SvREFCNT_dec(parser->linestr);
800 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
801 PerlIO_clearerr(parser->rsfp);
802 else if (parser->rsfp && (!parser->old_parser
803 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
804 PerlIO_close(parser->rsfp);
805 SvREFCNT_dec(parser->rsfp_filters);
806 SvREFCNT_dec(parser->lex_stuff);
807 SvREFCNT_dec(parser->lex_sub_repl);
809 Safefree(parser->lex_brackstack);
810 Safefree(parser->lex_casestack);
811 Safefree(parser->lex_shared);
812 PL_parser = parser->old_parser;
817 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
819 I32 nexttoke = parser->nexttoke;
820 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
822 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
823 && parser->nextval[nexttoke].opval
824 && parser->nextval[nexttoke].opval->op_slabbed
825 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
826 op_free(parser->nextval[nexttoke].opval);
827 parser->nextval[nexttoke].opval = NULL;
834 =for apidoc AmxUN|SV *|PL_parser-E<gt>linestr
836 Buffer scalar containing the chunk currently under consideration of the
837 text currently being lexed. This is always a plain string scalar (for
838 which C<SvPOK> is true). It is not intended to be used as a scalar by
839 normal scalar means; instead refer to the buffer directly by the pointer
840 variables described below.
842 The lexer maintains various C<char*> pointers to things in the
843 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
844 reallocated, all of these pointers must be updated. Don't attempt to
845 do this manually, but rather use L</lex_grow_linestr> if you need to
846 reallocate the buffer.
848 The content of the text chunk in the buffer is commonly exactly one
849 complete line of input, up to and including a newline terminator,
850 but there are situations where it is otherwise. The octets of the
851 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
852 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
853 flag on this scalar, which may disagree with it.
855 For direct examination of the buffer, the variable
856 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
857 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
858 of these pointers is usually preferable to examination of the scalar
859 through normal scalar means.
861 =for apidoc AmxUN|char *|PL_parser-E<gt>bufend
863 Direct pointer to the end of the chunk of text currently being lexed, the
864 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
865 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
866 always located at the end of the buffer, and does not count as part of
867 the buffer's contents.
869 =for apidoc AmxUN|char *|PL_parser-E<gt>bufptr
871 Points to the current position of lexing inside the lexer buffer.
872 Characters around this point may be freely examined, within
873 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
874 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
875 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
877 Lexing code (whether in the Perl core or not) moves this pointer past
878 the characters that it consumes. It is also expected to perform some
879 bookkeeping whenever a newline character is consumed. This movement
880 can be more conveniently performed by the function L</lex_read_to>,
881 which handles newlines appropriately.
883 Interpretation of the buffer's octets can be abstracted out by
884 using the slightly higher-level functions L</lex_peek_unichar> and
885 L</lex_read_unichar>.
887 =for apidoc AmxUN|char *|PL_parser-E<gt>linestart
889 Points to the start of the current line inside the lexer buffer.
890 This is useful for indicating at which column an error occurred, and
891 not much else. This must be updated by any lexing code that consumes
892 a newline; the function L</lex_read_to> handles this detail.
898 =for apidoc lex_bufutf8
900 Indicates whether the octets in the lexer buffer
901 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
902 of Unicode characters. If not, they should be interpreted as Latin-1
903 characters. This is analogous to the C<SvUTF8> flag for scalars.
905 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
906 contains valid UTF-8. Lexing code must be robust in the face of invalid
909 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
910 is significant, but not the whole story regarding the input character
911 encoding. Normally, when a file is being read, the scalar contains octets
912 and its C<SvUTF8> flag is off, but the octets should be interpreted as
913 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
914 however, the scalar may have the C<SvUTF8> flag on, and in this case its
915 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
916 is in effect. This logic may change in the future; use this function
917 instead of implementing the logic yourself.
923 Perl_lex_bufutf8(pTHX)
929 =for apidoc lex_grow_linestr
931 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
932 at least C<len> octets (including terminating C<NUL>). Returns a
933 pointer to the reallocated buffer. This is necessary before making
934 any direct modification of the buffer that would increase its length.
935 L</lex_stuff_pvn> provides a more convenient way to insert text into
938 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
939 this function updates all of the lexer's variables that point directly
946 Perl_lex_grow_linestr(pTHX_ STRLEN len)
950 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
951 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
954 linestr = PL_parser->linestr;
955 buf = SvPVX(linestr);
956 if (len <= SvLEN(linestr))
959 /* Is the lex_shared linestr SV the same as the current linestr SV?
960 * Only in this case does re_eval_start need adjusting, since it
961 * points within lex_shared->ls_linestr's buffer */
962 current = ( !PL_parser->lex_shared->ls_linestr
963 || linestr == PL_parser->lex_shared->ls_linestr);
965 bufend_pos = PL_parser->bufend - buf;
966 bufptr_pos = PL_parser->bufptr - buf;
967 oldbufptr_pos = PL_parser->oldbufptr - buf;
968 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
969 linestart_pos = PL_parser->linestart - buf;
970 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
971 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
972 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
973 PL_parser->lex_shared->re_eval_start - buf : 0;
975 buf = sv_grow(linestr, len);
977 PL_parser->bufend = buf + bufend_pos;
978 PL_parser->bufptr = buf + bufptr_pos;
979 PL_parser->oldbufptr = buf + oldbufptr_pos;
980 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
981 PL_parser->linestart = buf + linestart_pos;
982 if (PL_parser->last_uni)
983 PL_parser->last_uni = buf + last_uni_pos;
984 if (PL_parser->last_lop)
985 PL_parser->last_lop = buf + last_lop_pos;
986 if (current && PL_parser->lex_shared->re_eval_start)
987 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
992 =for apidoc lex_stuff_pvn
994 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
995 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
996 reallocating the buffer if necessary. This means that lexing code that
997 runs later will see the characters as if they had appeared in the input.
998 It is not recommended to do this as part of normal parsing, and most
999 uses of this facility run the risk of the inserted characters being
1000 interpreted in an unintended manner.
1002 The string to be inserted is represented by C<len> octets starting
1003 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1004 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1005 The characters are recoded for the lexer buffer, according to how the
1006 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1007 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1008 function is more convenient.
1014 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1018 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1019 if (flags & ~(LEX_STUFF_UTF8))
1020 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1022 if (flags & LEX_STUFF_UTF8) {
1025 STRLEN highhalf = variant_under_utf8_count((U8 *) pv,
1027 const char *p, *e = pv+len;;
1030 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1031 bufptr = PL_parser->bufptr;
1032 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1033 SvCUR_set(PL_parser->linestr,
1034 SvCUR(PL_parser->linestr) + len+highhalf);
1035 PL_parser->bufend += len+highhalf;
1036 for (p = pv; p != e; p++) {
1037 append_utf8_from_native_byte(*p, (U8 **) &bufptr);
1041 if (flags & LEX_STUFF_UTF8) {
1042 STRLEN highhalf = 0;
1043 const char *p, *e = pv+len;
1044 for (p = pv; p != e; p++) {
1046 if (UTF8_IS_ABOVE_LATIN1(c)) {
1047 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1048 "non-Latin-1 character into Latin-1 input");
1049 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1052 } else assert(UTF8_IS_INVARIANT(c));
1056 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1057 bufptr = PL_parser->bufptr;
1058 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1059 SvCUR_set(PL_parser->linestr,
1060 SvCUR(PL_parser->linestr) + len-highhalf);
1061 PL_parser->bufend += len-highhalf;
1064 if (UTF8_IS_INVARIANT(*p)) {
1070 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1076 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1077 bufptr = PL_parser->bufptr;
1078 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1079 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1080 PL_parser->bufend += len;
1081 Copy(pv, bufptr, len, char);
1087 =for apidoc lex_stuff_pv
1089 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1090 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1091 reallocating the buffer if necessary. This means that lexing code that
1092 runs later will see the characters as if they had appeared in the input.
1093 It is not recommended to do this as part of normal parsing, and most
1094 uses of this facility run the risk of the inserted characters being
1095 interpreted in an unintended manner.
1097 The string to be inserted is represented by octets starting at C<pv>
1098 and continuing to the first nul. These octets are interpreted as either
1099 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1100 in C<flags>. The characters are recoded for the lexer buffer, according
1101 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1102 If it is not convenient to nul-terminate a string to be inserted, the
1103 L</lex_stuff_pvn> function is more appropriate.
1109 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1111 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1112 lex_stuff_pvn(pv, strlen(pv), flags);
1116 =for apidoc lex_stuff_sv
1118 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1119 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1120 reallocating the buffer if necessary. This means that lexing code that
1121 runs later will see the characters as if they had appeared in the input.
1122 It is not recommended to do this as part of normal parsing, and most
1123 uses of this facility run the risk of the inserted characters being
1124 interpreted in an unintended manner.
1126 The string to be inserted is the string value of C<sv>. The characters
1127 are recoded for the lexer buffer, according to how the buffer is currently
1128 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1129 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1130 need to construct a scalar.
1136 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1140 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1142 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1144 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1148 =for apidoc lex_unstuff
1150 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1151 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1152 This hides the discarded text from any lexing code that runs later,
1153 as if the text had never appeared.
1155 This is not the normal way to consume lexed text. For that, use
1162 Perl_lex_unstuff(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1167 buf = PL_parser->bufptr;
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1172 bufend = PL_parser->bufend;
1174 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1175 unstuff_len = ptr - buf;
1176 Move(ptr, buf, bufend+1-ptr, char);
1177 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1178 PL_parser->bufend = bufend - unstuff_len;
1182 =for apidoc lex_read_to
1184 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1185 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1186 performing the correct bookkeeping whenever a newline character is passed.
1187 This is the normal way to consume lexed text.
1189 Interpretation of the buffer's octets can be abstracted out by
1190 using the slightly higher-level functions L</lex_peek_unichar> and
1191 L</lex_read_unichar>.
1197 Perl_lex_read_to(pTHX_ char *ptr)
1200 PERL_ARGS_ASSERT_LEX_READ_TO;
1201 s = PL_parser->bufptr;
1202 if (ptr < s || ptr > PL_parser->bufend)
1203 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1204 for (; s != ptr; s++)
1206 COPLINE_INC_WITH_HERELINES;
1207 PL_parser->linestart = s+1;
1209 PL_parser->bufptr = ptr;
1213 =for apidoc lex_discard_to
1215 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1216 up to C<ptr>. The remaining content of the buffer will be moved, and
1217 all pointers into the buffer updated appropriately. C<ptr> must not
1218 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1219 it is not permitted to discard text that has yet to be lexed.
1221 Normally it is not necessarily to do this directly, because it suffices to
1222 use the implicit discarding behaviour of L</lex_next_chunk> and things
1223 based on it. However, if a token stretches across multiple lines,
1224 and the lexing code has kept multiple lines of text in the buffer for
1225 that purpose, then after completion of the token it would be wise to
1226 explicitly discard the now-unneeded earlier lines, to avoid future
1227 multi-line tokens growing the buffer without bound.
1233 Perl_lex_discard_to(pTHX_ char *ptr)
1237 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1238 buf = SvPVX(PL_parser->linestr);
1240 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1243 if (ptr > PL_parser->bufptr)
1244 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1245 discard_len = ptr - buf;
1246 if (PL_parser->oldbufptr < ptr)
1247 PL_parser->oldbufptr = ptr;
1248 if (PL_parser->oldoldbufptr < ptr)
1249 PL_parser->oldoldbufptr = ptr;
1250 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1251 PL_parser->last_uni = NULL;
1252 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1253 PL_parser->last_lop = NULL;
1254 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1255 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1256 PL_parser->bufend -= discard_len;
1257 PL_parser->bufptr -= discard_len;
1258 PL_parser->oldbufptr -= discard_len;
1259 PL_parser->oldoldbufptr -= discard_len;
1260 if (PL_parser->last_uni)
1261 PL_parser->last_uni -= discard_len;
1262 if (PL_parser->last_lop)
1263 PL_parser->last_lop -= discard_len;
1267 Perl_notify_parser_that_changed_to_utf8(pTHX)
1269 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1270 * off to on. At compile time, this has the effect of entering a 'use
1271 * utf8' section. This means that any input was not previously checked for
1272 * UTF-8 (because it was off), but now we do need to check it, or our
1273 * assumptions about the input being sane could be wrong, and we could
1274 * segfault. This routine just sets a flag so that the next time we look
1275 * at the input we do the well-formed UTF-8 check. If we aren't in the
1276 * proper phase, there may not be a parser object, but if there is, setting
1277 * the flag is harmless */
1280 PL_parser->recheck_utf8_validity = TRUE;
1285 =for apidoc lex_next_chunk
1287 Reads in the next chunk of text to be lexed, appending it to
1288 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1289 looked to the end of the current chunk and wants to know more. It is
1290 usual, but not necessary, for lexing to have consumed the entirety of
1291 the current chunk at this time.
1293 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1294 chunk (i.e., the current chunk has been entirely consumed), normally the
1295 current chunk will be discarded at the same time that the new chunk is
1296 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1297 will not be discarded. If the current chunk has not been entirely
1298 consumed, then it will not be discarded regardless of the flag.
1300 Returns true if some new text was added to the buffer, or false if the
1301 buffer has reached the end of the input text.
1306 #define LEX_FAKE_EOF 0x80000000
1307 #define LEX_NO_TERM 0x40000000 /* here-doc */
1310 Perl_lex_next_chunk(pTHX_ U32 flags)
1314 STRLEN old_bufend_pos, new_bufend_pos;
1315 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1316 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1317 bool got_some_for_debugger = 0;
1320 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1321 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1322 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1324 linestr = PL_parser->linestr;
1325 buf = SvPVX(linestr);
1326 if (!(flags & LEX_KEEP_PREVIOUS)
1327 && PL_parser->bufptr == PL_parser->bufend)
1329 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1331 if (PL_parser->last_uni != PL_parser->bufend)
1332 PL_parser->last_uni = NULL;
1333 if (PL_parser->last_lop != PL_parser->bufend)
1334 PL_parser->last_lop = NULL;
1335 last_uni_pos = last_lop_pos = 0;
1337 SvCUR_set(linestr, 0);
1339 old_bufend_pos = PL_parser->bufend - buf;
1340 bufptr_pos = PL_parser->bufptr - buf;
1341 oldbufptr_pos = PL_parser->oldbufptr - buf;
1342 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1343 linestart_pos = PL_parser->linestart - buf;
1344 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1345 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1347 if (flags & LEX_FAKE_EOF) {
1349 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1351 } else if (filter_gets(linestr, old_bufend_pos)) {
1353 got_some_for_debugger = 1;
1354 } else if (flags & LEX_NO_TERM) {
1357 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1360 /* End of real input. Close filehandle (unless it was STDIN),
1361 * then add implicit termination.
1363 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1364 PerlIO_clearerr(PL_parser->rsfp);
1365 else if (PL_parser->rsfp)
1366 (void)PerlIO_close(PL_parser->rsfp);
1367 PL_parser->rsfp = NULL;
1368 PL_parser->in_pod = PL_parser->filtered = 0;
1369 if (!PL_in_eval && PL_minus_p) {
1371 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1372 PL_minus_n = PL_minus_p = 0;
1373 } else if (!PL_in_eval && PL_minus_n) {
1374 sv_catpvs(linestr, /*{*/";}");
1377 sv_catpvs(linestr, ";");
1380 buf = SvPVX(linestr);
1381 new_bufend_pos = SvCUR(linestr);
1382 PL_parser->bufend = buf + new_bufend_pos;
1383 PL_parser->bufptr = buf + bufptr_pos;
1386 const U8* first_bad_char_loc;
1387 if (UNLIKELY(! is_utf8_string_loc(
1388 (U8 *) PL_parser->bufptr,
1389 PL_parser->bufend - PL_parser->bufptr,
1390 &first_bad_char_loc)))
1392 _force_out_malformed_utf8_message(first_bad_char_loc,
1393 (U8 *) PL_parser->bufend,
1395 1 /* 1 means die */ );
1396 NOT_REACHED; /* NOTREACHED */
1400 PL_parser->oldbufptr = buf + oldbufptr_pos;
1401 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1402 PL_parser->linestart = buf + linestart_pos;
1403 if (PL_parser->last_uni)
1404 PL_parser->last_uni = buf + last_uni_pos;
1405 if (PL_parser->last_lop)
1406 PL_parser->last_lop = buf + last_lop_pos;
1407 if (PL_parser->preambling != NOLINE) {
1408 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1409 PL_parser->preambling = NOLINE;
1411 if ( got_some_for_debugger
1412 && PERLDB_LINE_OR_SAVESRC
1413 && PL_curstash != PL_debstash)
1415 /* debugger active and we're not compiling the debugger code,
1416 * so store the line into the debugger's array of lines
1418 update_debugger_info(NULL, buf+old_bufend_pos,
1419 new_bufend_pos-old_bufend_pos);
1425 =for apidoc lex_peek_unichar
1427 Looks ahead one (Unicode) character in the text currently being lexed.
1428 Returns the codepoint (unsigned integer value) of the next character,
1429 or -1 if lexing has reached the end of the input text. To consume the
1430 peeked character, use L</lex_read_unichar>.
1432 If the next character is in (or extends into) the next chunk of input
1433 text, the next chunk will be read in. Normally the current chunk will be
1434 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1435 bit set, then the current chunk will not be discarded.
1437 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1438 is encountered, an exception is generated.
1444 Perl_lex_peek_unichar(pTHX_ U32 flags)
1448 if (flags & ~(LEX_KEEP_PREVIOUS))
1449 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1450 s = PL_parser->bufptr;
1451 bufend = PL_parser->bufend;
1457 if (!lex_next_chunk(flags))
1459 s = PL_parser->bufptr;
1460 bufend = PL_parser->bufend;
1463 if (UTF8_IS_INVARIANT(head))
1465 if (UTF8_IS_START(head)) {
1466 len = UTF8SKIP(&head);
1467 while ((STRLEN)(bufend-s) < len) {
1468 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1470 s = PL_parser->bufptr;
1471 bufend = PL_parser->bufend;
1474 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1475 if (retlen == (STRLEN)-1) {
1476 _force_out_malformed_utf8_message((U8 *) s,
1479 1 /* 1 means die */ );
1480 NOT_REACHED; /* NOTREACHED */
1485 if (!lex_next_chunk(flags))
1487 s = PL_parser->bufptr;
1494 =for apidoc lex_read_unichar
1496 Reads the next (Unicode) character in the text currently being lexed.
1497 Returns the codepoint (unsigned integer value) of the character read,
1498 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1499 if lexing has reached the end of the input text. To non-destructively
1500 examine the next character, use L</lex_peek_unichar> instead.
1502 If the next character is in (or extends into) the next chunk of input
1503 text, the next chunk will be read in. Normally the current chunk will be
1504 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1505 bit set, then the current chunk will not be discarded.
1507 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1508 is encountered, an exception is generated.
1514 Perl_lex_read_unichar(pTHX_ U32 flags)
1517 if (flags & ~(LEX_KEEP_PREVIOUS))
1518 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1519 c = lex_peek_unichar(flags);
1522 COPLINE_INC_WITH_HERELINES;
1524 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1526 ++(PL_parser->bufptr);
1532 =for apidoc lex_read_space
1534 Reads optional spaces, in Perl style, in the text currently being
1535 lexed. The spaces may include ordinary whitespace characters and
1536 Perl-style comments. C<#line> directives are processed if encountered.
1537 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1538 at a non-space character (or the end of the input text).
1540 If spaces extend into the next chunk of input text, the next chunk will
1541 be read in. Normally the current chunk will be discarded at the same
1542 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1543 chunk will not be discarded.
1548 #define LEX_NO_INCLINE 0x40000000
1549 #define LEX_NO_NEXT_CHUNK 0x80000000
1552 Perl_lex_read_space(pTHX_ U32 flags)
1555 const bool can_incline = !(flags & LEX_NO_INCLINE);
1556 bool need_incline = 0;
1557 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1558 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1559 s = PL_parser->bufptr;
1560 bufend = PL_parser->bufend;
1566 } while (!(c == '\n' || (c == 0 && s == bufend)));
1567 } else if (c == '\n') {
1570 PL_parser->linestart = s;
1576 } else if (isSPACE(c)) {
1578 } else if (c == 0 && s == bufend) {
1581 if (flags & LEX_NO_NEXT_CHUNK)
1583 PL_parser->bufptr = s;
1584 l = CopLINE(PL_curcop);
1585 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1586 got_more = lex_next_chunk(flags);
1587 CopLINE_set(PL_curcop, l);
1588 s = PL_parser->bufptr;
1589 bufend = PL_parser->bufend;
1592 if (can_incline && need_incline && PL_parser->rsfp) {
1602 PL_parser->bufptr = s;
1607 =for apidoc validate_proto
1609 This function performs syntax checking on a prototype, C<proto>.
1610 If C<warn> is true, any illegal characters or mismatched brackets
1611 will trigger illegalproto warnings, declaring that they were
1612 detected in the prototype for C<name>.
1614 The return value is C<true> if this is a valid prototype, and
1615 C<false> if it is not, regardless of whether C<warn> was C<true> or
1618 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1625 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1627 STRLEN len, origlen;
1629 bool bad_proto = FALSE;
1630 bool in_brackets = FALSE;
1631 bool after_slash = FALSE;
1632 char greedy_proto = ' ';
1633 bool proto_after_greedy_proto = FALSE;
1634 bool must_be_last = FALSE;
1635 bool underscore = FALSE;
1636 bool bad_proto_after_underscore = FALSE;
1638 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1643 p = SvPV(proto, len);
1645 for (; len--; p++) {
1648 proto_after_greedy_proto = TRUE;
1650 if (!strchr(";@%", *p))
1651 bad_proto_after_underscore = TRUE;
1654 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1661 in_brackets = FALSE;
1662 else if ((*p == '@' || *p == '%')
1666 must_be_last = TRUE;
1675 after_slash = FALSE;
1680 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1683 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1684 origlen, UNI_DISPLAY_ISPRINT)
1685 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1687 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1688 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1689 sv_catpvs(name2, "::");
1690 sv_catsv(name2, (SV *)name);
1694 if (proto_after_greedy_proto)
1695 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1696 "Prototype after '%c' for %" SVf " : %s",
1697 greedy_proto, SVfARG(name), p);
1699 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1700 "Missing ']' in prototype for %" SVf " : %s",
1703 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1704 "Illegal character in prototype for %" SVf " : %s",
1706 if (bad_proto_after_underscore)
1707 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1708 "Illegal character after '_' in prototype for %" SVf " : %s",
1712 return (! (proto_after_greedy_proto || bad_proto) );
1717 * This subroutine has nothing to do with tilting, whether at windmills
1718 * or pinball tables. Its name is short for "increment line". It
1719 * increments the current line number in CopLINE(PL_curcop) and checks
1720 * to see whether the line starts with a comment of the form
1721 * # line 500 "foo.pm"
1722 * If so, it sets the current line number and file to the values in the comment.
1726 S_incline(pTHX_ const char *s, const char *end)
1734 PERL_ARGS_ASSERT_INCLINE;
1738 COPLINE_INC_WITH_HERELINES;
1739 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1740 && s+1 == PL_bufend && *s == ';') {
1741 /* fake newline in string eval */
1742 CopLINE_dec(PL_curcop);
1747 while (SPACE_OR_TAB(*s))
1749 if (memBEGINs(s, (STRLEN) (end - s), "line"))
1750 s += sizeof("line") - 1;
1753 if (SPACE_OR_TAB(*s))
1757 while (SPACE_OR_TAB(*s))
1765 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1767 while (SPACE_OR_TAB(*s))
1769 if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) {
1775 while (*t && !isSPACE(*t))
1779 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1781 if (*e != '\n' && *e != '\0')
1782 return; /* false alarm */
1784 if (!grok_atoUV(n, &uv, &e))
1786 line_num = ((line_t)uv) - 1;
1789 const STRLEN len = t - s;
1791 if (!PL_rsfp && !PL_parser->filtered) {
1792 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1793 * to *{"::_<newfilename"} */
1794 /* However, the long form of evals is only turned on by the
1795 debugger - usually they're "(eval %lu)" */
1796 GV * const cfgv = CopFILEGV(PL_curcop);
1799 STRLEN tmplen2 = len;
1803 if (tmplen2 + 2 <= sizeof smallbuf)
1806 Newx(tmpbuf2, tmplen2 + 2, char);
1811 memcpy(tmpbuf2 + 2, s, tmplen2);
1814 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1816 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1817 /* adjust ${"::_<newfilename"} to store the new file name */
1818 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1819 /* The line number may differ. If that is the case,
1820 alias the saved lines that are in the array.
1821 Otherwise alias the whole array. */
1822 if (CopLINE(PL_curcop) == line_num) {
1823 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1824 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1826 else if (GvAV(cfgv)) {
1827 AV * const av = GvAV(cfgv);
1828 const line_t start = CopLINE(PL_curcop)+1;
1829 SSize_t items = AvFILLp(av) - start;
1831 AV * const av2 = GvAVn(gv2);
1832 SV **svp = AvARRAY(av) + start;
1833 Size_t l = line_num+1;
1834 while (items-- && l < SSize_t_MAX && l == (line_t)l)
1835 av_store(av2, (SSize_t)l++, SvREFCNT_inc(*svp++));
1840 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1843 CopFILE_free(PL_curcop);
1844 CopFILE_setn(PL_curcop, s, len);
1846 CopLINE_set(PL_curcop, line_num);
1850 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1852 AV *av = CopFILEAVx(PL_curcop);
1855 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1857 sv = *av_fetch(av, 0, 1);
1858 SvUPGRADE(sv, SVt_PVMG);
1860 if (!SvPOK(sv)) SvPVCLEAR(sv);
1862 sv_catsv(sv, orig_sv);
1864 sv_catpvn(sv, buf, len);
1869 if (PL_parser->preambling == NOLINE)
1870 av_store(av, CopLINE(PL_curcop), sv);
1876 * Called to gobble the appropriate amount and type of whitespace.
1877 * Skips comments as well.
1878 * Returns the next character after the whitespace that is skipped.
1881 * Same thing, but look ahead without incrementing line numbers or
1882 * adjusting PL_linestart.
1885 #define skipspace(s) skipspace_flags(s, 0)
1886 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1889 Perl_skipspace_flags(pTHX_ char *s, U32 flags)
1891 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1892 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1893 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1896 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1898 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1899 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1900 LEX_NO_NEXT_CHUNK : 0));
1902 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1903 if (PL_linestart > PL_bufptr)
1904 PL_bufptr = PL_linestart;
1912 * Check the unary operators to ensure there's no ambiguity in how they're
1913 * used. An ambiguous piece of code would be:
1915 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1916 * the +5 is its argument.
1924 if (PL_oldoldbufptr != PL_last_uni)
1926 while (isSPACE(*PL_last_uni))
1929 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1930 s += UTF ? UTF8SKIP(s) : 1;
1931 if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s))
1934 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1935 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1936 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1940 * LOP : macro to build a list operator. Its behaviour has been replaced
1941 * with a subroutine, S_lop() for which LOP is just another name.
1944 #define LOP(f,x) return lop(f,x,s)
1948 * Build a list operator (or something that might be one). The rules:
1949 * - if we have a next token, then it's a list operator (no parens) for
1950 * which the next token has already been parsed; e.g.,
1953 * - if the next thing is an opening paren, then it's a function
1954 * - else it's a list operator
1958 S_lop(pTHX_ I32 f, U8 x, char *s)
1960 PERL_ARGS_ASSERT_LOP;
1965 PL_last_lop = PL_oldbufptr;
1966 PL_last_lop_op = (OPCODE)f;
1971 return REPORT(FUNC);
1974 return REPORT(FUNC);
1977 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1978 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1979 return REPORT(LSTOP);
1985 * When the lexer realizes it knows the next token (for instance,
1986 * it is reordering tokens for the parser) then it can call S_force_next
1987 * to know what token to return the next time the lexer is called. Caller
1988 * will need to set PL_nextval[] and possibly PL_expect to ensure
1989 * the lexer handles the token correctly.
1993 S_force_next(pTHX_ I32 type)
1997 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1998 tokereport(type, &NEXTVAL_NEXTTOKE);
2001 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2002 PL_nexttype[PL_nexttoke] = type;
2009 * This subroutine handles postfix deref syntax after the arrow has already
2010 * been emitted. @* $* etc. are emitted as two separate tokens right here.
2011 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2012 * only the first, leaving yylex to find the next.
2016 S_postderef(pTHX_ int const funny, char const next)
2018 assert(funny == DOLSHARP || strchr("$@%&*", funny));
2020 PL_expect = XOPERATOR;
2021 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2022 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2023 PL_lex_state = LEX_INTERPEND;
2025 force_next(POSTJOIN);
2031 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2032 && !PL_lex_brackets)
2034 PL_expect = XOPERATOR;
2043 int yyc = PL_parser->yychar;
2044 if (yyc != YYEMPTY) {
2046 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2047 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2048 PL_lex_allbrackets--;
2050 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2051 } else if (yyc == '('/*)*/) {
2052 PL_lex_allbrackets--;
2057 PL_parser->yychar = YYEMPTY;
2062 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2064 SV * const sv = newSVpvn_utf8(start, len,
2068 && is_utf8_non_invariant_string((const U8*)start, len));
2074 * When the lexer knows the next thing is a word (for instance, it has
2075 * just seen -> and it knows that the next char is a word char, then
2076 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2080 * char *start : buffer position (must be within PL_linestr)
2081 * int token : PL_next* will be this type of bare word
2082 * (e.g., METHOD,BAREWORD)
2083 * int check_keyword : if true, Perl checks to make sure the word isn't
2084 * a keyword (do this if the word is a label, e.g. goto FOO)
2085 * int allow_pack : if true, : characters will also be allowed (require,
2086 * use, etc. do this)
2090 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2095 PERL_ARGS_ASSERT_FORCE_WORD;
2097 start = skipspace(start);
2099 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2100 || (allow_pack && *s == ':' && s[1] == ':') )
2102 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2103 if (check_keyword) {
2104 char *s2 = PL_tokenbuf;
2106 if (allow_pack && memBEGINPs(s2, len, "CORE::")) {
2107 s2 += sizeof("CORE::") - 1;
2108 len2 -= sizeof("CORE::") - 1;
2110 if (keyword(s2, len2, 0))
2113 if (token == METHOD) {
2118 PL_expect = XOPERATOR;
2121 NEXTVAL_NEXTTOKE.opval
2122 = newSVOP(OP_CONST,0,
2123 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2124 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2132 * Called when the lexer wants $foo *foo &foo etc, but the program
2133 * text only contains the "foo" portion. The first argument is a pointer
2134 * to the "foo", and the second argument is the type symbol to prefix.
2135 * Forces the next token to be a "BAREWORD".
2136 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2140 S_force_ident(pTHX_ const char *s, int kind)
2142 PERL_ARGS_ASSERT_FORCE_IDENT;
2145 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2146 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2147 UTF ? SVf_UTF8 : 0));
2148 NEXTVAL_NEXTTOKE.opval = o;
2149 force_next(BAREWORD);
2151 o->op_private = OPpCONST_ENTERED;
2152 /* XXX see note in pp_entereval() for why we forgo typo
2153 warnings if the symbol must be introduced in an eval.
2155 gv_fetchpvn_flags(s, len,
2156 (PL_in_eval ? GV_ADDMULTI
2157 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2158 kind == '$' ? SVt_PV :
2159 kind == '@' ? SVt_PVAV :
2160 kind == '%' ? SVt_PVHV :
2168 S_force_ident_maybe_lex(pTHX_ char pit)
2170 NEXTVAL_NEXTTOKE.ival = pit;
2175 Perl_str_to_version(pTHX_ SV *sv)
2180 const char *start = SvPV_const(sv,len);
2181 const char * const end = start + len;
2182 const bool utf = cBOOL(SvUTF8(sv));
2184 PERL_ARGS_ASSERT_STR_TO_VERSION;
2186 while (start < end) {
2190 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2195 retval += ((NV)n)/nshift;
2204 * Forces the next token to be a version number.
2205 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2206 * and if "guessing" is TRUE, then no new token is created (and the caller
2207 * must use an alternative parsing method).
2211 S_force_version(pTHX_ char *s, int guessing)
2216 PERL_ARGS_ASSERT_FORCE_VERSION;
2224 while (isDIGIT(*d) || *d == '_' || *d == '.')
2226 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2228 s = scan_num(s, &pl_yylval);
2229 version = pl_yylval.opval;
2230 ver = cSVOPx(version)->op_sv;
2231 if (SvPOK(ver) && !SvNIOK(ver)) {
2232 SvUPGRADE(ver, SVt_PVNV);
2233 SvNV_set(ver, str_to_version(ver));
2234 SvNOK_on(ver); /* hint that it is a version */
2237 else if (guessing) {
2242 /* NOTE: The parser sees the package name and the VERSION swapped */
2243 NEXTVAL_NEXTTOKE.opval = version;
2244 force_next(BAREWORD);
2250 * S_force_strict_version
2251 * Forces the next token to be a version number using strict syntax rules.
2255 S_force_strict_version(pTHX_ char *s)
2258 const char *errstr = NULL;
2260 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2262 while (isSPACE(*s)) /* leading whitespace */
2265 if (is_STRICT_VERSION(s,&errstr)) {
2267 s = (char *)scan_version(s, ver, 0);
2268 version = newSVOP(OP_CONST, 0, ver);
2270 else if ((*s != ';' && *s != '{' && *s != '}' )
2271 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2275 yyerror(errstr); /* version required */
2279 /* NOTE: The parser sees the package name and the VERSION swapped */
2280 NEXTVAL_NEXTTOKE.opval = version;
2281 force_next(BAREWORD);
2288 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2289 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2290 * unchanged, and a new SV containing the modified input is returned.
2294 S_tokeq(pTHX_ SV *sv)
2301 PERL_ARGS_ASSERT_TOKEQ;
2305 assert (!SvIsCOW(sv));
2306 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2310 /* This is relying on the SV being "well formed" with a trailing '\0' */
2311 while (s < send && !(*s == '\\' && s[1] == '\\'))
2316 if ( PL_hints & HINT_NEW_STRING ) {
2317 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2318 SVs_TEMP | SvUTF8(sv));
2322 if (s + 1 < send && (s[1] == '\\'))
2323 s++; /* all that, just for this */
2328 SvCUR_set(sv, d - SvPVX_const(sv));
2330 if ( PL_hints & HINT_NEW_STRING )
2331 return new_constant(NULL, 0, "q", sv, pv, "q", 1, NULL);
2336 * Now come three functions related to double-quote context,
2337 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2338 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2339 * interact with PL_lex_state, and create fake ( ... ) argument lists
2340 * to handle functions and concatenation.
2344 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2349 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2351 * Pattern matching will set PL_lex_op to the pattern-matching op to
2352 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2354 * OP_CONST is easy--just make the new op and return.
2356 * Everything else becomes a FUNC.
2358 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2359 * had an OP_CONST. This just sets us up for a
2360 * call to S_sublex_push().
2364 S_sublex_start(pTHX)
2366 const I32 op_type = pl_yylval.ival;
2368 if (op_type == OP_NULL) {
2369 pl_yylval.opval = PL_lex_op;
2373 if (op_type == OP_CONST) {
2374 SV *sv = PL_lex_stuff;
2375 PL_lex_stuff = NULL;
2378 if (SvTYPE(sv) == SVt_PVIV) {
2379 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2381 const char * const p = SvPV_const(sv, len);
2382 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2386 pl_yylval.opval = newSVOP(op_type, 0, sv);
2390 PL_parser->lex_super_state = PL_lex_state;
2391 PL_parser->lex_sub_inwhat = (U16)op_type;
2392 PL_parser->lex_sub_op = PL_lex_op;
2393 PL_parser->sub_no_recover = FALSE;
2394 PL_parser->sub_error_count = PL_error_count;
2395 PL_lex_state = LEX_INTERPPUSH;
2399 pl_yylval.opval = PL_lex_op;
2409 * Create a new scope to save the lexing state. The scope will be
2410 * ended in S_sublex_done. Returns a '(', starting the function arguments
2411 * to the uc, lc, etc. found before.
2412 * Sets PL_lex_state to LEX_INTERPCONCAT.
2419 const bool is_heredoc = PL_multi_close == '<';
2422 PL_lex_state = PL_parser->lex_super_state;
2423 SAVEI8(PL_lex_dojoin);
2424 SAVEI32(PL_lex_brackets);
2425 SAVEI32(PL_lex_allbrackets);
2426 SAVEI32(PL_lex_formbrack);
2427 SAVEI8(PL_lex_fakeeof);
2428 SAVEI32(PL_lex_casemods);
2429 SAVEI32(PL_lex_starts);
2430 SAVEI8(PL_lex_state);
2431 SAVESPTR(PL_lex_repl);
2432 SAVEVPTR(PL_lex_inpat);
2433 SAVEI16(PL_lex_inwhat);
2436 SAVECOPLINE(PL_curcop);
2437 SAVEI32(PL_multi_end);
2438 SAVEI32(PL_parser->herelines);
2439 PL_parser->herelines = 0;
2441 SAVEIV(PL_multi_close);
2442 SAVEPPTR(PL_bufptr);
2443 SAVEPPTR(PL_bufend);
2444 SAVEPPTR(PL_oldbufptr);
2445 SAVEPPTR(PL_oldoldbufptr);
2446 SAVEPPTR(PL_last_lop);
2447 SAVEPPTR(PL_last_uni);
2448 SAVEPPTR(PL_linestart);
2449 SAVESPTR(PL_linestr);
2450 SAVEGENERICPV(PL_lex_brackstack);
2451 SAVEGENERICPV(PL_lex_casestack);
2452 SAVEGENERICPV(PL_parser->lex_shared);
2453 SAVEBOOL(PL_parser->lex_re_reparsing);
2454 SAVEI32(PL_copline);
2456 /* The here-doc parser needs to be able to peek into outer lexing
2457 scopes to find the body of the here-doc. So we put PL_linestr and
2458 PL_bufptr into lex_shared, to ‘share’ those values.
2460 PL_parser->lex_shared->ls_linestr = PL_linestr;
2461 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2463 PL_linestr = PL_lex_stuff;
2464 PL_lex_repl = PL_parser->lex_sub_repl;
2465 PL_lex_stuff = NULL;
2466 PL_parser->lex_sub_repl = NULL;
2468 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2469 set for an inner quote-like operator and then an error causes scope-
2470 popping. We must not have a PL_lex_stuff value left dangling, as
2471 that breaks assumptions elsewhere. See bug #123617. */
2472 SAVEGENERICSV(PL_lex_stuff);
2473 SAVEGENERICSV(PL_parser->lex_sub_repl);
2475 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2476 = SvPVX(PL_linestr);
2477 PL_bufend += SvCUR(PL_linestr);
2478 PL_last_lop = PL_last_uni = NULL;
2479 SAVEFREESV(PL_linestr);
2480 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2482 PL_lex_dojoin = FALSE;
2483 PL_lex_brackets = PL_lex_formbrack = 0;
2484 PL_lex_allbrackets = 0;
2485 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2486 Newx(PL_lex_brackstack, 120, char);
2487 Newx(PL_lex_casestack, 12, char);
2488 PL_lex_casemods = 0;
2489 *PL_lex_casestack = '\0';
2491 PL_lex_state = LEX_INTERPCONCAT;
2493 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2494 PL_copline = NOLINE;
2496 Newxz(shared, 1, LEXSHARED);
2497 shared->ls_prev = PL_parser->lex_shared;
2498 PL_parser->lex_shared = shared;
2500 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2501 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2502 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2503 PL_lex_inpat = PL_parser->lex_sub_op;
2505 PL_lex_inpat = NULL;
2507 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2508 PL_in_eval &= ~EVAL_RE_REPARSING;
2515 * Restores lexer state after a S_sublex_push.
2521 if (!PL_lex_starts++) {
2522 SV * const sv = newSVpvs("");
2523 if (SvUTF8(PL_linestr))
2525 PL_expect = XOPERATOR;
2526 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2530 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2531 PL_lex_state = LEX_INTERPCASEMOD;
2535 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2536 assert(PL_lex_inwhat != OP_TRANSR);
2538 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2539 PL_linestr = PL_lex_repl;
2541 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2542 PL_bufend += SvCUR(PL_linestr);
2543 PL_last_lop = PL_last_uni = NULL;
2544 PL_lex_dojoin = FALSE;
2545 PL_lex_brackets = 0;
2546 PL_lex_allbrackets = 0;
2547 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2548 PL_lex_casemods = 0;
2549 *PL_lex_casestack = '\0';
2551 if (SvEVALED(PL_lex_repl)) {
2552 PL_lex_state = LEX_INTERPNORMAL;
2554 /* we don't clear PL_lex_repl here, so that we can check later
2555 whether this is an evalled subst; that means we rely on the
2556 logic to ensure sublex_done() is called again only via the
2557 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2560 PL_lex_state = LEX_INTERPCONCAT;
2563 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2564 CopLINE(PL_curcop) +=
2565 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2566 + PL_parser->herelines;
2567 PL_parser->herelines = 0;
2572 const line_t l = CopLINE(PL_curcop);
2574 if (PL_parser->sub_error_count != PL_error_count) {
2575 if (PL_parser->sub_no_recover) {
2580 if (PL_multi_close == '<')
2581 PL_parser->herelines += l - PL_multi_end;
2582 PL_bufend = SvPVX(PL_linestr);
2583 PL_bufend += SvCUR(PL_linestr);
2584 PL_expect = XOPERATOR;
2590 S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e)
2592 /* This justs wraps get_and_check_backslash_N_name() to output any error
2593 * message it returns. */
2595 const char * error_msg = NULL;
2598 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME_WRAPPER;
2600 /* charnames doesn't work well if there have been errors found */
2601 if (PL_error_count > 0) {
2605 result = get_and_check_backslash_N_name(s, e, cBOOL(UTF), &error_msg);
2608 yyerror_pv(error_msg, UTF ? SVf_UTF8 : 0);
2615 Perl_get_and_check_backslash_N_name(pTHX_ const char* s,
2616 const char* const e,
2618 const char ** error_msg)
2620 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2621 * interior, hence to the "}". Finds what the name resolves to, returning
2622 * an SV* containing it; NULL if no valid one found.
2624 * 'is_utf8' is TRUE if we know we want the result to be UTF-8 even if it
2625 * doesn't have to be. */
2633 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2636 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2639 assert(s > (char *) 3);
2641 res = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0);
2644 SvREFCNT_dec_NN(res);
2645 /* diag_listed_as: Unknown charname '%s' */
2646 *error_msg = Perl_form(aTHX_ "Unknown charname ''");
2650 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2651 /* include the <}> */
2652 e - backslash_ptr + 1, error_msg);
2654 SvREFCNT_dec_NN(res);
2658 /* See if the charnames handler is the Perl core's, and if so, we can skip
2659 * the validation needed for a user-supplied one, as Perl's does its own
2661 table = GvHV(PL_hintgv); /* ^H */
2662 cvp = hv_fetchs(table, "charnames", FALSE);
2663 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2664 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2666 const char * const name = HvNAME(stash);
2667 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2672 /* Here, it isn't Perl's charname handler. We can't rely on a
2673 * user-supplied handler to validate the input name. For non-ut8 input,
2674 * look to see that the first character is legal. Then loop through the
2675 * rest checking that each is a continuation */
2677 /* This code makes the reasonable assumption that the only Latin1-range
2678 * characters that begin a character name alias are alphabetic, otherwise
2679 * would have to create a isCHARNAME_BEGIN macro */
2682 if (! isALPHAU(*s)) {
2687 if (! isCHARNAME_CONT(*s)) {
2690 if (*s == ' ' && *(s-1) == ' ') {
2697 /* Similarly for utf8. For invariants can check directly; for other
2698 * Latin1, can calculate their code point and check; otherwise use a
2700 if (UTF8_IS_INVARIANT(*s)) {
2701 if (! isALPHAU(*s)) {
2705 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2706 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2712 if (! _invlist_contains_cp(PL_utf8_charname_begin,
2713 utf8_to_uvchr_buf((U8 *) s,
2723 if (UTF8_IS_INVARIANT(*s)) {
2724 if (! isCHARNAME_CONT(*s)) {
2727 if (*s == ' ' && *(s-1) == ' ') {
2732 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2733 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2740 if (! _invlist_contains_cp(PL_utf8_charname_continue,
2741 utf8_to_uvchr_buf((U8 *) s,
2751 if (*(s-1) == ' ') {
2752 /* diag_listed_as: charnames alias definitions may not contain
2753 trailing white-space; marked by <-- HERE in %s
2755 *error_msg = Perl_form(aTHX_
2756 "charnames alias definitions may not contain trailing "
2757 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2758 (int)(s - backslash_ptr + 1), backslash_ptr,
2759 (int)(e - s + 1), s + 1);
2763 if (SvUTF8(res)) { /* Don't accept malformed charname value */
2764 const U8* first_bad_char_loc;
2766 const char* const str = SvPV_const(res, len);
2767 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2768 &first_bad_char_loc)))
2770 _force_out_malformed_utf8_message(first_bad_char_loc,
2771 (U8 *) PL_parser->bufend,
2773 0 /* 0 means don't die */ );
2774 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2775 immediately after '%s' */
2776 *error_msg = Perl_form(aTHX_
2777 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2778 (int) (e - backslash_ptr + 1), backslash_ptr,
2779 (int) ((char *) first_bad_char_loc - str), str);
2788 /* The final %.*s makes sure that should the trailing NUL be missing
2789 * that this print won't run off the end of the string */
2790 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2792 *error_msg = Perl_form(aTHX_
2793 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2794 (int)(s - backslash_ptr + 1), backslash_ptr,
2795 (int)(e - s + 1), s + 1);
2800 /* diag_listed_as: charnames alias definitions may not contain a
2801 sequence of multiple spaces; marked by <-- HERE
2803 *error_msg = Perl_form(aTHX_
2804 "charnames alias definitions may not contain a sequence of "
2805 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2806 (int)(s - backslash_ptr + 1), backslash_ptr,
2807 (int)(e - s + 1), s + 1);
2814 Extracts the next constant part of a pattern, double-quoted string,
2815 or transliteration. This is terrifying code.
2817 For example, in parsing the double-quoted string "ab\x63$d", it would
2818 stop at the '$' and return an OP_CONST containing 'abc'.
2820 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2821 processing a pattern (PL_lex_inpat is true), a transliteration
2822 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2824 Returns a pointer to the character scanned up to. If this is
2825 advanced from the start pointer supplied (i.e. if anything was
2826 successfully parsed), will leave an OP_CONST for the substring scanned
2827 in pl_yylval. Caller must intuit reason for not parsing further
2828 by looking at the next characters herself.
2832 \N{FOO} => \N{U+hex_for_character_FOO}
2833 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2836 all other \-char, including \N and \N{ apart from \N{ABC}
2839 @ and $ where it appears to be a var, but not for $ as tail anchor
2843 In transliterations:
2844 characters are VERY literal, except for - not at the start or end
2845 of the string, which indicates a range. However some backslash sequences
2846 are recognized: \r, \n, and the like
2847 \007 \o{}, \x{}, \N{}
2848 If all elements in the transliteration are below 256,
2849 scan_const expands the range to the full set of intermediate
2850 characters. If the range is in utf8, the hyphen is replaced with
2851 a certain range mark which will be handled by pmtrans() in op.c.
2853 In double-quoted strings:
2855 all those recognized in transliterations
2856 deprecated backrefs: \1 (in substitution replacements)
2857 case and quoting: \U \Q \E
2860 scan_const does *not* construct ops to handle interpolated strings.
2861 It stops processing as soon as it finds an embedded $ or @ variable
2862 and leaves it to the caller to work out what's going on.
2864 embedded arrays (whether in pattern or not) could be:
2865 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2867 $ in double-quoted strings must be the symbol of an embedded scalar.
2869 $ in pattern could be $foo or could be tail anchor. Assumption:
2870 it's a tail anchor if $ is the last thing in the string, or if it's
2871 followed by one of "()| \r\n\t"
2873 \1 (backreferences) are turned into $1 in substitutions
2875 The structure of the code is
2876 while (there's a character to process) {
2877 handle transliteration ranges
2878 skip regexp comments /(?#comment)/ and codes /(?{code})/
2879 skip #-initiated comments in //x patterns
2880 check for embedded arrays
2881 check for embedded scalars
2883 deprecate \1 in substitution replacements
2884 handle string-changing backslashes \l \U \Q \E, etc.
2885 switch (what was escaped) {
2886 handle \- in a transliteration (becomes a literal -)
2887 if a pattern and not \N{, go treat as regular character
2888 handle \132 (octal characters)
2889 handle \x15 and \x{1234} (hex characters)
2890 handle \N{name} (named characters, also \N{3,5} in a pattern)
2891 handle \cV (control characters)
2892 handle printf-style backslashes (\f, \r, \n, etc)
2895 } (end if backslash)
2896 handle regular character
2897 } (end while character to read)
2902 S_scan_const(pTHX_ char *start)
2904 char *send = PL_bufend; /* end of the constant */
2905 SV *sv = newSV(send - start); /* sv for the constant. See note below
2907 char *s = start; /* start of the constant */
2908 char *d = SvPVX(sv); /* destination for copies */
2909 bool dorange = FALSE; /* are we in a translit range? */
2910 bool didrange = FALSE; /* did we just finish a range? */
2911 bool in_charclass = FALSE; /* within /[...]/ */
2912 bool d_is_utf8 = FALSE; /* Output constant is UTF8 */
2913 bool s_is_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2914 UTF8? But, this can show as true
2915 when the source isn't utf8, as for
2916 example when it is entirely composed
2918 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2919 number of characters found so far
2920 that will expand (into 2 bytes)
2921 should we have to convert to
2923 SV *res; /* result from charnames */
2924 STRLEN offset_to_max = 0; /* The offset in the output to where the range
2925 high-end character is temporarily placed */
2927 /* Does something require special handling in tr/// ? This avoids extra
2928 * work in a less likely case. As such, khw didn't feel it was worth
2929 * adding any branches to the more mainline code to handle this, which
2930 * means that this doesn't get set in some circumstances when things like
2931 * \x{100} get expanded out. As a result there needs to be extra testing
2932 * done in the tr code */
2933 bool has_above_latin1 = FALSE;
2935 /* Note on sizing: The scanned constant is placed into sv, which is
2936 * initialized by newSV() assuming one byte of output for every byte of
2937 * input. This routine expects newSV() to allocate an extra byte for a
2938 * trailing NUL, which this routine will append if it gets to the end of
2939 * the input. There may be more bytes of input than output (eg., \N{LATIN
2940 * CAPITAL LETTER A}), or more output than input if the constant ends up
2941 * recoded to utf8, but each time a construct is found that might increase
2942 * the needed size, SvGROW() is called. Its size parameter each time is
2943 * based on the best guess estimate at the time, namely the length used so
2944 * far, plus the length the current construct will occupy, plus room for
2945 * the trailing NUL, plus one byte for every input byte still unscanned */
2947 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2950 int backslash_N = 0; /* ? was the character from \N{} */
2951 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2952 platform-specific like \x65 */
2955 PERL_ARGS_ASSERT_SCAN_CONST;
2957 assert(PL_lex_inwhat != OP_TRANSR);
2958 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2959 /* If we are doing a trans and we know we want UTF8 set expectation */
2960 d_is_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2961 s_is_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2964 /* Protect sv from errors and fatal warnings. */
2965 ENTER_with_name("scan_const");
2968 /* A bunch of code in the loop below assumes that if s[n] exists and is not
2969 * NUL, then s[n+1] exists. This assertion makes sure that assumption is
2971 assert(*send == '\0');
2974 || dorange /* Handle tr/// range at right edge of input */
2977 /* get transliterations out of the way (they're most literal) */
2978 if (PL_lex_inwhat == OP_TRANS) {
2980 /* But there isn't any special handling necessary unless there is a
2981 * range, so for most cases we just drop down and handle the value
2982 * as any other. There are two exceptions.
2984 * 1. A hyphen indicates that we are actually going to have a
2985 * range. In this case, skip the '-', set a flag, then drop
2986 * down to handle what should be the end range value.
2987 * 2. After we've handled that value, the next time through, that
2988 * flag is set and we fix up the range.
2990 * Ranges entirely within Latin1 are expanded out entirely, in
2991 * order to make the transliteration a simple table look-up.
2992 * Ranges that extend above Latin1 have to be done differently, so
2993 * there is no advantage to expanding them here, so they are
2994 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2995 * signifies a hyphen without any possible ambiguity. On EBCDIC
2996 * machines, if the range is expressed as Unicode, the Latin1
2997 * portion is expanded out even if the range extends above
2998 * Latin1. This is because each code point in it has to be
2999 * processed here individually to get its native translation */
3003 /* Here, we don't think we're in a range. If the new character
3004 * is not a hyphen; or if it is a hyphen, but it's too close to
3005 * either edge to indicate a range, or if we haven't output any
3006 * characters yet then it's a regular character. */
3007 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
3009 /* A regular character. Process like any other, but first
3010 * clear any flags */
3014 non_portable_endpoint = 0;
3017 /* The tests here for being above Latin1 and similar ones
3018 * in the following 'else' suffice to find all such
3019 * occurences in the constant, except those added by a
3020 * backslash escape sequence, like \x{100}. Mostly, those
3021 * set 'has_above_latin1' as appropriate */
3022 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3023 has_above_latin1 = TRUE;
3026 /* Drops down to generic code to process current byte */
3028 else { /* Is a '-' in the context where it means a range */
3029 if (didrange) { /* Something like y/A-C-Z// */
3030 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3036 s++; /* Skip past the hyphen */
3038 /* d now points to where the end-range character will be
3039 * placed. Save it so won't have to go finding it later,
3040 * and drop down to get that character. (Actually we
3041 * instead save the offset, to handle the case where a
3042 * realloc in the meantime could change the actual
3043 * pointer). We'll finish processing the range the next
3044 * time through the loop */
3045 offset_to_max = d - SvPVX_const(sv);
3047 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3048 has_above_latin1 = TRUE;
3051 /* Drops down to generic code to process current byte */
3053 } /* End of not a range */
3055 /* Here we have parsed a range. Now must handle it. At this
3057 * 'sv' is a SV* that contains the output string we are
3058 * constructing. The final two characters in that string
3059 * are the range start and range end, in order.
3060 * 'd' points to just beyond the range end in the 'sv' string,
3061 * where we would next place something
3062 * 'offset_to_max' is the offset in 'sv' at which the character
3063 * (the range's maximum end point) before 'd' begins.
3065 char * max_ptr = SvPVX(sv) + offset_to_max;
3068 IV range_max; /* last character in range */
3070 Size_t offset_to_min = 0;
3073 bool convert_unicode;
3074 IV real_range_max = 0;
3076 /* Get the code point values of the range ends. */
3078 /* We know the utf8 is valid, because we just constructed
3079 * it ourselves in previous loop iterations */
3080 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3081 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3082 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3084 /* This compensates for not all code setting
3085 * 'has_above_latin1', so that we don't skip stuff that
3086 * should be executed */
3087 if (range_max > 255) {
3088 has_above_latin1 = TRUE;
3092 min_ptr = max_ptr - 1;
3093 range_min = * (U8*) min_ptr;
3094 range_max = * (U8*) max_ptr;
3097 /* If the range is just a single code point, like tr/a-a/.../,
3098 * that code point is already in the output, twice. We can
3099 * just back up over the second instance and avoid all the rest
3100 * of the work. But if it is a variant character, it's been
3101 * counted twice, so decrement. (This unlikely scenario is
3102 * special cased, like the one for a range of 2 code points
3103 * below, only because the main-line code below needs a range
3104 * of 3 or more to work without special casing. Might as well
3105 * get it out of the way now.) */
3106 if (UNLIKELY(range_max == range_min)) {
3108 if (! d_is_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3109 utf8_variant_count--;
3115 /* On EBCDIC platforms, we may have to deal with portable
3116 * ranges. These happen if at least one range endpoint is a
3117 * Unicode value (\N{...}), or if the range is a subset of
3118 * [A-Z] or [a-z], and both ends are literal characters,
3119 * like 'A', and not like \x{C1} */
3121 cBOOL(backslash_N) /* \N{} forces Unicode,
3122 hence portable range */
3123 || ( ! non_portable_endpoint
3124 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3125 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3126 if (convert_unicode) {
3128 /* Special handling is needed for these portable ranges.
3129 * They are defined to be in Unicode terms, which includes
3130 * all the Unicode code points between the end points.
3131 * Convert to Unicode to get the Unicode range. Later we
3132 * will convert each code point in the range back to
3134 range_min = NATIVE_TO_UNI(range_min);
3135 range_max = NATIVE_TO_UNI(range_max);
3139 if (range_min > range_max) {
3141 if (convert_unicode) {
3142 /* Need to convert back to native for meaningful
3143 * messages for this platform */
3144 range_min = UNI_TO_NATIVE(range_min);
3145 range_max = UNI_TO_NATIVE(range_max);
3148 /* Use the characters themselves for the error message if
3149 * ASCII printables; otherwise some visible representation
3151 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3153 "Invalid range \"%c-%c\" in transliteration operator",
3154 (char)range_min, (char)range_max);
3157 else if (convert_unicode) {
3158 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3160 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3161 UVXf "}\" in transliteration operator",
3162 range_min, range_max);
3166 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3168 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3169 " in transliteration operator",
3170 range_min, range_max);
3174 /* If the range is exactly two code points long, they are
3175 * already both in the output */
3176 if (UNLIKELY(range_min + 1 == range_max)) {
3180 /* Here the range contains at least 3 code points */
3184 /* If everything in the transliteration is below 256, we
3185 * can avoid special handling later. A translation table
3186 * for each of those bytes is created by op.c. So we
3187 * expand out all ranges to their constituent code points.
3188 * But if we've encountered something above 255, the
3189 * expanding won't help, so skip doing that. But if it's
3190 * EBCDIC, we may have to look at each character below 256
3191 * if we have to convert to/from Unicode values */
3192 if ( has_above_latin1
3194 && (range_min > 255 || ! convert_unicode)
3197 const STRLEN off = d - SvPVX(sv);
3198 const STRLEN extra = 1 + (send - s) + 1;
3201 /* Move the high character one byte to the right; then
3202 * insert between it and the range begin, an illegal
3203 * byte which serves to indicate this is a range (using
3204 * a '-' would be ambiguous). */
3206 if (off + extra > SvLEN(sv)) {
3207 d = off + SvGROW(sv, off + extra);
3208 max_ptr = d - off + offset_to_max;
3212 while (e-- > max_ptr) {
3215 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3219 /* Here, we're going to expand out the range. For EBCDIC
3220 * the range can extend above 255 (not so in ASCII), so
3221 * for EBCDIC, split it into the parts above and below
3224 if (range_max > 255) {
3225 real_range_max = range_max;
3231 /* Here we need to expand out the string to contain each
3232 * character in the range. Grow the output to handle this.
3233 * For non-UTF8, we need a byte for each code point in the
3234 * range, minus the three that we've already allocated for: the
3235 * hyphen, the min, and the max. For UTF-8, we need this
3236 * plus an extra byte for each code point that occupies two
3237 * bytes (is variant) when in UTF-8 (except we've already
3238 * allocated for the end points, including if they are
3239 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3240 * platforms, it's easy to calculate a precise number. To
3241 * start, we count the variants in the range, which we need
3242 * elsewhere in this function anyway. (For the case where it
3243 * isn't easy to calculate, 'extras' has been initialized to 0,
3244 * and the calculation is done in a loop further down.) */
3246 if (convert_unicode)
3249 /* This is executed unconditionally on ASCII, and for
3250 * Unicode ranges on EBCDIC. Under these conditions, all
3251 * code points above a certain value are variant; and none
3252 * under that value are. We just need to find out how much
3253 * of the range is above that value. We don't count the
3254 * end points here, as they will already have been counted
3255 * as they were parsed. */
3256 if (range_min >= UTF_CONTINUATION_MARK) {
3258 /* The whole range is made up of variants */
3259 extras = (range_max - 1) - (range_min + 1) + 1;
3261 else if (range_max >= UTF_CONTINUATION_MARK) {
3263 /* Only the higher portion of the range is variants */
3264 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3267 utf8_variant_count += extras;
3270 /* The base growth is the number of code points in the range,
3271 * not including the endpoints, which have already been sized
3272 * for (and output). We don't subtract for the hyphen, as it
3273 * has been parsed but not output, and the SvGROW below is
3274 * based only on what's been output plus what's left to parse.
3276 grow = (range_max - 1) - (range_min + 1) + 1;
3280 /* In some cases in EBCDIC, we haven't yet calculated a
3281 * precise amount needed for the UTF-8 variants. Just
3282 * assume the worst case, that everything will expand by a
3284 if (! convert_unicode) {
3290 /* Otherwise we know exactly how many variants there
3291 * are in the range. */
3296 /* Grow, but position the output to overwrite the range min end
3297 * point, because in some cases we overwrite that */
3298 SvCUR_set(sv, d - SvPVX_const(sv));
3299 offset_to_min = min_ptr - SvPVX_const(sv);
3301 /* See Note on sizing above. */
3302 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3305 + 1 /* Trailing NUL */ );
3307 /* Now, we can expand out the range. */
3309 if (convert_unicode) {
3312 /* Recall that the min and max are now in Unicode terms, so
3313 * we have to convert each character to its native
3316 for (i = range_min; i <= range_max; i++) {
3317 append_utf8_from_native_byte(
3318 LATIN1_TO_NATIVE((U8) i),
3323 for (i = range_min; i <= range_max; i++) {
3324 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3330 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3332 /* Here, no conversions are necessary, which means that the
3333 * first character in the range is already in 'd' and
3334 * valid, so we can skip overwriting it */
3338 for (i = range_min + 1; i <= range_max; i++) {
3339 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3345 assert(range_min + 1 <= range_max);
3346 for (i = range_min + 1; i < range_max; i++) {
3348 /* In this case on EBCDIC, we haven't calculated
3349 * the variants. Do it here, as we go along */
3350 if (! UVCHR_IS_INVARIANT(i)) {
3351 utf8_variant_count++;
3357 /* The range_max is done outside the loop so as to
3358 * avoid having to special case not incrementing
3359 * 'utf8_variant_count' on EBCDIC (it's already been
3360 * counted when originally parsed) */
3361 *d++ = (char) range_max;
3366 /* If the original range extended above 255, add in that
3368 if (real_range_max) {
3369 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3370 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3371 if (real_range_max > 0x100) {
3372 if (real_range_max > 0x101) {
3373 *d++ = (char) ILLEGAL_UTF8_BYTE;
3375 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3381 /* mark the range as done, and continue */
3385 non_portable_endpoint = 0;
3389 } /* End of is a range */
3390 } /* End of transliteration. Joins main code after these else's */
3391 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3394 while (s1 >= start && *s1-- == '\\')
3397 in_charclass = TRUE;
3399 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3402 while (s1 >= start && *s1-- == '\\')
3405 in_charclass = FALSE;
3407 /* skip for regexp comments /(?#comment)/, except for the last
3408 * char, which will be done separately. Stop on (?{..}) and
3410 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3413 PERL_UINT_FAST8_T len = UTF8SKIP(s);
3415 while (s + len < send && *s != ')') {
3416 Copy(s, d, len, U8);
3419 len = UTF8_SAFE_SKIP(s, send);
3422 else while (s+1 < send && *s != ')') {
3426 else if (!PL_lex_casemods
3427 && ( s[2] == '{' /* This should match regcomp.c */
3428 || (s[2] == '?' && s[3] == '{')))
3433 /* likewise skip #-initiated comments in //x patterns */
3437 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3439 while (s < send && *s != '\n')
3442 /* no further processing of single-quoted regex */
3443 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3444 goto default_action;
3446 /* check for embedded arrays
3447 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3449 else if (*s == '@' && s[1]) {
3451 ? isIDFIRST_utf8_safe(s+1, send)
3452 : isWORDCHAR_A(s[1]))
3456 if (strchr(":'{$", s[1]))
3458 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3459 break; /* in regexp, neither @+ nor @- are interpolated */
3461 /* check for embedded scalars. only stop if we're sure it's a
3463 else if (*s == '$') {
3464 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3466 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3468 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3469 "Possible unintended interpolation of $\\ in regex");
3471 break; /* in regexp, $ might be tail anchor */
3475 /* End of else if chain - OP_TRANS rejoin rest */
3477 if (UNLIKELY(s >= send)) {
3483 if (*s == '\\' && s+1 < send) {
3484 char* e; /* Can be used for ending '}', etc. */
3488 /* warn on \1 - \9 in substitution replacements, but note that \11
3489 * is an octal; and \19 is \1 followed by '9' */
3490 if (PL_lex_inwhat == OP_SUBST
3496 /* diag_listed_as: \%d better written as $%d */
3497 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3502 /* string-change backslash escapes */
3503 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3507 /* In a pattern, process \N, but skip any other backslash escapes.
3508 * This is because we don't want to translate an escape sequence
3509 * into a meta symbol and have the regex compiler use the meta
3510 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3511 * in spite of this, we do have to process \N here while the proper
3512 * charnames handler is in scope. See bugs #56444 and #62056.
3514 * There is a complication because \N in a pattern may also stand
3515 * for 'match a non-nl', and not mean a charname, in which case its
3516 * processing should be deferred to the regex compiler. To be a
3517 * charname it must be followed immediately by a '{', and not look
3518 * like \N followed by a curly quantifier, i.e., not something like
3519 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3521 else if (PL_lex_inpat
3524 || regcurly(s + 1)))
3527 goto default_action;
3533 if ((isALPHANUMERIC(*s)))
3534 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3535 "Unrecognized escape \\%c passed through",
3537 /* default action is to copy the quoted character */
3538 goto default_action;
3541 /* eg. \132 indicates the octal constant 0132 */
3542 case '0': case '1': case '2': case '3':
3543 case '4': case '5': case '6': case '7':
3545 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3547 uv = grok_oct(s, &len, &flags, NULL);
3549 if (len < 3 && s < send && isDIGIT(*s)
3550 && ckWARN(WARN_MISC))
3552 Perl_warner(aTHX_ packWARN(WARN_MISC),
3553 "%s", form_short_octal_warning(s, len));
3556 goto NUM_ESCAPE_INSERT;
3558 /* eg. \o{24} indicates the octal constant \024 */
3563 bool valid = grok_bslash_o(&s, send,
3565 TRUE, /* Output warning */
3566 FALSE, /* Not strict */
3567 TRUE, /* Output warnings for
3572 uv = 0; /* drop through to ensure range ends are set */
3574 goto NUM_ESCAPE_INSERT;
3577 /* eg. \x24 indicates the hex constant 0x24 */
3582 bool valid = grok_bslash_x(&s, send,
3584 TRUE, /* Output warning */
3585 FALSE, /* Not strict */
3586 TRUE, /* Output warnings for
3591 uv = 0; /* drop through to ensure range ends are set */
3596 /* Insert oct or hex escaped character. */
3598 /* Here uv is the ordinal of the next character being added */
3599 if (UVCHR_IS_INVARIANT(uv)) {
3603 if (!d_is_utf8 && uv > 255) {
3605 /* Here, 'uv' won't fit unless we convert to UTF-8.
3606 * If we've only seen invariants so far, all we have to
3607 * do is turn on the flag */
3608 if (utf8_variant_count == 0) {
3612 SvCUR_set(sv, d - SvPVX_const(sv));
3616 sv_utf8_upgrade_flags_grow(
3618 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3620 /* Since we're having to grow here,
3621 * make sure we have enough room for
3622 * this escape and a NUL, so the
3623 * code immediately below won't have
3624 * to actually grow again */
3626 + (STRLEN)(send - s) + 1);
3627 d = SvPVX(sv) + SvCUR(sv);
3630 has_above_latin1 = TRUE;
3636 utf8_variant_count++;
3639 /* Usually, there will already be enough room in 'sv'
3640 * since such escapes are likely longer than any UTF-8
3641 * sequence they can end up as. This isn't the case on
3642 * EBCDIC where \x{40000000} contains 12 bytes, and the
3643 * UTF-8 for it contains 14. And, we have to allow for
3644 * a trailing NUL. It probably can't happen on ASCII
3645 * platforms, but be safe. See Note on sizing above. */
3646 const STRLEN needed = d - SvPVX(sv)
3650 if (UNLIKELY(needed > SvLEN(sv))) {
3651 SvCUR_set(sv, d - SvPVX_const(sv));
3652 d = SvCUR(sv) + SvGROW(sv, needed);
3655 d = (char*)uvchr_to_utf8((U8*)d, uv);
3656 if (PL_lex_inwhat == OP_TRANS
3657 && PL_parser->lex_sub_op)
3659 PL_parser->lex_sub_op->op_private |=
3660 (PL_lex_repl ? OPpTRANS_FROM_UTF
3666 non_portable_endpoint++;
3671 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3672 * named character, like \N{LATIN SMALL LETTER A}, or a named
3673 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3674 * GRAVE} (except y/// can't handle the latter, croaking). For
3675 * convenience all three forms are referred to as "named
3676 * characters" below.
3678 * For patterns, \N also can mean to match a non-newline. Code
3679 * before this 'switch' statement should already have handled
3680 * this situation, and hence this code only has to deal with
3681 * the named character cases.
3683 * For non-patterns, the named characters are converted to
3684 * their string equivalents. In patterns, named characters are
3685 * not converted to their ultimate forms for the same reasons
3686 * that other escapes aren't (mainly that the ultimate
3687 * character could be considered a meta-symbol by the regex
3688 * compiler). Instead, they are converted to the \N{U+...}
3689 * form to get the value from the charnames that is in effect
3690 * right now, while preserving the fact that it was a named
3691 * character, so that the regex compiler knows this.
3693 * The structure of this section of code (besides checking for
3694 * errors and upgrading to utf8) is:
3695 * If the named character is of the form \N{U+...}, pass it
3696 * through if a pattern; otherwise convert the code point
3698 * Otherwise must be some \N{NAME}: convert to
3699 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3701 * Transliteration is an exception. The conversion to utf8 is
3702 * only done if the code point requires it to be representable.
3704 * Here, 's' points to the 'N'; the test below is guaranteed to
3705 * succeed if we are being called on a pattern, as we already
3706 * know from a test above that the next character is a '{'. A
3707 * non-pattern \N must mean 'named character', which requires
3711 yyerror("Missing braces on \\N{}");
3717 /* If there is no matching '}', it is an error. */
3718 if (! (e = (char *) memchr(s, '}', send - s))) {
3719 if (! PL_lex_inpat) {
3720 yyerror("Missing right brace on \\N{}");
3722 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3724 yyquit(); /* Have exhausted the input. */
3727 /* Here it looks like a named character */
3729 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3730 s += 2; /* Skip to next char after the 'U+' */
3733 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3734 /* Check the syntax. */
3737 if (!isXDIGIT(*s)) {
3740 "Invalid hexadecimal number in \\N{U+...}"
3749 else if ((*s == '.' || *s == '_')
3755 /* Pass everything through unchanged.
3756 * +1 is for the '}' */
3757 Copy(orig_s, d, e - orig_s + 1, char);
3758 d += e - orig_s + 1;
3760 else { /* Not a pattern: convert the hex to string */
3761 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3762 | PERL_SCAN_SILENT_ILLDIGIT
3763 | PERL_SCAN_DISALLOW_PREFIX;
3765 uv = grok_hex(s, &len, &flags, NULL);
3766 if (len == 0 || (len != (STRLEN)(e - s)))
3769 /* For non-tr///, if the destination is not in utf8,
3770 * unconditionally recode it to be so. This is
3771 * because \N{} implies Unicode semantics, and scalars
3772 * have to be in utf8 to guarantee those semantics.
3773 * tr/// doesn't care about Unicode rules, so no need
3774 * there to upgrade to UTF-8 for small enough code
3776 if (! d_is_utf8 && ( uv > 0xFF
3777 || PL_lex_inwhat != OP_TRANS))
3779 /* See Note on sizing above. */
3780 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3782 SvCUR_set(sv, d - SvPVX_const(sv));
3786 if (utf8_variant_count == 0) {
3788 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3791 sv_utf8_upgrade_flags_grow(
3793 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3795 d = SvPVX(sv) + SvCUR(sv);
3799 has_above_latin1 = TRUE;
3802 /* Add the (Unicode) code point to the output. */
3803 if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3804 *d++ = (char) LATIN1_TO_NATIVE(uv);
3807 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3811 else /* Here is \N{NAME} but not \N{U+...}. */
3812 if (! (res = get_and_check_backslash_N_name_wrapper(s, e)))
3813 { /* Failed. We should die eventually, but for now use a NUL
3817 else { /* Successfully evaluated the name */
3819 const char *str = SvPV_const(res, len);
3822 if (! len) { /* The name resolved to an empty string */
3823 const char empty_N[] = "\\N{_}";
3824 Copy(empty_N, d, sizeof(empty_N) - 1, char);
3825 d += sizeof(empty_N) - 1;
3828 /* In order to not lose information for the regex
3829 * compiler, pass the result in the specially made
3830 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3831 * the code points in hex of each character
3832 * returned by charnames */
3834 const char *str_end = str + len;
3835 const STRLEN off = d - SvPVX_const(sv);
3837 if (! SvUTF8(res)) {
3838 /* For the non-UTF-8 case, we can determine the
3839 * exact length needed without having to parse
3840 * through the string. Each character takes up
3841 * 2 hex digits plus either a trailing dot or
3843 const char initial_text[] = "\\N{U+";
3844 const STRLEN initial_len = sizeof(initial_text)
3846 d = off + SvGROW(sv, off
3849 /* +1 for trailing NUL */
3852 + (STRLEN)(send - e));
3853 Copy(initial_text, d, initial_len, char);
3855 while (str < str_end) {
3858 my_snprintf(hex_string,
3862 /* The regex compiler is
3863 * expecting Unicode, not
3865 NATIVE_TO_LATIN1(*str));
3866 PERL_MY_SNPRINTF_POST_GUARD(len,
3867 sizeof(hex_string));
3868 Copy(hex_string, d, 3, char);
3872 d--; /* Below, we will overwrite the final
3873 dot with a right brace */
3876 STRLEN char_length; /* cur char's byte length */
3878 /* and the number of bytes after this is
3879 * translated into hex digits */
3880 STRLEN output_length;
3882 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3883 * for max('U+', '.'); and 1 for NUL */
3884 char hex_string[2 * UTF8_MAXBYTES + 5];
3886 /* Get the first character of the result. */
3887 U32 uv = utf8n_to_uvchr((U8 *) str,
3891 /* Convert first code point to Unicode hex,
3892 * including the boiler plate before it. */
3894 my_snprintf(hex_string, sizeof(hex_string),
3896 (unsigned int) NATIVE_TO_UNI(uv));
3898 /* Make sure there is enough space to hold it */
3899 d = off + SvGROW(sv, off
3901 + (STRLEN)(send - e)
3902 + 2); /* '}' + NUL */
3904 Copy(hex_string, d, output_length, char);
3907 /* For each subsequent character, append dot and
3908 * its Unicode code point in hex */
3909 while ((str += char_length) < str_end) {
3910 const STRLEN off = d - SvPVX_const(sv);
3911 U32 uv = utf8n_to_uvchr((U8 *) str,
3916 my_snprintf(hex_string,
3919 (unsigned int) NATIVE_TO_UNI(uv));
3921 d = off + SvGROW(sv, off
3923 + (STRLEN)(send - e)
3924 + 2); /* '}' + NUL */
3925 Copy(hex_string, d, output_length, char);
3930 *d++ = '}'; /* Done. Add the trailing brace */
3933 else { /* Here, not in a pattern. Convert the name to a
3936 if (PL_lex_inwhat == OP_TRANS) {
3937 str = SvPV_const(res, len);
3938 if (len > ((SvUTF8(res))
3942 yyerror(Perl_form(aTHX_
3943 "%.*s must not be a named sequence"
3944 " in transliteration operator",
3945 /* +1 to include the "}" */
3946 (int) (e + 1 - start), start));
3948 goto end_backslash_N;
3951 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3952 has_above_latin1 = TRUE;
3956 else if (! SvUTF8(res)) {
3957 /* Make sure \N{} return is UTF-8. This is because
3958 * \N{} implies Unicode semantics, and scalars have
3959 * to be in utf8 to guarantee those semantics; but
3960 * not needed in tr/// */
3961 sv_utf8_upgrade_flags(res, 0);
3962 str = SvPV_const(res, len);
3965 /* Upgrade destination to be utf8 if this new
3967 if (! d_is_utf8 && SvUTF8(res)) {
3968 /* See Note on sizing above. */
3969 const STRLEN extra = len + (send - s) + 1;
3971 SvCUR_set(sv, d - SvPVX_const(sv));
3975 if (utf8_variant_count == 0) {
3977 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3980 sv_utf8_upgrade_flags_grow(sv,
3981 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3983 d = SvPVX(sv) + SvCUR(sv);
3986 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3988 /* See Note on sizing above. (NOTE: SvCUR() is not
3989 * set correctly here). */
3990 const STRLEN extra = len + (send - e) + 1;
3991 const STRLEN off = d - SvPVX_const(sv);
3992 d = off + SvGROW(sv, off + extra);
3994 Copy(str, d, len, char);
4000 } /* End \N{NAME} */
4004 backslash_N++; /* \N{} is defined to be Unicode */
4006 s = e + 1; /* Point to just after the '}' */
4009 /* \c is a control character */
4013 *d++ = grok_bslash_c(*s, 1);
4016 yyerror("Missing control char name in \\c");
4017 yyquit(); /* Are at end of input, no sense continuing */
4020 non_portable_endpoint++;
4024 /* printf-style backslashes, formfeeds, newlines, etc */
4050 } /* end if (backslash) */
4053 /* Just copy the input to the output, though we may have to convert
4056 * If the input has the same representation in UTF-8 as not, it will be
4057 * a single byte, and we don't care about UTF8ness; just copy the byte */
4058 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4061 else if (! s_is_utf8 && ! d_is_utf8) {
4062 /* If neither source nor output is UTF-8, is also a single byte,
4063 * just copy it; but this byte counts should we later have to
4064 * convert to UTF-8 */
4066 utf8_variant_count++;
4068 else if (s_is_utf8 && d_is_utf8) { /* Both UTF-8, can just copy */
4069 const STRLEN len = UTF8SKIP(s);
4071 /* We expect the source to have already been checked for
4073 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4075 Copy(s, d, len, U8);
4079 else if (s_is_utf8) { /* UTF8ness matters: convert output to utf8 */
4080 STRLEN need = send - s + 1; /* See Note on sizing above. */
4082 SvCUR_set(sv, d - SvPVX_const(sv));
4086 if (utf8_variant_count == 0) {
4088 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4091 sv_utf8_upgrade_flags_grow(sv,
4092 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4094 d = SvPVX(sv) + SvCUR(sv);
4097 goto default_action; /* Redo, having upgraded so both are UTF-8 */
4099 else { /* UTF8ness matters: convert this non-UTF8 source char to
4100 UTF-8 for output. It will occupy 2 bytes, but don't include
4101 the input byte since we haven't incremented 's' yet. See
4102 Note on sizing above. */
4103 const STRLEN off = d - SvPVX(sv);
4104 const STRLEN extra = 2 + (send - s - 1) + 1;
4105 if (off + extra > SvLEN(sv)) {
4106 d = off + SvGROW(sv, off + extra);
4108 *d++ = UTF8_EIGHT_BIT_HI(*s);
4109 *d++ = UTF8_EIGHT_BIT_LO(*s);
4112 } /* while loop to process each character */
4115 const STRLEN off = d - SvPVX(sv);
4117 /* See if room for the terminating NUL */
4118 if (UNLIKELY(off >= SvLEN(sv))) {
4122 if (off > SvLEN(sv))
4124 Perl_croak(aTHX_ "panic: constant overflowed allocated space,"
4125 " %" UVuf " >= %" UVuf, (UV)off, (UV)SvLEN(sv));
4127 /* Whew! Here we don't have room for the terminating NUL, but
4128 * everything else so far has fit. It's not too late to grow
4129 * to fit the NUL and continue on. But it is a bug, as the code
4130 * above was supposed to have made room for this, so under
4131 * DEBUGGING builds, we panic anyway. */
4132 d = off + SvGROW(sv, off + 1);
4136 /* terminate the string and set up the sv */
4138 SvCUR_set(sv, d - SvPVX_const(sv));
4143 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4144 PL_parser->lex_sub_op->op_private |=
4145 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4149 /* shrink the sv if we allocated more than we used */
4150 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4151 SvPV_shrink_to_cur(sv);
4154 /* return the substring (via pl_yylval) only if we parsed anything */
4157 for (; s2 < s; s2++) {
4159 COPLINE_INC_WITH_HERELINES;
4161 SvREFCNT_inc_simple_void_NN(sv);
4162 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4163 && ! PL_parser->lex_re_reparsing)
4165 const char *const key = PL_lex_inpat ? "qr" : "q";
4166 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4170 if (PL_lex_inwhat == OP_TRANS) {
4173 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4176 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4184 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4185 type, typelen, NULL);
4187 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4189 LEAVE_with_name("scan_const");
4194 * Returns TRUE if there's more to the expression (e.g., a subscript),
4197 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4199 * ->[ and ->{ return TRUE
4200 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4201 * { and [ outside a pattern are always subscripts, so return TRUE
4202 * if we're outside a pattern and it's not { or [, then return FALSE
4203 * if we're in a pattern and the first char is a {
4204 * {4,5} (any digits around the comma) returns FALSE
4205 * if we're in a pattern and the first char is a [
4207 * [SOMETHING] has a funky algorithm to decide whether it's a
4208 * character class or not. It has to deal with things like
4209 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4210 * anything else returns TRUE
4213 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4216 S_intuit_more(pTHX_ char *s, char *e)
4218 PERL_ARGS_ASSERT_INTUIT_MORE;
4220 if (PL_lex_brackets)
4222 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4224 if (*s == '-' && s[1] == '>'
4225 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4226 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4227 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4229 if (*s != '{' && *s != '[')
4231 PL_parser->sub_no_recover = TRUE;
4235 /* In a pattern, so maybe we have {n,m}. */
4243 /* On the other hand, maybe we have a character class */
4246 if (*s == ']' || *s == '^')
4249 /* this is terrifying, and it works */
4252 const char * const send = (char *) memchr(s, ']', e - s);
4253 unsigned char un_char, last_un_char;
4254 char tmpbuf[sizeof PL_tokenbuf * 4];
4256 if (!send) /* has to be an expression */
4258 weight = 2; /* let's weigh the evidence */
4262 else if (isDIGIT(*s)) {
4264 if (isDIGIT(s[1]) && s[2] == ']')
4270 Zero(seen,256,char);
4272 for (; s < send; s++) {
4273 last_un_char = un_char;
4274 un_char = (unsigned char)*s;
4279 weight -= seen[un_char] * 10;
4280 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4282 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4283 len = (int)strlen(tmpbuf);
4284 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4285 UTF ? SVf_UTF8 : 0, SVt_PV))
4292 && strchr("[#!%*<>()-=",s[1]))
4294 if (/*{*/ strchr("])} =",s[2]))
4303 if (strchr("wds]",s[1]))
4305 else if (seen[(U8)'\''] || seen[(U8)'"'])
4307 else if (strchr("rnftbxcav",s[1]))
4309 else if (isDIGIT(s[1])) {
4311 while (s[1] && isDIGIT(s[1]))
4321 if (strchr("aA01! ",last_un_char))
4323 if (strchr("zZ79~",s[1]))
4325 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4326 weight -= 5; /* cope with negative subscript */
4329 if (!isWORDCHAR(last_un_char)
4330 && !(last_un_char == '$' || last_un_char == '@'
4331 || last_un_char == '&')
4332 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4336 if (keyword(d, s - d, 0))
4339 if (un_char == last_un_char + 1)
4341 weight -= seen[un_char];
4346 if (weight >= 0) /* probably a character class */
4356 * Does all the checking to disambiguate
4358 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4359 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4361 * First argument is the stuff after the first token, e.g. "bar".
4363 * Not a method if foo is a filehandle.
4364 * Not a method if foo is a subroutine prototyped to take a filehandle.
4365 * Not a method if it's really "Foo $bar"
4366 * Method if it's "foo $bar"
4367 * Not a method if it's really "print foo $bar"
4368 * Method if it's really "foo package::" (interpreted as package->foo)
4369 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4370 * Not a method if bar is a filehandle or package, but is quoted with
4375 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4377 char *s = start + (*start == '$');
4378 char tmpbuf[sizeof PL_tokenbuf];
4381 /* Mustn't actually add anything to a symbol table.
4382 But also don't want to "initialise" any placeholder
4383 constants that might already be there into full
4384 blown PVGVs with attached PVCV. */
4386 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4388 PERL_ARGS_ASSERT_INTUIT_METHOD;
4390 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4392 if (cv && SvPOK(cv)) {
4393 const char *proto = CvPROTO(cv);
4395 while (*proto && (isSPACE(*proto) || *proto == ';'))
4402 if (*start == '$') {
4403 SSize_t start_off = start - SvPVX(PL_linestr);
4404 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4405 || isUPPER(*PL_tokenbuf))
4407 /* this could be $# */
4410 PL_bufptr = SvPVX(PL_linestr) + start_off;
4412 return *s == '(' ? FUNCMETH : METHOD;
4415 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4416 /* start is the beginning of the possible filehandle/object,
4417 * and s is the end of it
4418 * tmpbuf is a copy of it (but with single quotes as double colons)
4421 if (!keyword(tmpbuf, len, 0)) {
4422 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4427 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4428 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4430 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4431 && (!isGV(indirgv) || GvCVu(indirgv)))
4433 /* filehandle or package name makes it a method */
4434 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4436 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4437 return 0; /* no assumptions -- "=>" quotes bareword */
4439 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4440 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4441 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4443 force_next(BAREWORD);
4445 return *s == '(' ? FUNCMETH : METHOD;
4451 /* Encoded script support. filter_add() effectively inserts a
4452 * 'pre-processing' function into the current source input stream.
4453 * Note that the filter function only applies to the current source file
4454 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4456 * The datasv parameter (which may be NULL) can be used to pass
4457 * private data to this instance of the filter. The filter function
4458 * can recover the SV using the FILTER_DATA macro and use it to
4459 * store private buffers and state information.
4461 * The supplied datasv parameter is upgraded to a PVIO type
4462 * and the IoDIRP/IoANY field is used to store the function pointer,
4463 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4464 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4465 * private use must be set using malloc'd pointers.
4469 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4477 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4478 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4480 if (!PL_rsfp_filters)
4481 PL_rsfp_filters = newAV();
4484 SvUPGRADE(datasv, SVt_PVIO);
4485 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4486 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4487 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4488 FPTR2DPTR(void *, IoANY(datasv)),
4489 SvPV_nolen(datasv)));
4490 av_unshift(PL_rsfp_filters, 1);
4491 av_store(PL_rsfp_filters, 0, datasv) ;
4493 !PL_parser->filtered
4494 && PL_parser->lex_flags & LEX_EVALBYTES
4495 && PL_bufptr < PL_bufend
4497 const char *s = PL_bufptr;
4498 while (s < PL_bufend) {
4500 SV *linestr = PL_parser->linestr;
4501 char *buf = SvPVX(linestr);
4502 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4503 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4504 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4505 STRLEN const linestart_pos = PL_parser->linestart - buf;
4506 STRLEN const last_uni_pos =
4507 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4508 STRLEN const last_lop_pos =
4509 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4510 av_push(PL_rsfp_filters, linestr);
4511 PL_parser->linestr =
4512 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4513 buf = SvPVX(PL_parser->linestr);
4514 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4515 PL_parser->bufptr = buf + bufptr_pos;
4516 PL_parser->oldbufptr = buf + oldbufptr_pos;
4517 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4518 PL_parser->linestart = buf + linestart_pos;
4519 if (PL_parser->last_uni)
4520 PL_parser->last_uni = buf + last_uni_pos;
4521 if (PL_parser->last_lop)
4522 PL_parser->last_lop = buf + last_lop_pos;
4523 SvLEN_set(linestr, SvCUR(linestr));
4524 SvCUR_set(linestr, s - SvPVX(linestr));
4525 PL_parser->filtered = 1;
4535 /* Delete most recently added instance of this filter function. */
4537 Perl_filter_del(pTHX_ filter_t funcp)
4541 PERL_ARGS_ASSERT_FILTER_DEL;
4544 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4545 FPTR2DPTR(void*, funcp)));
4547 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4549 /* if filter is on top of stack (usual case) just pop it off */
4550 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4551 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4552 sv_free(av_pop(PL_rsfp_filters));
4556 /* we need to search for the correct entry and clear it */
4557 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4561 /* Invoke the idxth filter function for the current rsfp. */
4562 /* maxlen 0 = read one text line */
4564 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4569 /* This API is bad. It should have been using unsigned int for maxlen.
4570 Not sure if we want to change the API, but if not we should sanity
4571 check the value here. */
4572 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4574 PERL_ARGS_ASSERT_FILTER_READ;
4576 if (!PL_parser || !PL_rsfp_filters)
4578 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4579 /* Provide a default input filter to make life easy. */
4580 /* Note that we append to the line. This is handy. */
4581 DEBUG_P(PerlIO_printf(Perl_debug_log,
4582 "filter_read %d: from rsfp\n", idx));
4583 if (correct_length) {
4586 const int old_len = SvCUR(buf_sv);
4588 /* ensure buf_sv is large enough */
4589 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4590 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4591 correct_length)) <= 0) {
4592 if (PerlIO_error(PL_rsfp))
4593 return -1; /* error */
4595 return 0 ; /* end of file */
4597 SvCUR_set(buf_sv, old_len + len) ;
4598 SvPVX(buf_sv)[old_len + len] = '\0';
4601 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4602 if (PerlIO_error(PL_rsfp))
4603 return -1; /* error */
4605 return 0 ; /* end of file */
4608 return SvCUR(buf_sv);
4610 /* Skip this filter slot if filter has been deleted */
4611 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4612 DEBUG_P(PerlIO_printf(Perl_debug_log,
4613 "filter_read %d: skipped (filter deleted)\n",
4615 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4617 if (SvTYPE(datasv) != SVt_PVIO) {
4618 if (correct_length) {
4620 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4621 if (!remainder) return 0; /* eof */
4622 if (correct_length > remainder) correct_length = remainder;
4623 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4624 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4627 const char *s = SvEND(datasv);
4628 const char *send = SvPVX(datasv) + SvLEN(datasv);
4636 if (s == send) return 0; /* eof */
4637 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4638 SvCUR_set(datasv, s-SvPVX(datasv));
4640 return SvCUR(buf_sv);
4642 /* Get function pointer hidden within datasv */
4643 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4644 DEBUG_P(PerlIO_printf(Perl_debug_log,
4645 "filter_read %d: via function %p (%s)\n",
4646 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4647 /* Call function. The function is expected to */
4648 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4649 /* Return: <0:error, =0:eof, >0:not eof */
4651 save_scalar(PL_errgv);
4652 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4658 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4660 PERL_ARGS_ASSERT_FILTER_GETS;
4662 #ifdef PERL_CR_FILTER
4663 if (!PL_rsfp_filters) {
4664 filter_add(S_cr_textfilter,NULL);
4667 if (PL_rsfp_filters) {
4669 SvCUR_set(sv, 0); /* start with empty line */
4670 if (FILTER_READ(0, sv, 0) > 0)
4671 return ( SvPVX(sv) ) ;
4676 return (sv_gets(sv, PL_rsfp, append));
4680 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4684 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4686 if (memEQs(pkgname, len, "__PACKAGE__"))
4690 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4691 && (gv = gv_fetchpvn_flags(pkgname,
4693 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4695 return GvHV(gv); /* Foo:: */
4698 /* use constant CLASS => 'MyClass' */
4699 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4700 if (gv && GvCV(gv)) {
4701 SV * const sv = cv_const_sv(GvCV(gv));
4703 return gv_stashsv(sv, 0);
4706 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4711 S_tokenize_use(pTHX_ int is_use, char *s) {
4712 PERL_ARGS_ASSERT_TOKENIZE_USE;
4714 if (PL_expect != XSTATE)
4715 /* diag_listed_as: "use" not allowed in expression */
4716 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4717 is_use ? "use" : "no"));
4720 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4721 s = force_version(s, TRUE);
4722 if (*s == ';' || *s == '}'
4723 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4724 NEXTVAL_NEXTTOKE.opval = NULL;
4725 force_next(BAREWORD);
4727 else if (*s == 'v') {
4728 s = force_word(s,BAREWORD,FALSE,TRUE);
4729 s = force_version(s, FALSE);
4733 s = force_word(s,BAREWORD,FALSE,TRUE);
4734 s = force_version(s, FALSE);
4736 pl_yylval.ival = is_use;
4740 static const char* const exp_name[] =
4741 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4742 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4743 "SIGVAR", "TERMORDORDOR"
4747 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4749 S_word_takes_any_delimiter(char *p, STRLEN len)
4751 return (len == 1 && strchr("msyq", p[0]))
4753 && ((p[0] == 't' && p[1] == 'r')
4754 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4758 S_check_scalar_slice(pTHX_ char *s)
4761 while (SPACE_OR_TAB(*s)) s++;
4762 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4768 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4769 || (*s && strchr(" \t$#+-'\"", *s)))
4771 s += UTF ? UTF8SKIP(s) : 1;
4773 if (*s == '}' || *s == ']')
4774 pl_yylval.ival = OPpSLICEWARNING;
4777 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4779 S_lex_token_boundary(pTHX)
4781 PL_oldoldbufptr = PL_oldbufptr;
4782 PL_oldbufptr = PL_bufptr;
4785 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4787 S_vcs_conflict_marker(pTHX_ char *s)
4789 lex_token_boundary();
4791 yyerror("Version control conflict marker");
4792 while (s < PL_bufend && *s != '\n')
4800 Works out what to call the token just pulled out of the input
4801 stream. The yacc parser takes care of taking the ops we return and
4802 stitching them into a tree.
4805 The type of the next token
4808 Check if we have already built the token; if so, use it.
4809 Switch based on the current state:
4810 - if we have a case modifier in a string, deal with that
4811 - handle other cases of interpolation inside a string
4812 - scan the next line if we are inside a format
4813 In the normal state, switch on the next character:
4815 if alphabetic, go to key lookup
4816 unrecognized character - croak
4817 - 0/4/26: handle end-of-line or EOF
4818 - cases for whitespace
4819 - \n and #: handle comments and line numbers
4820 - various operators, brackets and sigils
4823 - 'v': vstrings (or go to key lookup)
4824 - 'x' repetition operator (or go to key lookup)
4825 - other ASCII alphanumerics (key lookup begins here):
4828 scan built-in keyword (but do nothing with it yet)
4829 check for statement label
4830 check for lexical subs
4831 goto just_a_word if there is one
4832 see whether built-in keyword is overridden
4833 switch on keyword number:
4834 - default: just_a_word:
4835 not a built-in keyword; handle bareword lookup
4836 disambiguate between method and sub call
4837 fall back to bareword
4838 - cases for built-in keywords
4846 char *s = PL_bufptr;
4850 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4854 /* orig_keyword, gvp, and gv are initialized here because
4855 * jump to the label just_a_word_zero can bypass their
4856 * initialization later. */
4857 I32 orig_keyword = 0;
4861 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4862 const U8* first_bad_char_loc;
4863 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4864 PL_bufend - PL_bufptr,
4865 &first_bad_char_loc)))
4867 _force_out_malformed_utf8_message(first_bad_char_loc,
4870 1 /* 1 means die */ );
4871 NOT_REACHED; /* NOTREACHED */
4873 PL_parser->recheck_utf8_validity = FALSE;
4876 SV* tmp = newSVpvs("");
4877 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4878 (IV)CopLINE(PL_curcop),
4879 lex_state_names[PL_lex_state],
4880 exp_name[PL_expect],
4881 pv_display(tmp, s, strlen(s), 0, 60));
4885 /* when we've already built the next token, just pull it out of the queue */
4888 pl_yylval = PL_nextval[PL_nexttoke];
4891 next_type = PL_nexttype[PL_nexttoke];
4892 if (next_type & (7<<24)) {
4893 if (next_type & (1<<24)) {
4894 if (PL_lex_brackets > 100)
4895 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4896 PL_lex_brackstack[PL_lex_brackets++] =
4897 (char) ((next_type >> 16) & 0xff);
4899 if (next_type & (2<<24))
4900 PL_lex_allbrackets++;
4901 if (next_type & (4<<24))
4902 PL_lex_allbrackets--;
4903 next_type &= 0xffff;
4905 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4909 switch (PL_lex_state) {
4911 case LEX_INTERPNORMAL:
4914 /* interpolated case modifiers like \L \U, including \Q and \E.
4915 when we get here, PL_bufptr is at the \
4917 case LEX_INTERPCASEMOD:
4919 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4921 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4922 PL_bufptr, PL_bufend, *PL_bufptr);
4924 /* handle \E or end of string */
4925 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4927 if (PL_lex_casemods) {
4928 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4929 PL_lex_casestack[PL_lex_casemods] = '\0';
4931 if (PL_bufptr != PL_bufend
4932 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4933 || oldmod == 'F')) {
4935 PL_lex_state = LEX_INTERPCONCAT;
4937 PL_lex_allbrackets--;
4940 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4941 /* Got an unpaired \E */
4942 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4943 "Useless use of \\E");
4945 if (PL_bufptr != PL_bufend)
4947 PL_lex_state = LEX_INTERPCONCAT;
4951 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4952 "### Saw case modifier\n"); });
4954 if (s[1] == '\\' && s[2] == 'E') {
4956 PL_lex_state = LEX_INTERPCONCAT;
4961 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
4962 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
4964 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4966 if ((*s == 'L' || *s == 'U' || *s == 'F')
4967 && (strpbrk(PL_lex_casestack, "LUF")))
4969 PL_lex_casestack[--PL_lex_casemods] = '\0';
4970 PL_lex_allbrackets--;
4973 if (PL_lex_casemods > 10)
4974 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4975 PL_lex_casestack[PL_lex_casemods++] = *s;
4976 PL_lex_casestack[PL_lex_casemods] = '\0';
4977 PL_lex_state = LEX_INTERPCONCAT;
4978 NEXTVAL_NEXTTOKE.ival = 0;
4979 force_next((2<<24)|'(');
4981 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4983 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4985 NEXTVAL_NEXTTOKE.ival = OP_LC;
4987 NEXTVAL_NEXTTOKE.ival = OP_UC;
4989 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4991 NEXTVAL_NEXTTOKE.ival = OP_FC;
4993 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4997 if (PL_lex_starts) {
5000 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5001 if (PL_lex_casemods == 1 && PL_lex_inpat)
5004 AopNOASSIGN(OP_CONCAT);
5010 case LEX_INTERPPUSH:
5011 return REPORT(sublex_push());
5013 case LEX_INTERPSTART:
5014 if (PL_bufptr == PL_bufend)
5015 return REPORT(sublex_done());
5016 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
5017 "### Interpolated variable\n"); });
5019 /* for /@a/, we leave the joining for the regex engine to do
5020 * (unless we're within \Q etc) */
5021 PL_lex_dojoin = (*PL_bufptr == '@'
5022 && (!PL_lex_inpat || PL_lex_casemods));
5023 PL_lex_state = LEX_INTERPNORMAL;
5024 if (PL_lex_dojoin) {
5025 NEXTVAL_NEXTTOKE.ival = 0;
5027 force_ident("\"", '$');
5028 NEXTVAL_NEXTTOKE.ival = 0;
5030 NEXTVAL_NEXTTOKE.ival = 0;
5031 force_next((2<<24)|'(');
5032 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
5035 /* Convert (?{...}) and friends to 'do {...}' */
5036 if (PL_lex_inpat && *PL_bufptr == '(') {
5037 PL_parser->lex_shared->re_eval_start = PL_bufptr;
5039 if (*PL_bufptr != '{')
5041 PL_expect = XTERMBLOCK;
5045 if (PL_lex_starts++) {
5047 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5048 if (!PL_lex_casemods && PL_lex_inpat)
5051 AopNOASSIGN(OP_CONCAT);
5055 case LEX_INTERPENDMAYBE:
5056 if (intuit_more(PL_bufptr, PL_bufend)) {
5057 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5063 if (PL_lex_dojoin) {
5064 const U8 dojoin_was = PL_lex_dojoin;
5065 PL_lex_dojoin = FALSE;
5066 PL_lex_state = LEX_INTERPCONCAT;
5067 PL_lex_allbrackets--;
5068 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
5070 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5071 && SvEVALED(PL_lex_repl))
5073 if (PL_bufptr != PL_bufend)
5074 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5077 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5078 re_eval_str. If the here-doc body’s length equals the previous
5079 value of re_eval_start, re_eval_start will now be null. So
5080 check re_eval_str as well. */
5081 if (PL_parser->lex_shared->re_eval_start
5082 || PL_parser->lex_shared->re_eval_str) {
5084 if (*PL_bufptr != ')')
5085 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5087 /* having compiled a (?{..}) expression, return the original
5088 * text too, as a const */
5089 if (PL_parser->lex_shared->re_eval_str) {
5090 sv = PL_parser->lex_shared->re_eval_str;
5091 PL_parser->lex_shared->re_eval_str = NULL;
5093 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5094 SvPV_shrink_to_cur(sv);
5096 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5097 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5098 NEXTVAL_NEXTTOKE.opval =
5099 newSVOP(OP_CONST, 0,
5102 PL_parser->lex_shared->re_eval_start = NULL;
5108 case LEX_INTERPCONCAT:
5110 if (PL_lex_brackets)
5111 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5112 (long) PL_lex_brackets);
5114 if (PL_bufptr == PL_bufend)
5115 return REPORT(sublex_done());
5117 /* m'foo' still needs to be parsed for possible (?{...}) */
5118 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5119 SV *sv = newSVsv(PL_linestr);
5121 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5125 int save_error_count = PL_error_count;
5127 s = scan_const(PL_bufptr);
5129 /* Set flag if this was a pattern and there were errors. op.c will
5130 * refuse to compile a pattern with this flag set. Otherwise, we
5131 * could get segfaults, etc. */
5132 if (PL_lex_inpat && PL_error_count > save_error_count) {
5133 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5136 PL_lex_state = LEX_INTERPCASEMOD;
5138 PL_lex_state = LEX_INTERPSTART;
5141 if (s != PL_bufptr) {
5142 NEXTVAL_NEXTTOKE = pl_yylval;
5145 if (PL_lex_starts++) {
5146 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5147 if (!PL_lex_casemods && PL_lex_inpat)
5150 AopNOASSIGN(OP_CONCAT);
5160 if (PL_parser->sub_error_count != PL_error_count) {
5161 /* There was an error parsing a formline, which tends to
5163 Unlike interpolated sub-parsing, we can't treat any of
5164 these as recoverable, so no need to check sub_no_recover.
5168 assert(PL_lex_formbrack);
5169 s = scan_formline(PL_bufptr);
5170 if (!PL_lex_formbrack)
5179 /* We really do *not* want PL_linestr ever becoming a COW. */
5180 assert (!SvIsCOW(PL_linestr));
5182 PL_oldoldbufptr = PL_oldbufptr;
5184 PL_parser->saw_infix_sigil = 0;
5186 if (PL_in_my == KEY_sigvar) {
5187 /* we expect the sigil and optional var name part of a
5188 * signature element here. Since a '$' is not necessarily
5189 * followed by a var name, handle it specially here; the general
5190 * yylex code would otherwise try to interpret whatever follows
5191 * as a var; e.g. ($, ...) would be seen as the var '$,'
5198 PL_bufptr = s; /* for error reporting */
5203 /* spot stuff that looks like an prototype */
5204 if (strchr("$:@%&*;\\[]", *s)) {
5205 yyerror("Illegal character following sigil in a subroutine signature");
5208 /* '$#' is banned, while '$ # comment' isn't */
5210 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5214 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5215 char *dest = PL_tokenbuf + 1;
5216 /* read var name, including sigil, into PL_tokenbuf */
5217 PL_tokenbuf[0] = sigil;
5218 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5219 0, cBOOL(UTF), FALSE, FALSE);
5221 assert(PL_tokenbuf[1]); /* we have a variable name */
5229 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
5230 * as the ASSIGNOP, and exclude other tokens that start with =
5232 if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
5233 /* save now to report with the same context as we did when
5234 * all ASSIGNOPS were accepted */
5238 NEXTVAL_NEXTTOKE.ival = 0;
5239 force_next(ASSIGNOP);
5242 else if (*s == ',' || *s == ')') {
5243 PL_expect = XOPERATOR;
5246 /* make sure the context shows the unexpected character and
5247 * hopefully a bit more */
5249 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5251 PL_bufptr = s; /* for error reporting */
5252 yyerror("Illegal operator following parameter in a subroutine signature");
5256 NEXTVAL_NEXTTOKE.ival = sigil;
5257 force_next('p'); /* force a signature pending identifier */
5264 case ',': /* handle ($a,,$b) */
5269 yyerror("A signature parameter must start with '$', '@' or '%'");
5270 /* very crude error recovery: skip to likely next signature
5272 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5283 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5287 else if (isALNUMC(*s)) {
5291 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5294 STRLEN skiplen = UTF8SKIP(s);
5295 STRLEN stravail = PL_bufend - s;
5296 c = sv_uni_display(dsv, newSVpvn_flags(s,
5297 skiplen > stravail ? stravail : skiplen,
5298 SVs_TEMP | SVf_UTF8),
5299 10, UNI_DISPLAY_ISPRINT);
5302 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5305 if (s >= PL_linestart) {
5309 /* somehow (probably due to a parse failure), PL_linestart has advanced
5310 * pass PL_bufptr, get a reasonable beginning of line
5313 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
5316 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
5317 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5318 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
5321 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5322 UTF8fARG(UTF, (s - d), d),
5327 goto fake_eof; /* emulate EOF on ^D or ^Z */
5329 if ((!PL_rsfp || PL_lex_inwhat)
5330 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5334 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5336 yyerror((const char *)
5338 ? "Format not terminated"
5339 : "Missing right curly or square bracket"));
5341 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5342 "### Tokener got EOF\n");
5346 if (s++ < PL_bufend)
5347 goto retry; /* ignore stray nulls */
5350 if (!PL_in_eval && !PL_preambled) {
5351 PL_preambled = TRUE;
5353 /* Generate a string of Perl code to load the debugger.
5354 * If PERL5DB is set, it will return the contents of that,
5355 * otherwise a compile-time require of perl5db.pl. */
5357 const char * const pdb = PerlEnv_getenv("PERL5DB");
5360 sv_setpv(PL_linestr, pdb);
5361 sv_catpvs(PL_linestr,";");
5363 SETERRNO(0,SS_NORMAL);
5364 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5366 PL_parser->preambling = CopLINE(PL_curcop);
5368 SvPVCLEAR(PL_linestr);
5369 if (PL_preambleav) {
5370 SV **svp = AvARRAY(PL_preambleav);
5371 SV **const end = svp + AvFILLp(PL_preambleav);
5373 sv_catsv(PL_linestr, *svp);
5375 sv_catpvs(PL_linestr, ";");
5377 sv_free(MUTABLE_SV(PL_preambleav));
5378 PL_preambleav = NULL;
5381 sv_catpvs(PL_linestr,
5382 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5383 if (PL_minus_n || PL_minus_p) {
5384 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5386 sv_catpvs(PL_linestr,"chomp;");
5389 if ( ( *PL_splitstr == '/'
5390 || *PL_splitstr == '\''
5391 || *PL_splitstr == '"')
5392 && strchr(PL_splitstr + 1, *PL_splitstr))
5394 /* strchr is ok, because -F pattern can't contain
5396 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5399 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5400 bytes can be used as quoting characters. :-) */
5401 const char *splits = PL_splitstr;
5402 sv_catpvs(PL_linestr, "our @F=split(q\0");
5405 if (*splits == '\\')
5406 sv_catpvn(PL_linestr, splits, 1);
5407 sv_catpvn(PL_linestr, splits, 1);
5408 } while (*splits++);
5409 /* This loop will embed the trailing NUL of
5410 PL_linestr as the last thing it does before
5412 sv_catpvs(PL_linestr, ");");
5416 sv_catpvs(PL_linestr,"our @F=split(' ');");
5419 sv_catpvs(PL_linestr, "\n");
5420 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5421 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5422 PL_last_lop = PL_last_uni = NULL;
5423 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5424 update_debugger_info(PL_linestr, NULL, 0);
5429 bof = cBOOL(PL_rsfp);
5432 fake_eof = LEX_FAKE_EOF;
5434 PL_bufptr = PL_bufend;
5435 COPLINE_INC_WITH_HERELINES;
5436 if (!lex_next_chunk(fake_eof)) {
5437 CopLINE_dec(PL_curcop);
5439 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5441 CopLINE_dec(PL_curcop);
5443 /* If it looks like the start of a BOM or raw UTF-16,
5444 * check if it in fact is. */
5447 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5451 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5452 bof = (offset == (Off_t)SvCUR(PL_linestr));
5453 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5454 /* offset may include swallowed CR */
5456 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5459 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5460 s = swallow_bom((U8*)s);
5463 if (PL_parser->in_pod) {
5464 /* Incest with pod. */
5465 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
5468 SvPVCLEAR(PL_linestr);
5469 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5470 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5471 PL_last_lop = PL_last_uni = NULL;
5472 PL_parser->in_pod = 0;
5475 if (PL_rsfp || PL_parser->filtered)
5476 incline(s, PL_bufend);
5477 } while (PL_parser->in_pod);
5478 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5479 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5480 PL_last_lop = PL_last_uni = NULL;
5481 if (CopLINE(PL_curcop) == 1) {
5482 while (s < PL_bufend && isSPACE(*s))
5484 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5488 if (*s == '#' && *(s+1) == '!')
5490 #ifdef ALTERNATE_SHEBANG
5492 static char const as[] = ALTERNATE_SHEBANG;
5493 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5494 d = s + (sizeof(as) - 1);
5496 #endif /* ALTERNATE_SHEBANG */
5505 while (*d && !isSPACE(*d))
5509 #ifdef ARG_ZERO_IS_SCRIPT
5510 if (ipathend > ipath) {
5512 * HP-UX (at least) sets argv[0] to the script name,
5513 * which makes $^X incorrect. And Digital UNIX and Linux,
5514 * at least, set argv[0] to the basename of the Perl
5515 * interpreter. So, having found "#!", we'll set it right.
5517 SV* copfilesv = CopFILESV(PL_curcop);
5520 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5522 assert(SvPOK(x) || SvGMAGICAL(x));
5523 if (sv_eq(x, copfilesv)) {
5524 sv_setpvn(x, ipath, ipathend - ipath);
5530 const char *bstart = SvPV_const(copfilesv, blen);
5531 const char * const lstart = SvPV_const(x, llen);
5533 bstart += blen - llen;
5534 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5535 sv_setpvn(x, ipath, ipathend - ipath);
5542 /* Anything to do if no copfilesv? */
5544 TAINT_NOT; /* $^X is always tainted, but that's OK */
5546 #endif /* ARG_ZERO_IS_SCRIPT */
5551 d = instr(s,"perl -");
5553 d = instr(s,"perl");
5555 /* avoid getting into infinite loops when shebang
5556 * line contains "Perl" rather than "perl" */
5558 for (d = ipathend-4; d >= ipath; --d) {
5559 if (isALPHA_FOLD_EQ(*d, 'p')
5560 && !ibcmp(d, "perl", 4))
5570 #ifdef ALTERNATE_SHEBANG
5572 * If the ALTERNATE_SHEBANG on this system starts with a
5573 * character that can be part of a Perl expression, then if
5574 * we see it but not "perl", we're probably looking at the
5575 * start of Perl code, not a request to hand off to some
5576 * other interpreter. Similarly, if "perl" is there, but
5577 * not in the first 'word' of the line, we assume the line
5578 * contains the start of the Perl program.
5580 if (d && *s != '#') {
5581 const char *c = ipath;
5582 while (*c && !strchr("; \t\r\n\f\v#", *c))
5585 d = NULL; /* "perl" not in first word; ignore */
5587 *s = '#'; /* Don't try to parse shebang line */
5589 #endif /* ALTERNATE_SHEBANG */
5594 && !instr(s,"indir")
5595 && instr(PL_origargv[0],"perl"))
5602 while (s < PL_bufend && isSPACE(*s))
5604 if (s < PL_bufend) {
5605 Newx(newargv,PL_origargc+3,char*);
5607 while (s < PL_bufend && !isSPACE(*s))
5610 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5613 newargv = PL_origargv;
5616 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5618 Perl_croak(aTHX_ "Can't exec %s", ipath);
5621 while (*d && !isSPACE(*d))
5623 while (SPACE_OR_TAB(*d))
5627 const bool switches_done = PL_doswitches;
5628 const U32 oldpdb = PL_perldb;
5629 const bool oldn = PL_minus_n;
5630 const bool oldp = PL_minus_p;
5634 bool baduni = FALSE;
5636 const char *d2 = d1 + 1;
5637 if (parse_unicode_opts((const char **)&d2)
5641 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5642 const char * const m = d1;
5643 while (*d1 && !isSPACE(*d1))
5645 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5648 d1 = moreswitches(d1);
5650 if (PL_doswitches && !switches_done) {
5651 int argc = PL_origargc;
5652 char **argv = PL_origargv;
5655 } while (argc && argv[0][0] == '-' && argv[0][1]);
5656 init_argv_symbols(argc,argv);
5658 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5659 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5660 /* if we have already added "LINE: while (<>) {",
5661 we must not do it again */
5663 SvPVCLEAR(PL_linestr);
5664 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5665 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5666 PL_last_lop = PL_last_uni = NULL;
5667 PL_preambled = FALSE;
5668 if (PERLDB_LINE_OR_SAVESRC)
5669 (void)gv_fetchfile(PL_origfilename);
5676 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5677 PL_lex_state = LEX_FORMLINE;
5678 force_next(FORMRBRACK);
5683 #ifdef PERL_STRICT_CR
5684 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5686 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5688 case ' ': case '\t': case '\f': case '\v':
5693 if (PL_lex_state != LEX_NORMAL
5694 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5696 const bool in_comment = *s == '#';
5697 if (*s == '#' && s == PL_linestart && PL_in_eval
5698 && !PL_rsfp && !PL_parser->filtered) {
5699 /* handle eval qq[#line 1 "foo"\n ...] */
5700 CopLINE_dec(PL_curcop);
5701 incline(s, PL_bufend);
5704 while (d < PL_bufend && *d != '\n')
5709 if (in_comment && d == PL_bufend
5710 && PL_lex_state == LEX_INTERPNORMAL
5711 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5712 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5714 incline(s, PL_bufend);
5715 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5716 PL_lex_state = LEX_FORMLINE;
5717 force_next(FORMRBRACK);
5722 while (s < PL_bufend && *s != '\n')
5728 incline(s, PL_bufend);
5733 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5741 while (s < PL_bufend && SPACE_OR_TAB(*s))
5744 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5745 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5746 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5747 OPERATOR('-'); /* unary minus */
5750 case 'r': ftst = OP_FTEREAD; break;
5751 case 'w': ftst = OP_FTEWRITE; break;
5752 case 'x': ftst = OP_FTEEXEC; break;
5753 case 'o': ftst = OP_FTEOWNED; break;
5754 case 'R': ftst = OP_FTRREAD; break;
5755 case 'W': ftst = OP_FTRWRITE; break;
5756 case 'X': ftst = OP_FTREXEC; break;
5757 case 'O': ftst = OP_FTROWNED; break;
5758 case 'e': ftst = OP_FTIS; break;
5759 case 'z': ftst = OP_FTZERO; break;
5760 case 's': ftst = OP_FTSIZE; break;
5761 case 'f': ftst = OP_FTFILE; break;
5762 case 'd': ftst = OP_FTDIR; break;
5763 case 'l': ftst = OP_FTLINK; break;
5764 case 'p': ftst = OP_FTPIPE; break;
5765 case 'S': ftst = OP_FTSOCK; break;
5766 case 'u': ftst = OP_FTSUID; break;
5767 case 'g': ftst = OP_FTSGID; break;
5768 case 'k': ftst = OP_FTSVTX; break;
5769 case 'b': ftst = OP_FTBLK; break;
5770 case 'c': ftst = OP_FTCHR; break;
5771 case 't': ftst = OP_FTTTY; break;
5772 case 'T': ftst = OP_FTTEXT; break;
5773 case 'B': ftst = OP_FTBINARY; break;
5774 case 'M': case 'A': case 'C':
5775 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5777 case 'M': ftst = OP_FTMTIME; break;
5778 case 'A': ftst = OP_FTATIME; break;
5779 case 'C': ftst = OP_FTCTIME; break;
5787 PL_last_uni = PL_oldbufptr;
5788 PL_last_lop_op = (OPCODE)ftst;
5789 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5790 "### Saw file test %c\n", (int)tmp);
5795 /* Assume it was a minus followed by a one-letter named
5796 * subroutine call (or a -bareword), then. */
5797 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5798 "### '-%c' looked like a file test but was not\n",
5805 const char tmp = *s++;
5808 if (PL_expect == XOPERATOR)
5813 else if (*s == '>') {
5816 if (((*s == '$' || *s == '&') && s[1] == '*')
5817 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5818 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5819 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5822 PL_expect = XPOSTDEREF;
5825 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5826 s = force_word(s,METHOD,FALSE,TRUE);
5834 if (PL_expect == XOPERATOR) {
5836 && !PL_lex_allbrackets
5837 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5845 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5847 OPERATOR('-'); /* unary minus */
5853 const char tmp = *s++;
5856 if (PL_expect == XOPERATOR)
5861 if (PL_expect == XOPERATOR) {
5863 && !PL_lex_allbrackets
5864 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5872 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5879 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5880 if (PL_expect != XOPERATOR) {
5881 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5882 PL_expect = XOPERATOR;
5883 force_ident(PL_tokenbuf, '*');
5891 if (*s == '=' && !PL_lex_allbrackets
5892 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5900 && !PL_lex_allbrackets
5901 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5906 PL_parser->saw_infix_sigil = 1;
5911 if (PL_expect == XOPERATOR) {
5913 && !PL_lex_allbrackets
5914 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5919 PL_parser->saw_infix_sigil = 1;
5922 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5923 PL_tokenbuf[0] = '%';
5924 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5926 if (!PL_tokenbuf[1]) {
5929 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5930 && intuit_more(s, PL_bufend)) {
5932 PL_tokenbuf[0] = '@';
5934 PL_expect = XOPERATOR;
5935 force_ident_maybe_lex('%');
5940 bof = FEATURE_BITWISE_IS_ENABLED;
5941 if (bof && s[1] == '.')
5943 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5944 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5950 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5952 if (PL_lex_brackets > 100)
5953 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5954 PL_lex_brackstack[PL_lex_brackets++] = 0;
5955 PL_lex_allbrackets++;
5957 const char tmp = *s++;
5962 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5964 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5967 Perl_ck_warner_d(aTHX_
5968 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5969 "Smartmatch is experimental");
5973 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5975 BCop(OP_SCOMPLEMENT);
5977 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5979 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5986 goto just_a_word_zero_gv;
5992 switch (PL_expect) {
5994 if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
5996 PL_bufptr = s; /* update in case we back off */
5999 "Use of := for an empty attribute list is not allowed");
6006 PL_expect = XTERMBLOCK;
6008 /* NB: as well as parsing normal attributes, we also end up
6009 * here if there is something looking like attributes
6010 * following a signature (which is illegal, but used to be
6011 * legal in 5.20..5.26). If the latter, we still parse the
6012 * attributes so that error messages(s) are less confusing,
6013 * but ignore them (parser->sig_seen).
6017 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6018 bool sig = PL_parser->sig_seen;
6021 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6022 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
6023 if (tmp < 0) tmp = -tmp;
6038 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
6040 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
6045 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
6047 COPLINE_SET_FROM_MULTI_END;
6050 sv_catsv(sv, PL_lex_stuff);
6051 attrs = op_append_elem(OP_LIST, attrs,
6052 newSVOP(OP_CONST, 0, sv));
6053 SvREFCNT_dec_NN(PL_lex_stuff);
6054 PL_lex_stuff = NULL;
6057 /* NOTE: any CV attrs applied here need to be part of
6058 the CVf_BUILTIN_ATTRS define in cv.h! */
6059 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
6062 CvLVALUE_on(PL_compcv);
6064 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
6067 CvMETHOD_on(PL_compcv);
6069 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
6073 Perl_ck_warner_d(aTHX_
6074 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
6075 ":const is experimental"
6077 CvANONCONST_on(PL_compcv);
6078 if (!CvANON(PL_compcv))
6079 yyerror(":const is not permitted on named "
6083 /* After we've set the flags, it could be argued that
6084 we don't need to do the attributes.pm-based setting
6085 process, and shouldn't bother appending recognized
6086 flags. To experiment with that, uncomment the
6087 following "else". (Note that's already been
6088 uncommented. That keeps the above-applied built-in
6089 attributes from being intercepted (and possibly
6090 rejected) by a package's attribute routines, but is
6091 justified by the performance win for the common case
6092 of applying only built-in attributes.) */
6094 attrs = op_append_elem(OP_LIST, attrs,
6095 newSVOP(OP_CONST, 0,
6099 if (*s == ':' && s[1] != ':')
6102 break; /* require real whitespace or :'s */
6103 /* XXX losing whitespace on sequential attributes here */
6108 && !(PL_expect == XOPERATOR
6109 ? (*s == '=' || *s == ')')
6110 : (*s == '{' || *s == '(')))
6112 const char q = ((*s == '\'') ? '"' : '\'');
6113 /* If here for an expression, and parsed no attrs, back
6115 if (PL_expect == XOPERATOR && !attrs) {
6119 /* MUST advance bufptr here to avoid bogus "at end of line"
6120 context messages from yyerror().
6123 yyerror( (const char *)
6125 ? Perl_form(aTHX_ "Invalid separator character "
6126 "%c%c%c in attribute list", q, *s, q)
6127 : "Unterminated attribute list" ) );
6134 if (PL_parser->sig_seen) {
6135 /* see comment about about sig_seen and parser error
6139 Perl_croak(aTHX_ "Subroutine attributes must come "
6140 "before the signature");
6143 NEXTVAL_NEXTTOKE.opval = attrs;
6149 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6153 PL_lex_allbrackets--;
6157 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6158 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6162 PL_lex_allbrackets++;
6165 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6172 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6175 PL_lex_allbrackets--;
6181 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6184 if (PL_lex_brackets <= 0)
6185 /* diag_listed_as: Unmatched right %s bracket */
6186 yyerror("Unmatched right square bracket");
6189 PL_lex_allbrackets--;
6190 if (PL_lex_state == LEX_INTERPNORMAL) {
6191 if (PL_lex_brackets == 0) {
6192 if (*s == '-' && s[1] == '>')
6193 PL_lex_state = LEX_INTERPENDMAYBE;
6194 else if (*s != '[' && *s != '{')
6195 PL_lex_state = LEX_INTERPEND;
6202 if (PL_lex_brackets > 100) {
6203 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6205 switch (PL_expect) {
6208 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6209 PL_lex_allbrackets++;
6210 OPERATOR(HASHBRACK);
6212 while (s < PL_bufend && SPACE_OR_TAB(*s))
6215 PL_tokenbuf[0] = '\0';
6216 if (d < PL_bufend && *d == '-') {
6217 PL_tokenbuf[0] = '-';
6219 while (d < PL_bufend && SPACE_OR_TAB(*d))
6222 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6223 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6225 while (d < PL_bufend && SPACE_OR_TAB(*d))
6228 const char minus = (PL_tokenbuf[0] == '-');
6229 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6237 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6238 PL_lex_allbrackets++;
6243 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6244 PL_lex_allbrackets++;
6248 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6249 PL_lex_allbrackets++;
6254 if (PL_oldoldbufptr == PL_last_lop)
6255 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6257 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6258 PL_lex_allbrackets++;
6261 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6263 /* This hack is to get the ${} in the message. */
6265 yyerror("syntax error");
6268 OPERATOR(HASHBRACK);
6270 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6271 /* ${...} or @{...} etc., but not print {...}
6272 * Skip the disambiguation and treat this as a block.
6274 goto block_expectation;
6276 /* This hack serves to disambiguate a pair of curlies
6277 * as being a block or an anon hash. Normally, expectation
6278 * determines that, but in cases where we're not in a
6279 * position to expect anything in particular (like inside
6280 * eval"") we have to resolve the ambiguity. This code
6281 * covers the case where the first term in the curlies is a
6282 * quoted string. Most other cases need to be explicitly
6283 * disambiguated by prepending a "+" before the opening
6284 * curly in order to force resolution as an anon hash.
6286 * XXX should probably propagate the outer expectation
6287 * into eval"" to rely less on this hack, but that could
6288 * potentially break current behavior of eval"".
6292 if (*s == '\'' || *s == '"' || *s == '`') {
6293 /* common case: get past first string, handling escapes */
6294 for (t++; t < PL_bufend && *t != *s;)
6299 else if (*s == 'q') {
6302 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6303 && !isWORDCHAR(*t))))
6305 /* skip q//-like construct */
6307 char open, close, term;
6310 while (t < PL_bufend && isSPACE(*t))
6312 /* check for q => */
6313 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6314 OPERATOR(HASHBRACK);
6318 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6322 for (t++; t < PL_bufend; t++) {
6323 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6325 else if (*t == open)
6329 for (t++; t < PL_bufend; t++) {
6330 if (*t == '\\' && t+1 < PL_bufend)
6332 else if (*t == close && --brackets <= 0)
6334 else if (*t == open)
6341 /* skip plain q word */
6342 while ( t < PL_bufend
6343 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6345 t += UTF ? UTF8SKIP(t) : 1;
6348 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6349 t += UTF ? UTF8SKIP(t) : 1;
6350 while ( t < PL_bufend
6351 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6353 t += UTF ? UTF8SKIP(t) : 1;
6356 while (t < PL_bufend && isSPACE(*t))
6358 /* if comma follows first term, call it an anon hash */
6359 /* XXX it could be a comma expression with loop modifiers */
6360 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6361 || (*t == '=' && t[1] == '>')))
6362 OPERATOR(HASHBRACK);
6363 if (PL_expect == XREF)
6366 /* If there is an opening brace or 'sub:', treat it
6367 as a term to make ${{...}}{k} and &{sub:attr...}
6368 dwim. Otherwise, treat it as a statement, so
6369 map {no strict; ...} works.
6376 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6389 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6395 pl_yylval.ival = CopLINE(PL_curcop);
6396 PL_copline = NOLINE; /* invalidate current command line number */
6397 TOKEN(formbrack ? '=' : '{');
6399 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6402 assert(s != PL_bufend);
6404 if (PL_lex_brackets <= 0)
6405 /* diag_listed_as: Unmatched right %s bracket */
6406 yyerror("Unmatched right curly bracket");
6408 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6409 PL_lex_allbrackets--;
6410 if (PL_lex_state == LEX_INTERPNORMAL) {
6411 if (PL_lex_brackets == 0) {
6412 if (PL_expect & XFAKEBRACK) {
6413 PL_expect &= XENUMMASK;
6414 PL_lex_state = LEX_INTERPEND;
6416 return yylex(); /* ignore fake brackets */
6418 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6419 && SvEVALED(PL_lex_repl))
6420 PL_lex_state = LEX_INTERPEND;
6421 else if (*s == '-' && s[1] == '>')
6422 PL_lex_state = LEX_INTERPENDMAYBE;
6423 else if (*s != '[' && *s != '{')
6424 PL_lex_state = LEX_INTERPEND;
6427 if (PL_expect & XFAKEBRACK) {
6428 PL_expect &= XENUMMASK;
6430 return yylex(); /* ignore fake brackets */
6432 force_next(formbrack ? '.' : '}');
6433 if (formbrack) LEAVE_with_name("lex_format");
6434 if (formbrack == 2) { /* means . where arguments were expected */
6440 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6443 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6444 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6451 if (PL_expect == XOPERATOR) {
6452 if ( PL_bufptr == PL_linestart
6453 && ckWARN(WARN_SEMICOLON)
6454 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6456 CopLINE_dec(PL_curcop);
6457 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6458 CopLINE_inc(PL_curcop);
6461 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6463 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6464 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6470 PL_parser->saw_infix_sigil = 1;
6471 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6477 PL_tokenbuf[0] = '&';
6478 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6479 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6480 if (PL_tokenbuf[1]) {
6481 force_ident_maybe_lex('&');
6490 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6491 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6499 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6501 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6502 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6506 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6510 const char tmp = *s++;
6512 if ( (s == PL_linestart+2 || s[-3] == '\n')
6513 && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
6515 s = vcs_conflict_marker(s + 5);
6518 if (!PL_lex_allbrackets
6519 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6527 if (!PL_lex_allbrackets
6528 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6537 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6538 && strchr("+-*/%.^&|<",tmp))
6539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6540 "Reversed %c= operator",(int)tmp);
6542 if (PL_expect == XSTATE
6544 && (s == PL_linestart+1 || s[-2] == '\n') )
6546 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6547 || PL_lex_state != LEX_NORMAL)
6552 incline(s, PL_bufend);
6553 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
6555 s = (char *) memchr(s,'\n', d - s);
6560 incline(s, PL_bufend);
6568 PL_parser->in_pod = 1;
6572 if (PL_expect == XBLOCK) {
6574 #ifdef PERL_STRICT_CR
6575 while (SPACE_OR_TAB(*t))
6577 while (SPACE_OR_TAB(*t) || *t == '\r')
6580 if (*t == '\n' || *t == '#') {
6582 ENTER_with_name("lex_format");
6583 SAVEI8(PL_parser->form_lex_state);
6584 SAVEI32(PL_lex_formbrack);
6585 PL_parser->form_lex_state = PL_lex_state;
6586 PL_lex_formbrack = PL_lex_brackets + 1;
6587 PL_parser->sub_error_count = PL_error_count;
6591 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6600 const char tmp = *s++;
6602 /* was this !=~ where !~ was meant?
6603 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6605 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6606 const char *t = s+1;
6608 while (t < PL_bufend && isSPACE(*t))
6611 if (*t == '/' || *t == '?'
6612 || ((*t == 'm' || *t == 's' || *t == 'y')
6613 && !isWORDCHAR(t[1]))
6614 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6615 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6616 "!=~ should be !~");
6618 if (!PL_lex_allbrackets
6619 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6632 if (PL_expect != XOPERATOR) {
6633 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6635 if (s[1] == '<' && s[2] != '>') {
6636 if ( (s == PL_linestart || s[-1] == '\n')
6637 && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
6639 s = vcs_conflict_marker(s + 7);
6642 s = scan_heredoc(s);
6645 s = scan_inputsymbol(s);
6646 PL_expect = XOPERATOR;
6647 TOKEN(sublex_start());
6653 if ( (s == PL_linestart+2 || s[-3] == '\n')
6654 && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
6656 s = vcs_conflict_marker(s + 5);
6659 if (*s == '=' && !PL_lex_allbrackets
6660 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6665 SHop(OP_LEFT_SHIFT);
6670 if (!PL_lex_allbrackets
6671 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6679 if (!PL_lex_allbrackets
6680 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6689 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6697 const char tmp = *s++;
6699 if ( (s == PL_linestart+2 || s[-3] == '\n')
6700 && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
6702 s = vcs_conflict_marker(s + 5);
6705 if (*s == '=' && !PL_lex_allbrackets
6706 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6711 SHop(OP_RIGHT_SHIFT);
6713 else if (tmp == '=') {
6714 if (!PL_lex_allbrackets
6715 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6724 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6733 if (PL_expect == XPOSTDEREF) {
6736 POSTDEREF(DOLSHARP);
6742 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6743 || strchr("{$:+-@", s[2])))
6745 PL_tokenbuf[0] = '@';
6746 s = scan_ident(s + 1, PL_tokenbuf + 1,
6747 sizeof PL_tokenbuf - 1, FALSE);
6748 if (PL_expect == XOPERATOR) {
6750 if (PL_bufptr > s) {
6752 PL_bufptr = PL_oldbufptr;
6754 no_op("Array length", d);
6756 if (!PL_tokenbuf[1])
6758 PL_expect = XOPERATOR;
6759 force_ident_maybe_lex('#');
6763 PL_tokenbuf[0] = '$';
6764 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6765 if (PL_expect == XOPERATOR) {
6767 if (PL_bufptr > s) {
6769 PL_bufptr = PL_oldbufptr;
6773 if (!PL_tokenbuf[1]) {
6775 yyerror("Final $ should be \\$ or $name");
6781 const char tmp = *s;
6782 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6785 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6786 && intuit_more(s, PL_bufend)) {
6788 PL_tokenbuf[0] = '@';
6789 if (ckWARN(WARN_SYNTAX)) {
6793 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6796 t += UTF ? UTF8SKIP(t) : 1;
6799 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6800 while (t < PL_bufend && *t != ']')
6802 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6803 "Multidimensional syntax %" UTF8f " not supported",
6804 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6808 else if (*s == '{') {
6810 PL_tokenbuf[0] = '%';
6811 if ( strEQ(PL_tokenbuf+1, "SIG")
6812 && ckWARN(WARN_SYNTAX)
6813 && (t = (char *) memchr(s, '}', PL_bufend - s))
6814 && (t = (char *) memchr(t, '=', PL_bufend - t)))
6816 char tmpbuf[sizeof PL_tokenbuf];
6819 } while (isSPACE(*t));
6820 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6822 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6827 && get_cvn_flags(tmpbuf, len, UTF
6831 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6832 "You need to quote \"%" UTF8f "\"",
6833 UTF8fARG(UTF, len, tmpbuf));
6840 PL_expect = XOPERATOR;
6841 if ((PL_lex_state == LEX_NORMAL || PL_lex_brackets) && isSPACE((char)tmp)) {
6842 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6843 if (!islop || PL_last_lop_op == OP_GREPSTART)
6844 PL_expect = XOPERATOR;
6845 else if (strchr("$@\"'`q", *s))
6846 PL_expect = XTERM; /* e.g. print $fh "foo" */
6847 else if ( strchr("&*<%", *s)
6848 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6850 PL_expect = XTERM; /* e.g. print $fh &sub */
6852 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6853 char tmpbuf[sizeof PL_tokenbuf];
6855 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6856 if ((t2 = keyword(tmpbuf, len, 0))) {
6857 /* binary operators exclude handle interpretations */
6869 PL_expect = XTERM; /* e.g. print $fh length() */
6874 PL_expect = XTERM; /* e.g. print $fh subr() */
6877 else if (isDIGIT(*s))
6878 PL_expect = XTERM; /* e.g. print $fh 3 */
6879 else if (*s == '.' && isDIGIT(s[1]))
6880 PL_expect = XTERM; /* e.g. print $fh .3 */
6881 else if ((*s == '?' || *s == '-' || *s == '+')
6882 && !isSPACE(s[1]) && s[1] != '=')
6883 PL_expect = XTERM; /* e.g. print $fh -1 */
6884 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6886 PL_expect = XTERM; /* e.g. print $fh /.../
6887 XXX except DORDOR operator
6889 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6891 PL_expect = XTERM; /* print $fh <<"EOF" */
6894 force_ident_maybe_lex('$');
6898 if (PL_expect == XPOSTDEREF)
6900 PL_tokenbuf[0] = '@';
6901 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6902 if (PL_expect == XOPERATOR) {
6904 if (PL_bufptr > s) {
6906 PL_bufptr = PL_oldbufptr;
6911 if (!PL_tokenbuf[1]) {
6914 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6916 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6917 && intuit_more(s, PL_bufend))
6920 PL_tokenbuf[0] = '%';
6922 /* Warn about @ where they meant $. */
6923 if (*s == '[' || *s == '{') {
6924 if (ckWARN(WARN_SYNTAX)) {
6925 S_check_scalar_slice(aTHX_ s);
6929 PL_expect = XOPERATOR;
6930 force_ident_maybe_lex('@');
6933 case '/': /* may be division, defined-or, or pattern */
6934 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6935 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6936 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6941 else if (PL_expect == XOPERATOR) {
6943 if (*s == '=' && !PL_lex_allbrackets
6944 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6952 /* Disable warning on "study /blah/" */
6953 if ( PL_oldoldbufptr == PL_last_uni
6954 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6955 || memNE(PL_last_uni, "study", 5)
6956 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6959 s = scan_pat(s,OP_MATCH);
6960 TERM(sublex_start());
6963 case '?': /* conditional */
6965 if (!PL_lex_allbrackets
6966 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6971 PL_lex_allbrackets++;
6975 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6976 #ifdef PERL_STRICT_CR
6979 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6981 && (s == PL_linestart || s[-1] == '\n') )
6984 formbrack = 2; /* dot seen where arguments expected */
6987 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6991 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6994 if (!PL_lex_allbrackets
6995 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
7003 pl_yylval.ival = OPf_SPECIAL;
7009 if (*s == '=' && !PL_lex_allbrackets
7010 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
7018 case '0': case '1': case '2': case '3': case '4':
7019 case '5': case '6': case '7': case '8': case '9':
7020 s = scan_num(s, &pl_yylval);
7021 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
7022 if (PL_expect == XOPERATOR)
7027 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7029 missingterm(NULL, 0);
7030 COPLINE_SET_FROM_MULTI_END;
7031 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
7032 if (PL_expect == XOPERATOR) {
7035 pl_yylval.ival = OP_CONST;
7036 TERM(sublex_start());
7039 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7042 printbuf("### Saw string before %s\n", s);
7044 PerlIO_printf(Perl_debug_log,
7045 "### Saw unterminated string\n");
7047 if (PL_expect == XOPERATOR) {
7051 missingterm(NULL, 0);
7052 pl_yylval.ival = OP_CONST;
7053 /* FIXME. I think that this can be const if char *d is replaced by
7054 more localised variables. */
7055 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
7056 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
7057 pl_yylval.ival = OP_STRINGIFY;
7061 if (pl_yylval.ival == OP_CONST)
7062 COPLINE_SET_FROM_MULTI_END;
7063 TERM(sublex_start());
7066 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7069 printbuf("### Saw backtick string before %s\n", s);
7071 PerlIO_printf(Perl_debug_log,
7072 "### Saw unterminated backtick string\n");
7074 if (PL_expect == XOPERATOR)
7075 no_op("Backticks",s);
7077 missingterm(NULL, 0);
7078 pl_yylval.ival = OP_BACKTICK;
7079 TERM(sublex_start());
7083 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
7085 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
7087 if (PL_expect == XOPERATOR)
7088 no_op("Backslash",s);
7092 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
7093 char *start = s + 2;
7094 while (isDIGIT(*start) || *start == '_')
7096 if (*start == '.' && isDIGIT(start[1])) {
7097 s = scan_num(s, &pl_yylval);
7100 else if ((*start == ':' && start[1] == ':')
7101 || (PL_expect == XSTATE && *start == ':'))
7103 else if (PL_expect == XSTATE) {
7105 while (d < PL_bufend && isSPACE(*d)) d++;
7106 if (*d == ':') goto keylookup;
7108 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
7109 if (!isALPHA(*start) && (PL_expect == XTERM
7110 || PL_expect == XREF || PL_expect == XSTATE
7111 || PL_expect == XTERMORDORDOR)) {
7112 GV *const gv = gv_fetchpvn_flags(s, start - s,
7113 UTF ? SVf_UTF8 : 0, SVt_PVCV);
7115 s = scan_num(s, &pl_yylval);
7122 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7175 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7177 /* Some keywords can be followed by any delimiter, including ':' */
7178 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7180 /* x::* is just a word, unless x is "CORE" */
7181 if (!anydelim && *s == ':' && s[1] == ':') {
7182 if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
7187 while (d < PL_bufend && isSPACE(*d))
7188 d++; /* no comments skipped here, or s### is misparsed */
7190 /* Is this a word before a => operator? */
7191 if (*d == '=' && d[1] == '>') {
7195 = newSVOP(OP_CONST, 0,
7196 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7197 pl_yylval.opval->op_private = OPpCONST_BARE;
7201 /* Check for plugged-in keyword */
7205 char *saved_bufptr = PL_bufptr;
7207 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7209 if (result == KEYWORD_PLUGIN_DECLINE) {
7210 /* not a plugged-in keyword */
7211 PL_bufptr = saved_bufptr;
7212 } else if (result == KEYWORD_PLUGIN_STMT) {
7213 pl_yylval.opval = o;
7215 if (!PL_nexttoke) PL_expect = XSTATE;
7216 return REPORT(PLUGSTMT);
7217 } else if (result == KEYWORD_PLUGIN_EXPR) {
7218 pl_yylval.opval = o;
7220 if (!PL_nexttoke) PL_expect = XOPERATOR;
7221 return REPORT(PLUGEXPR);
7223 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7228 /* Check for built-in keyword */
7229 tmp = keyword(PL_tokenbuf, len, 0);
7231 /* Is this a label? */
7232 if (!anydelim && PL_expect == XSTATE
7233 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7236 newSVOP(OP_CONST, 0,
7237 newSVpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0));
7242 /* Check for lexical sub */
7243 if (PL_expect != XOPERATOR) {
7244 char tmpbuf[sizeof PL_tokenbuf + 1];
7246 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7247 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7248 if (off != NOT_IN_PAD) {
7249 assert(off); /* we assume this is boolean-true below */
7250 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7251 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7252 HEK * const stashname = HvNAME_HEK(stash);
7253 sv = newSVhek(stashname);
7254 sv_catpvs(sv, "::");
7255 sv_catpvn_flags(sv, PL_tokenbuf, len,
7256 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7257 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7267 rv2cv_op = newOP(OP_PADANY, 0);
7268 rv2cv_op->op_targ = off;
7269 cv = find_lexical_cv(off);
7277 if (tmp < 0) { /* second-class keyword? */
7278 GV *ogv = NULL; /* override (winner) */
7279 GV *hgv = NULL; /* hidden (loser) */
7280 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7282 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7283 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7285 && (cv = GvCVu(gv)))
7287 if (GvIMPORTED_CV(gv))
7289 else if (! CvMETHOD(cv))
7293 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7296 && (isGV_with_GP(gv)
7297 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7298 : SvPCS_IMPORTED(gv)
7299 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7307 tmp = 0; /* overridden by import or by GLOBAL */
7310 && -tmp==KEY_lock /* XXX generalizable kludge */
7313 tmp = 0; /* any sub overrides "weak" keyword */
7315 else { /* no override */
7317 if (tmp == KEY_dump) {
7318 Perl_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
7322 if (hgv && tmp != KEY_x) /* never ambiguous */
7323 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7324 "Ambiguous call resolved as CORE::%s(), "
7325 "qualify as such or use &",
7330 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7331 && (!anydelim || *s != '#')) {
7332 /* no override, and not s### either; skipspace is safe here
7333 * check for => on following line */
7335 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7336 STRLEN soff = s - SvPVX(PL_linestr);
7338 arrow = *s == '=' && s[1] == '>';
7339 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7340 s = SvPVX(PL_linestr) + soff;
7348 /* Trade off - by using this evil construction we can pull the
7349 variable gv into the block labelled keylookup. If not, then
7350 we have to give it function scope so that the goto from the
7351 earlier ':' case doesn't bypass the initialisation. */
7352 just_a_word_zero_gv:
7362 default: /* not a keyword */
7365 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7367 bool no_op_error = FALSE;
7369 if (PL_expect == XOPERATOR) {
7370 if (PL_bufptr == PL_linestart) {
7371 CopLINE_dec(PL_curcop);
7372 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7373 CopLINE_inc(PL_curcop);
7376 /* We want to call no_op with s pointing after the
7377 bareword, so defer it. But we want it to come
7378 before the Bad name croak. */
7382 /* Get the rest if it looks like a package qualifier */
7384 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7386 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7389 no_op("Bareword",s);
7390 no_op_error = FALSE;
7393 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7394 UTF8fARG(UTF, len, PL_tokenbuf),
7395 *s == '\'' ? "'" : "::");
7401 no_op("Bareword",s);
7403 /* See if the name is "Foo::",
7404 in which case Foo is a bareword
7405 (and a package name). */
7408 && PL_tokenbuf[len - 2] == ':'
7409 && PL_tokenbuf[len - 1] == ':')
7411 if (ckWARN(WARN_BAREWORD)
7412 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7413 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7414 "Bareword \"%" UTF8f
7415 "\" refers to nonexistent package",
7416 UTF8fARG(UTF, len, PL_tokenbuf));
7418 PL_tokenbuf[len] = '\0';
7427 /* if we saw a global override before, get the right name */
7430 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7433 SV * const tmp_sv = sv;
7434 sv = newSVpvs("CORE::GLOBAL::");
7435 sv_catsv(sv, tmp_sv);
7436 SvREFCNT_dec(tmp_sv);
7440 /* Presume this is going to be a bareword of some sort. */
7442 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7443 pl_yylval.opval->op_private = OPpCONST_BARE;
7445 /* And if "Foo::", then that's what it certainly is. */
7451 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7452 const_op->op_private = OPpCONST_BARE;
7454 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7458 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7461 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7464 /* Use this var to track whether intuit_method has been
7465 called. intuit_method returns 0 or > 255. */
7468 /* See if it's the indirect object for a list operator. */
7471 && PL_oldoldbufptr < PL_bufptr
7472 && (PL_oldoldbufptr == PL_last_lop
7473 || PL_oldoldbufptr == PL_last_uni)
7474 && /* NO SKIPSPACE BEFORE HERE! */
7476 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7479 bool immediate_paren = *s == '(';
7482 /* (Now we can afford to cross potential line boundary.) */
7485 /* intuit_method() can indirectly call lex_next_chunk(),
7488 s_off = s - SvPVX(PL_linestr);
7489 /* Two barewords in a row may indicate method call. */
7490 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7492 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7494 /* the code at method: doesn't use s */
7497 s = SvPVX(PL_linestr) + s_off;
7499 /* If not a declared subroutine, it's an indirect object. */
7500 /* (But it's an indir obj regardless for sort.) */
7501 /* Also, if "_" follows a filetest operator, it's a bareword */
7504 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7506 && (PL_last_lop_op != OP_MAPSTART
7507 && PL_last_lop_op != OP_GREPSTART))))
7508 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7509 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7513 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7518 PL_expect = XOPERATOR;
7521 /* Is this a word before a => operator? */
7522 if (*s == '=' && s[1] == '>' && !pkgname) {
7525 if (gvp || (lex && !off)) {
7526 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7527 /* This is our own scalar, created a few lines
7528 above, so this is safe. */
7530 sv_setpv(sv, PL_tokenbuf);
7531 if (UTF && !IN_BYTES
7532 && is_utf8_string((U8*)PL_tokenbuf, len))
7539 /* If followed by a paren, it's certainly a subroutine. */
7544 while (SPACE_OR_TAB(*d))
7546 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7551 NEXTVAL_NEXTTOKE.opval =
7552 off ? rv2cv_op : pl_yylval.opval;
7554 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7555 else op_free(rv2cv_op), force_next(BAREWORD);
7560 /* If followed by var or block, call it a method (unless sub) */
7562 if ((*s == '$' || *s == '{') && !cv) {
7564 PL_last_lop = PL_oldbufptr;
7565 PL_last_lop_op = OP_METHOD;
7566 if (!PL_lex_allbrackets
7567 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7569 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7571 PL_expect = XBLOCKTERM;
7573 return REPORT(METHOD);
7576 /* If followed by a bareword, see if it looks like indir obj. */
7580 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7581 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7585 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7587 sv_setpvn(sv, PL_tokenbuf, len);
7588 if (UTF && !IN_BYTES
7589 && is_utf8_string((U8*)PL_tokenbuf, len))
7591 else SvUTF8_off(sv);
7594 if (tmp == METHOD && !PL_lex_allbrackets
7595 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7597 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7602 /* Not a method, so call it a subroutine (if defined) */
7605 /* Check for a constant sub */
7606 if ((sv = cv_const_sv_or_av(cv))) {
7609 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7610 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7611 if (SvTYPE(sv) == SVt_PVAV)
7612 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7615 pl_yylval.opval->op_private = 0;
7616 pl_yylval.opval->op_folded = 1;
7617 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7622 op_free(pl_yylval.opval);
7624 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7625 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7626 PL_last_lop = PL_oldbufptr;
7627 PL_last_lop_op = OP_ENTERSUB;
7628 /* Is there a prototype? */
7632 STRLEN protolen = CvPROTOLEN(cv);
7633 const char *proto = CvPROTO(cv);
7635 proto = S_strip_spaces(aTHX_ proto, &protolen);
7638 if ((optional = *proto == ';'))
7641 while (*proto == ';');
7645 *proto == '$' || *proto == '_'
7646 || *proto == '*' || *proto == '+'
7651 *proto == '\\' && proto[1] && proto[2] == '\0'
7654 UNIPROTO(UNIOPSUB,optional);
7655 if (*proto == '\\' && proto[1] == '[') {
7656 const char *p = proto + 2;
7657 while(*p && *p != ']')
7659 if(*p == ']' && !p[1])
7660 UNIPROTO(UNIOPSUB,optional);
7662 if (*proto == '&' && *s == '{') {
7664 sv_setpvs(PL_subname, "__ANON__");
7666 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7667 if (!PL_lex_allbrackets
7668 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7670 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7675 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7677 force_next(off ? PRIVATEREF : BAREWORD);
7678 if (!PL_lex_allbrackets
7679 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7681 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7686 /* Call it a bare word */
7688 if (PL_hints & HINT_STRICT_SUBS)
7689 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7692 /* after "print" and similar functions (corresponding to
7693 * "F? L" in opcode.pl), whatever wasn't already parsed as
7694 * a filehandle should be subject to "strict subs".
7695 * Likewise for the optional indirect-object argument to system
7696 * or exec, which can't be a bareword */
7697 if ((PL_last_lop_op == OP_PRINT
7698 || PL_last_lop_op == OP_PRTF
7699 || PL_last_lop_op == OP_SAY
7700 || PL_last_lop_op == OP_SYSTEM
7701 || PL_last_lop_op == OP_EXEC)
7702 && (PL_hints & HINT_STRICT_SUBS))
7703 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7704 if (lastchar != '-') {
7705 if (ckWARN(WARN_RESERVED)) {
7709 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7711 /* PL_warn_reserved is constant */
7712 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7713 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7715 GCC_DIAG_RESTORE_STMT;
7723 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7724 && saw_infix_sigil) {
7725 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7726 "Operator or semicolon missing before %c%" UTF8f,
7728 UTF8fARG(UTF, strlen(PL_tokenbuf),
7730 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7731 "Ambiguous use of %c resolved as operator %c",
7732 lastchar, lastchar);
7739 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7744 newSVOP(OP_CONST, 0,
7745 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7748 case KEY___PACKAGE__:
7750 newSVOP(OP_CONST, 0,
7752 ? newSVhek(HvNAME_HEK(PL_curstash))
7759 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7760 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7763 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7765 gv_init(gv,stash,"DATA",4,0);
7768 GvIOp(gv) = newIO();
7769 IoIFP(GvIOp(gv)) = PL_rsfp;
7770 /* Mark this internal pseudo-handle as clean */
7771 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7772 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7773 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7775 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7776 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7777 /* if the script was opened in binmode, we need to revert
7778 * it to text mode for compatibility; but only iff it has CRs
7779 * XXX this is a questionable hack at best. */
7780 if (PL_bufend-PL_bufptr > 2
7781 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7784 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7785 loc = PerlIO_tell(PL_rsfp);
7786 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7789 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7791 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7792 #endif /* NETWARE */
7794 PerlIO_seek(PL_rsfp, loc, 0);
7798 #ifdef PERLIO_LAYERS
7801 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7810 FUN0OP(CvCLONE(PL_compcv)
7811 ? newOP(OP_RUNCV, 0)
7812 : newPVOP(OP_RUNCV,0,NULL));
7821 if (PL_expect == XSTATE) {
7832 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7833 if ((*s == ':' && s[1] == ':')
7834 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7838 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7842 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7843 UTF8fARG(UTF, len, PL_tokenbuf));
7846 else if (tmp == KEY_require || tmp == KEY_do
7848 /* that's a way to remember we saw "CORE::" */
7860 LOP(OP_ACCEPT,XTERM);
7863 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7868 LOP(OP_ATAN2,XTERM);
7874 LOP(OP_BINMODE,XTERM);
7877 LOP(OP_BLESS,XTERM);
7886 /* We have to disambiguate the two senses of
7887 "continue". If the next token is a '{' then
7888 treat it as the start of a continue block;
7889 otherwise treat it as a control operator.
7899 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7909 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7918 if (!PL_cryptseen) {
7919 PL_cryptseen = TRUE;
7923 LOP(OP_CRYPT,XTERM);
7926 LOP(OP_CHMOD,XTERM);
7929 LOP(OP_CHOWN,XTERM);
7932 LOP(OP_CONNECT,XTERM);
7952 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7954 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
7955 && !keyword(PL_tokenbuf + 1, len, 0)) {
7956 SSize_t off = s-SvPVX(PL_linestr);
7958 s = SvPVX(PL_linestr)+off;
7960 force_ident_maybe_lex('&');
7965 if (orig_keyword == KEY_do) {
7974 PL_hints |= HINT_BLOCK_SCOPE;
7984 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7985 STR_WITH_LEN("NDBM_File::"),
7986 STR_WITH_LEN("DB_File::"),
7987 STR_WITH_LEN("GDBM_File::"),
7988 STR_WITH_LEN("SDBM_File::"),
7989 STR_WITH_LEN("ODBM_File::"),
7991 LOP(OP_DBMOPEN,XTERM);
8003 pl_yylval.ival = CopLINE(PL_curcop);
8007 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8019 if (*s == '{') { /* block eval */
8020 PL_expect = XTERMBLOCK;
8021 UNIBRACK(OP_ENTERTRY);
8023 else { /* string eval */
8025 UNIBRACK(OP_ENTEREVAL);
8030 UNIBRACK(-OP_ENTEREVAL);
8044 case KEY_endhostent:
8050 case KEY_endservent:
8053 case KEY_endprotoent:
8064 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8066 pl_yylval.ival = CopLINE(PL_curcop);
8068 if ( PL_expect == XSTATE
8069 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
8072 SSize_t s_off = s - SvPVX(PL_linestr);
8074 if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
8075 && isSPACE(*(p + 2)))
8079 else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
8080 && isSPACE(*(p + 3)))
8086 /* skip optional package name, as in "for my abc $x (..)" */
8087 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
8088 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8091 if (*p != '$' && *p != '\\')
8092 Perl_croak(aTHX_ "Missing $ on loop variable");
8094 /* The buffer may have been reallocated, update s */
8095 s = SvPVX(PL_linestr) + s_off;
8100 LOP(OP_FORMLINE,XTERM);
8109 LOP(OP_FCNTL,XTERM);
8115 LOP(OP_FLOCK,XTERM);
8118 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8123 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8128 LOP(OP_GREPSTART, XREF);
8145 case KEY_getpriority:
8146 LOP(OP_GETPRIORITY,XTERM);
8148 case KEY_getprotobyname:
8151 case KEY_getprotobynumber:
8152 LOP(OP_GPBYNUMBER,XTERM);
8154 case KEY_getprotoent:
8166 case KEY_getpeername:
8167 UNI(OP_GETPEERNAME);
8169 case KEY_gethostbyname:
8172 case KEY_gethostbyaddr:
8173 LOP(OP_GHBYADDR,XTERM);
8175 case KEY_gethostent:
8178 case KEY_getnetbyname:
8181 case KEY_getnetbyaddr:
8182 LOP(OP_GNBYADDR,XTERM);
8187 case KEY_getservbyname:
8188 LOP(OP_GSBYNAME,XTERM);
8190 case KEY_getservbyport:
8191 LOP(OP_GSBYPORT,XTERM);
8193 case KEY_getservent:
8196 case KEY_getsockname:
8197 UNI(OP_GETSOCKNAME);
8199 case KEY_getsockopt:
8200 LOP(OP_GSOCKOPT,XTERM);
8215 pl_yylval.ival = CopLINE(PL_curcop);
8216 Perl_ck_warner_d(aTHX_
8217 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8218 "given is experimental");
8223 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8231 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8233 pl_yylval.ival = CopLINE(PL_curcop);
8237 LOP(OP_INDEX,XTERM);
8243 LOP(OP_IOCTL,XTERM);
8270 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8275 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8289 LOP(OP_LISTEN,XTERM);
8298 s = scan_pat(s,OP_MATCH);
8299 TERM(sublex_start());
8302 LOP(OP_MAPSTART, XREF);
8305 LOP(OP_MKDIR,XTERM);
8308 LOP(OP_MSGCTL,XTERM);
8311 LOP(OP_MSGGET,XTERM);
8314 LOP(OP_MSGRCV,XTERM);
8317 LOP(OP_MSGSND,XTERM);
8324 yyerror(Perl_form(aTHX_
8325 "Can't redeclare \"%s\" in \"%s\"",
8326 tmp == KEY_my ? "my" :
8327 tmp == KEY_state ? "state" : "our",
8328 PL_in_my == KEY_my ? "my" :
8329 PL_in_my == KEY_state ? "state" : "our"));
8331 PL_in_my = (U16)tmp;
8333 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8334 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8335 if (memEQs(PL_tokenbuf, len, "sub"))
8337 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8338 if (!PL_in_my_stash) {
8342 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8343 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8344 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8347 else if (*s == '\\') {
8348 if (!FEATURE_MYREF_IS_ENABLED)
8349 Perl_croak(aTHX_ "The experimental declared_refs "
8350 "feature is not enabled");
8351 Perl_ck_warner_d(aTHX_
8352 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8353 "Declaring references is experimental");
8361 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8366 s = tokenize_use(0, s);
8370 if (*s == '(' || (s = skipspace(s), *s == '('))
8373 if (!PL_lex_allbrackets
8374 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8376 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8383 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8385 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8387 for (t=d; isSPACE(*t);)
8389 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8391 && !(t[0] == '=' && t[1] == '>')
8392 && !(t[0] == ':' && t[1] == ':')
8393 && !keyword(s, d-s, 0)
8395 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8396 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8397 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8403 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8405 pl_yylval.ival = OP_OR;
8415 LOP(OP_OPEN_DIR,XTERM);
8418 checkcomma(s,PL_tokenbuf,"filehandle");
8422 checkcomma(s,PL_tokenbuf,"filehandle");
8441 s = force_word(s,BAREWORD,FALSE,TRUE);
8443 s = force_strict_version(s);
8447 LOP(OP_PIPE_OP,XTERM);
8450 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8452 missingterm(NULL, 0);
8453 COPLINE_SET_FROM_MULTI_END;
8454 pl_yylval.ival = OP_CONST;
8455 TERM(sublex_start());
8462 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8464 missingterm(NULL, 0);
8465 COPLINE_SET_FROM_MULTI_END;
8466 PL_expect = XOPERATOR;
8467 if (SvCUR(PL_lex_stuff)) {
8468 int warned_comma = !ckWARN(WARN_QW);
8469 int warned_comment = warned_comma;
8470 d = SvPV_force(PL_lex_stuff, len);
8472 for (; isSPACE(*d) && len; --len, ++d)
8477 if (!warned_comma || !warned_comment) {
8478 for (; !isSPACE(*d) && len; --len, ++d) {
8479 if (!warned_comma && *d == ',') {
8480 Perl_warner(aTHX_ packWARN(WARN_QW),
8481 "Possible attempt to separate words with commas");
8484 else if (!warned_comment && *d == '#') {
8485 Perl_warner(aTHX_ packWARN(WARN_QW),
8486 "Possible attempt to put comments in qw() list");
8492 for (; !isSPACE(*d) && len; --len, ++d)
8495 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8496 words = op_append_elem(OP_LIST, words,
8497 newSVOP(OP_CONST, 0, tokeq(sv)));
8502 words = newNULLLIST();
8503 SvREFCNT_dec_NN(PL_lex_stuff);
8504 PL_lex_stuff = NULL;
8505 PL_expect = XOPERATOR;
8506 pl_yylval.opval = sawparens(words);
8511 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8513 missingterm(NULL, 0);
8514 pl_yylval.ival = OP_STRINGIFY;
8515 if (SvIVX(PL_lex_stuff) == '\'')
8516 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8517 TERM(sublex_start());
8520 s = scan_pat(s,OP_QR);
8521 TERM(sublex_start());
8524 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8526 missingterm(NULL, 0);
8527 pl_yylval.ival = OP_BACKTICK;
8528 TERM(sublex_start());
8536 s = force_version(s, FALSE);
8538 else if (*s != 'v' || !isDIGIT(s[1])
8539 || (s = force_version(s, TRUE), *s == 'v'))
8541 *PL_tokenbuf = '\0';
8542 s = force_word(s,BAREWORD,TRUE,TRUE);
8543 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8544 PL_tokenbuf + sizeof(PL_tokenbuf),
8547 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8548 GV_ADD | (UTF ? SVf_UTF8 : 0));
8551 yyerror("<> at require-statement should be quotes");
8553 if (orig_keyword == KEY_require) {
8559 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8561 PL_last_uni = PL_oldbufptr;
8562 PL_last_lop_op = OP_REQUIRE;
8564 return REPORT( (int)REQUIRE );
8573 LOP(OP_RENAME,XTERM);
8582 LOP(OP_RINDEX,XTERM);
8591 UNIDOR(OP_READLINE);
8594 UNIDOR(OP_BACKTICK);
8603 LOP(OP_REVERSE,XTERM);
8606 UNIDOR(OP_READLINK);
8613 if (pl_yylval.opval)
8614 TERM(sublex_start());
8616 TOKEN(1); /* force error */
8619 checkcomma(s,PL_tokenbuf,"filehandle");
8629 LOP(OP_SELECT,XTERM);
8635 LOP(OP_SEMCTL,XTERM);
8638 LOP(OP_SEMGET,XTERM);
8641 LOP(OP_SEMOP,XTERM);
8647 LOP(OP_SETPGRP,XTERM);
8649 case KEY_setpriority:
8650 LOP(OP_SETPRIORITY,XTERM);
8652 case KEY_sethostent:
8658 case KEY_setservent:
8661 case KEY_setprotoent:
8671 LOP(OP_SEEKDIR,XTERM);
8673 case KEY_setsockopt:
8674 LOP(OP_SSOCKOPT,XTERM);
8680 LOP(OP_SHMCTL,XTERM);
8683 LOP(OP_SHMGET,XTERM);
8686 LOP(OP_SHMREAD,XTERM);
8689 LOP(OP_SHMWRITE,XTERM);
8692 LOP(OP_SHUTDOWN,XTERM);
8701 LOP(OP_SOCKET,XTERM);
8703 case KEY_socketpair:
8704 LOP(OP_SOCKPAIR,XTERM);
8707 checkcomma(s,PL_tokenbuf,"subroutine name");
8710 s = force_word(s,BAREWORD,TRUE,TRUE);
8714 LOP(OP_SPLIT,XTERM);
8717 LOP(OP_SPRINTF,XTERM);
8720 LOP(OP_SPLICE,XTERM);
8735 LOP(OP_SUBSTR,XTERM);
8741 char * const tmpbuf = PL_tokenbuf + 1;
8742 bool have_name, have_proto;
8743 const int key = tmp;
8744 SV *format_name = NULL;
8745 bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
8747 SSize_t off = s-SvPVX(PL_linestr);
8749 d = SvPVX(PL_linestr)+off;
8751 SAVEBOOL(PL_parser->sig_seen);
8752 PL_parser->sig_seen = FALSE;
8754 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8756 || (*s == ':' && s[1] == ':'))
8759 PL_expect = XATTRBLOCK;
8760 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8762 if (key == KEY_format)
8763 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8765 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8767 PL_tokenbuf, len + 1, 0
8769 sv_setpvn(PL_subname, tmpbuf, len);
8771 sv_setsv(PL_subname,PL_curstname);
8772 sv_catpvs(PL_subname,"::");
8773 sv_catpvn(PL_subname,tmpbuf,len);
8775 if (SvUTF8(PL_linestr))
8776 SvUTF8_on(PL_subname);
8783 if (key == KEY_my || key == KEY_our || key==KEY_state)
8786 /* diag_listed_as: Missing name in "%s sub" */
8788 "Missing name in \"%s\"", PL_bufptr);
8790 PL_expect = XATTRTERM;
8791 sv_setpvs(PL_subname,"?");
8795 if (key == KEY_format) {
8797 NEXTVAL_NEXTTOKE.opval
8798 = newSVOP(OP_CONST,0, format_name);
8799 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8800 force_next(BAREWORD);
8805 /* Look for a prototype */
8806 if (*s == '(' && !is_sigsub) {
8807 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8809 Perl_croak(aTHX_ "Prototype not terminated");
8810 COPLINE_SET_FROM_MULTI_END;
8811 (void)validate_proto(PL_subname, PL_lex_stuff,
8812 ckWARN(WARN_ILLEGALPROTO), 0);
8820 if ( !(*s == ':' && s[1] != ':')
8821 && (*s != '{' && *s != '(') && key != KEY_format)
8823 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8824 key == KEY_DESTROY || key == KEY_BEGIN ||
8825 key == KEY_UNITCHECK || key == KEY_CHECK ||
8826 key == KEY_INIT || key == KEY_END ||
8827 key == KEY_my || key == KEY_state ||
8830 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8831 else if (*s != ';' && *s != '}')
8832 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8836 NEXTVAL_NEXTTOKE.opval =
8837 newSVOP(OP_CONST, 0, PL_lex_stuff);
8838 PL_lex_stuff = NULL;
8843 sv_setpvs(PL_subname, "__ANON__");
8845 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8851 force_ident_maybe_lex('&');
8859 LOP(OP_SYSTEM,XREF);
8862 LOP(OP_SYMLINK,XTERM);
8865 LOP(OP_SYSCALL,XTERM);
8868 LOP(OP_SYSOPEN,XTERM);
8871 LOP(OP_SYSSEEK,XTERM);
8874 LOP(OP_SYSREAD,XTERM);
8877 LOP(OP_SYSWRITE,XTERM);
8882 TERM(sublex_start());
8903 LOP(OP_TRUNCATE,XTERM);
8915 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8917 pl_yylval.ival = CopLINE(PL_curcop);
8921 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8923 pl_yylval.ival = CopLINE(PL_curcop);
8927 LOP(OP_UNLINK,XTERM);
8933 LOP(OP_UNPACK,XTERM);
8936 LOP(OP_UTIME,XTERM);
8942 LOP(OP_UNSHIFT,XTERM);
8945 s = tokenize_use(1, s);
8955 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8957 pl_yylval.ival = CopLINE(PL_curcop);
8958 Perl_ck_warner_d(aTHX_
8959 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8960 "when is experimental");
8964 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8966 pl_yylval.ival = CopLINE(PL_curcop);
8970 PL_hints |= HINT_BLOCK_SCOPE;
8977 LOP(OP_WAITPID,XTERM);
8983 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8984 * we use the same number on EBCDIC */
8985 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8989 if (PL_expect == XOPERATOR) {
8990 if (*s == '=' && !PL_lex_allbrackets
8991 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
9001 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
9003 pl_yylval.ival = OP_XOR;
9012 Looks up an identifier in the pad or in a package
9014 is_sig indicates that this is a subroutine signature variable
9015 rather than a plain pad var.
9018 PRIVATEREF if this is a lexical name.
9019 BAREWORD if this belongs to a package.
9022 if we're in a my declaration
9023 croak if they tried to say my($foo::bar)
9024 build the ops for a my() declaration
9025 if it's an access to a my() variable
9026 build ops for access to a my() variable
9027 if in a dq string, and they've said @foo and we can't find @foo
9029 build ops for a bareword
9033 S_pending_ident(pTHX)
9036 const char pit = (char)pl_yylval.ival;
9037 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
9038 /* All routes through this function want to know if there is a colon. */
9039 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
9041 DEBUG_T({ PerlIO_printf(Perl_debug_log,
9042 "### Pending identifier '%s'\n", PL_tokenbuf); });
9043 assert(tokenbuf_len >= 2);
9045 /* if we're in a my(), we can't allow dynamics here.
9046 $foo'bar has already been turned into $foo::bar, so
9047 just check for colons.
9049 if it's a legal name, the OP is a PADANY.
9052 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
9054 /* diag_listed_as: No package name allowed for variable %s
9056 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
9057 "%se %s in \"our\"",
9058 *PL_tokenbuf=='&' ?"subroutin":"variabl",
9059 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
9060 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
9065 /* "my" variable %s can't be in a package */
9066 /* PL_no_myglob is constant */
9067 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
9068 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
9069 PL_in_my == KEY_my ? "my" : "state",
9070 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
9072 UTF ? SVf_UTF8 : 0);
9073 GCC_DIAG_RESTORE_STMT;
9076 if (PL_in_my == KEY_sigvar) {
9077 /* A signature 'padop' needs in addition, an op_first to
9078 * point to a child sigdefelem, and an extra field to hold
9079 * the signature index. We can achieve both by using an
9080 * UNOP_AUX and (ab)using the op_aux field to hold the
9081 * index. If we ever need more fields, use a real malloced
9082 * aux strut instead.
9084 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
9085 INT2PTR(UNOP_AUX_item *,
9086 (PL_parser->sig_elems)));
9087 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9088 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9092 o = newOP(OP_PADANY, 0);
9093 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9094 UTF ? SVf_UTF8 : 0);
9095 if (PL_in_my == KEY_sigvar)
9098 pl_yylval.opval = o;
9104 build the ops for accesses to a my() variable.
9109 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9111 if (tmp != NOT_IN_PAD) {
9112 /* might be an "our" variable" */
9113 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9114 /* build ops for a bareword */
9115 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9116 HEK * const stashname = HvNAME_HEK(stash);
9117 SV * const sym = newSVhek(stashname);
9118 sv_catpvs(sym, "::");
9119 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9120 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9121 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9125 ((PL_tokenbuf[0] == '$') ? SVt_PV
9126 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9131 pl_yylval.opval = newOP(OP_PADANY, 0);
9132 pl_yylval.opval->op_targ = tmp;
9138 Whine if they've said @foo or @foo{key} in a doublequoted string,
9139 and @foo (or %foo) isn't a variable we can find in the symbol
9142 if (ckWARN(WARN_AMBIGUOUS)
9144 && PL_lex_state != LEX_NORMAL
9145 && !PL_lex_brackets)
9147 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9148 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9150 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9153 /* Downgraded from fatal to warning 20000522 mjd */
9154 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9155 "Possible unintended interpolation of %" UTF8f
9157 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9161 /* build ops for a bareword */
9162 pl_yylval.opval = newSVOP(OP_CONST, 0,
9163 newSVpvn_flags(PL_tokenbuf + 1,
9164 tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9165 UTF ? SVf_UTF8 : 0 ));
9166 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9168 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9169 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9170 | ( UTF ? SVf_UTF8 : 0 ),
9171 ((PL_tokenbuf[0] == '$') ? SVt_PV
9172 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9178 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9180 PERL_ARGS_ASSERT_CHECKCOMMA;
9182 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9183 if (ckWARN(WARN_SYNTAX)) {
9186 for (w = s+2; *w && level; w++) {
9194 /* the list of chars below is for end of statements or
9195 * block / parens, boolean operators (&&, ||, //) and branch
9196 * constructs (or, and, if, until, unless, while, err, for).
9197 * Not a very solid hack... */
9198 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9199 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9200 "%s (...) interpreted as function",name);
9203 while (s < PL_bufend && isSPACE(*s))
9207 while (s < PL_bufend && isSPACE(*s))
9209 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9210 const char * const w = s;
9211 s += UTF ? UTF8SKIP(s) : 1;
9212 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9213 s += UTF ? UTF8SKIP(s) : 1;
9214 while (s < PL_bufend && isSPACE(*s))
9218 if (keyword(w, s - w, 0))
9221 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9222 if (gv && GvCVu(gv))
9227 Copy(w, tmpbuf+1, s - w, char);
9229 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9230 if (off != NOT_IN_PAD) return;
9232 Perl_croak(aTHX_ "No comma allowed after %s", what);
9237 /* S_new_constant(): do any overload::constant lookup.
9239 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9240 Best used as sv=new_constant(..., sv, ...).
9241 If s, pv are NULL, calls subroutine with one argument,
9242 and <type> is used with error messages only.
9243 <type> is assumed to be well formed UTF-8.
9245 If error_msg is not NULL, *error_msg will be set to any error encountered.
9246 Otherwise yyerror() will be used to output it */
9249 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9250 SV *sv, SV *pv, const char *type, STRLEN typelen,
9251 const char ** error_msg)
9254 HV * table = GvHV(PL_hintgv); /* ^H */
9259 const char *why1 = "", *why2 = "", *why3 = "";
9261 PERL_ARGS_ASSERT_NEW_CONSTANT;
9262 /* We assume that this is true: */
9263 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9266 sv_2mortal(sv); /* Parent created it permanently */
9268 || ! (PL_hints & HINT_LOCALIZE_HH)
9269 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9274 /* Here haven't found what we're looking for. If it is charnames,
9275 * perhaps it needs to be loaded. Try doing that before giving up */
9277 Perl_load_module(aTHX_
9279 newSVpvs("_charnames"),
9280 /* version parameter; no need to specify it, as if
9281 * we get too early a version, will fail anyway,
9282 * not being able to find '_charnames' */
9287 assert(sp == PL_stack_sp);
9288 table = GvHV(PL_hintgv);
9290 && (PL_hints & HINT_LOCALIZE_HH)
9291 && (cvp = hv_fetch(table, key, keylen, FALSE))
9297 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9298 msg = Perl_form(aTHX_
9299 "Constant(%.*s) unknown",
9300 (int)(type ? typelen : len),
9306 why3 = "} is not defined";
9309 msg = Perl_form(aTHX_
9310 /* The +3 is for '\N{'; -4 for that, plus '}' */
9311 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9315 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9316 (int)(type ? typelen : len),
9317 (type ? type: s), why1, why2, why3);
9324 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9326 return SvREFCNT_inc_simple_NN(sv);
9331 pv = newSVpvn_flags(s, len, SVs_TEMP);
9333 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9335 typesv = &PL_sv_undef;
9337 PUSHSTACKi(PERLSI_OVERLOAD);
9349 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9353 /* Check the eval first */
9354 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9356 const char * errstr;
9357 sv_catpvs(errsv, "Propagated");
9358 errstr = SvPV_const(errsv, errlen);
9359 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9361 res = SvREFCNT_inc_simple_NN(sv);
9365 SvREFCNT_inc_simple_void_NN(res);
9374 why1 = "Call to &{$^H{";
9376 why3 = "}} did not return a defined value";
9378 (void)sv_2mortal(sv);
9385 PERL_STATIC_INLINE void
9386 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9387 bool is_utf8, bool check_dollar, bool tick_warn)
9390 const char *olds = *s;
9391 PERL_ARGS_ASSERT_PARSE_IDENT;
9393 while (*s < PL_bufend) {
9395 Perl_croak(aTHX_ "%s", ident_too_long);
9396 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9397 /* The UTF-8 case must come first, otherwise things
9398 * like c\N{COMBINING TILDE} would start failing, as the
9399 * isWORDCHAR_A case below would gobble the 'c' up.
9402 char *t = *s + UTF8SKIP(*s);
9403 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9406 if (*d + (t - *s) > e)
9407 Perl_croak(aTHX_ "%s", ident_too_long);
9408 Copy(*s, *d, t - *s, char);
9412 else if ( isWORDCHAR_A(**s) ) {
9415 } while (isWORDCHAR_A(**s) && *d < e);
9417 else if ( allow_package
9419 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9426 else if (allow_package && **s == ':' && (*s)[1] == ':'
9427 /* Disallow things like Foo::$bar. For the curious, this is
9428 * the code path that triggers the "Bad name after" warning
9429 * when looking for barewords.
9431 && !(check_dollar && (*s)[2] == '$')) {
9438 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9439 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9442 Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9445 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9446 "Old package separator used in string");
9447 if (olds[-1] == '#')
9451 if (*olds == '\'') {
9458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9459 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9460 UTF8fARG(is_utf8, d2-d, d));
9465 /* Returns a NUL terminated string, with the length of the string written to
9469 Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9472 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9473 bool is_utf8 = cBOOL(UTF);
9475 PERL_ARGS_ASSERT_SCAN_WORD;
9477 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9483 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9484 * iff Unicode semantics are to be used. The legal ones are any of:
9485 * a) all ASCII characters except:
9486 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9488 * The final case currently doesn't get this far in the program, so we
9489 * don't test for it. If that were to change, it would be ok to allow it.
9490 * b) When not under Unicode rules, any upper Latin1 character
9491 * c) Otherwise, when unicode rules are used, all XIDS characters.
9493 * Because all ASCII characters have the same representation whether
9494 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9495 * '{' without knowing if is UTF-8 or not. */
9496 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9497 (isGRAPH_A(*(s)) || ((is_utf8) \
9498 ? isIDFIRST_utf8_safe(s, e) \
9500 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9503 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9505 I32 herelines = PL_parser->herelines;
9506 SSize_t bracket = -1;
9509 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9510 bool is_utf8 = cBOOL(UTF);
9511 I32 orig_copline = 0, tmp_copline = 0;
9513 PERL_ARGS_ASSERT_SCAN_IDENT;
9515 if (isSPACE(*s) || !*s)
9518 while (isDIGIT(*s)) {
9520 Perl_croak(aTHX_ "%s", ident_too_long);
9524 else { /* See if it is a "normal" identifier */
9525 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9530 /* Either a digit variable, or parse_ident() found an identifier
9531 (anything valid as a bareword), so job done and return. */
9532 if (PL_lex_state != LEX_NORMAL)
9533 PL_lex_state = LEX_INTERPENDMAYBE;
9537 /* Here, it is not a run-of-the-mill identifier name */
9539 if (*s == '$' && s[1]
9540 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9541 || isDIGIT_A((U8)s[1])
9544 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9546 /* Dereferencing a value in a scalar variable.
9547 The alternatives are different syntaxes for a scalar variable.
9548 Using ' as a leading package separator isn't allowed. :: is. */
9551 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9553 bracket = s - SvPVX(PL_linestr);
9555 orig_copline = CopLINE(PL_curcop);
9556 if (s < PL_bufend && isSPACE(*s)) {
9560 if ((s <= PL_bufend - (is_utf8)
9563 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9566 const STRLEN skip = UTF8SKIP(s);
9569 for ( i = 0; i < skip; i++ )
9577 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9578 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9582 /* Warn about ambiguous code after unary operators if {...} notation isn't
9583 used. There's no difference in ambiguity; it's merely a heuristic
9584 about when not to warn. */
9585 else if (ck_uni && bracket == -1)
9587 if (bracket != -1) {
9590 /* If we were processing {...} notation then... */
9591 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9592 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9595 /* note we have to check for a normal identifier first,
9596 * as it handles utf8 symbols, and only after that has
9597 * been ruled out can we look at the caret words */
9598 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9599 /* if it starts as a valid identifier, assume that it is one.
9600 (the later check for } being at the expected point will trap
9601 cases where this doesn't pan out.) */
9602 d += is_utf8 ? UTF8SKIP(d) : 1;
9603 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
9606 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9608 while (isWORDCHAR(*s) && d < e) {
9612 Perl_croak(aTHX_ "%s", ident_too_long);
9615 tmp_copline = CopLINE(PL_curcop);
9616 if (s < PL_bufend && isSPACE(*s)) {
9619 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9620 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9621 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9622 const char * const brack =
9624 ((*s == '[') ? "[...]" : "{...}");
9625 orig_copline = CopLINE(PL_curcop);
9626 CopLINE_set(PL_curcop, tmp_copline);
9627 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9628 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9629 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9630 funny, dest, brack, funny, dest, brack);
9631 CopLINE_set(PL_curcop, orig_copline);
9634 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9635 PL_lex_allbrackets++;
9641 tmp_copline = CopLINE(PL_curcop);
9642 if ((skip = s < PL_bufend && isSPACE(*s))) {
9643 /* Avoid incrementing line numbers or resetting PL_linestart,
9644 in case we have to back up. */
9645 STRLEN s_off = s - SvPVX(PL_linestr);
9647 s = SvPVX(PL_linestr) + s_off;
9652 /* Expect to find a closing } after consuming any trailing whitespace.
9655 /* Now increment line numbers if applicable. */
9659 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9660 PL_lex_state = LEX_INTERPEND;
9663 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) {
9664 if (ckWARN(WARN_AMBIGUOUS)
9665 && (keyword(dest, d - dest, 0)
9666 || get_cvn_flags(dest, d - dest, is_utf8
9670 SV *tmp = newSVpvn_flags( dest, d - dest,
9671 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9674 orig_copline = CopLINE(PL_curcop);
9675 CopLINE_set(PL_curcop, tmp_copline);
9676 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9677 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9678 funny, SVfARG(tmp), funny, SVfARG(tmp));
9679 CopLINE_set(PL_curcop, orig_copline);
9684 /* Didn't find the closing } at the point we expected, so restore
9685 state such that the next thing to process is the opening { and */
9686 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9687 CopLINE_set(PL_curcop, orig_copline);
9688 PL_parser->herelines = herelines;
9690 PL_parser->sub_no_recover = TRUE;
9693 else if ( PL_lex_state == LEX_INTERPNORMAL
9695 && !intuit_more(s, PL_bufend))
9696 PL_lex_state = LEX_INTERPEND;
9701 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9703 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9704 * found in the parse starting at 's', based on the subset that are valid
9705 * in this context input to this routine in 'valid_flags'. Advances s.
9706 * Returns TRUE if the input should be treated as a valid flag, so the next
9707 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9708 * upon first call on the current regex. This routine will set it to any
9709 * charset modifier found. The caller shouldn't change it. This way,
9710 * another charset modifier encountered in the parse can be detected as an
9711 * error, as we have decided to allow only one */
9714 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9716 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9717 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9718 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9719 UTF ? SVf_UTF8 : 0);
9721 /* Pretend that it worked, so will continue processing before
9730 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9731 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9732 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9733 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9734 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9735 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9736 case LOCALE_PAT_MOD:
9738 goto multiple_charsets;
9740 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9743 case UNICODE_PAT_MOD:
9745 goto multiple_charsets;
9747 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9750 case ASCII_RESTRICT_PAT_MOD:
9752 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9756 /* Error if previous modifier wasn't an 'a', but if it was, see
9757 * if, and accept, a second occurrence (only) */
9759 || get_regex_charset(*pmfl)
9760 != REGEX_ASCII_RESTRICTED_CHARSET)
9762 goto multiple_charsets;
9764 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9768 case DEPENDS_PAT_MOD:
9770 goto multiple_charsets;
9772 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9781 if (*charset != c) {
9782 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9784 else if (c == 'a') {
9785 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9786 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9789 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9792 /* Pretend that it worked, so will continue processing before dieing */
9798 S_scan_pat(pTHX_ char *start, I32 type)
9802 const char * const valid_flags =
9803 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9804 char charset = '\0'; /* character set modifier */
9805 unsigned int x_mod_count = 0;
9807 PERL_ARGS_ASSERT_SCAN_PAT;
9809 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9811 Perl_croak(aTHX_ "Search pattern not terminated");
9813 pm = (PMOP*)newPMOP(type, 0);
9814 if (PL_multi_open == '?') {
9815 /* This is the only point in the code that sets PMf_ONCE: */
9816 pm->op_pmflags |= PMf_ONCE;
9818 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9819 allows us to restrict the list needed by reset to just the ??
9821 assert(type != OP_TRANS);
9823 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9826 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9829 elements = mg->mg_len / sizeof(PMOP**);
9830 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9831 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9832 mg->mg_len = elements * sizeof(PMOP**);
9833 PmopSTASH_set(pm,PL_curstash);
9837 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9838 * anon CV. False positives like qr/[(?{]/ are harmless */
9840 if (type == OP_QR) {
9842 char *e, *p = SvPV(PL_lex_stuff, len);
9844 for (; p < e; p++) {
9845 if (p[0] == '(' && p[1] == '?'
9846 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9848 pm->op_pmflags |= PMf_HAS_CV;
9852 pm->op_pmflags |= PMf_IS_QR;
9855 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9856 &s, &charset, &x_mod_count))
9858 /* issue a warning if /c is specified,but /g is not */
9859 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9861 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9862 "Use of /c modifier is meaningless without /g" );
9865 PL_lex_op = (OP*)pm;
9866 pl_yylval.ival = OP_MATCH;
9871 S_scan_subst(pTHX_ char *start)
9877 line_t linediff = 0;
9879 char charset = '\0'; /* character set modifier */
9880 unsigned int x_mod_count = 0;
9883 PERL_ARGS_ASSERT_SCAN_SUBST;
9885 pl_yylval.ival = OP_NULL;
9887 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9890 Perl_croak(aTHX_ "Substitution pattern not terminated");
9894 first_start = PL_multi_start;
9895 first_line = CopLINE(PL_curcop);
9896 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9898 SvREFCNT_dec_NN(PL_lex_stuff);
9899 PL_lex_stuff = NULL;
9900 Perl_croak(aTHX_ "Substitution replacement not terminated");
9902 PL_multi_start = first_start; /* so whole substitution is taken together */
9904 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9908 if (*s == EXEC_PAT_MOD) {
9912 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9913 &s, &charset, &x_mod_count))
9919 if ((pm->op_pmflags & PMf_CONTINUE)) {
9920 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9924 SV * const repl = newSVpvs("");
9927 pm->op_pmflags |= PMf_EVAL;
9928 for (; es > 1; es--) {
9929 sv_catpvs(repl, "eval ");
9931 sv_catpvs(repl, "do {");
9932 sv_catsv(repl, PL_parser->lex_sub_repl);
9933 sv_catpvs(repl, "}");
9934 SvREFCNT_dec(PL_parser->lex_sub_repl);
9935 PL_parser->lex_sub_repl = repl;
9939 linediff = CopLINE(PL_curcop) - first_line;
9941 CopLINE_set(PL_curcop, first_line);
9943 if (linediff || es) {
9944 /* the IVX field indicates that the replacement string is a s///e;
9945 * the NVX field indicates how many src code lines the replacement
9947 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9948 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
9949 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9953 PL_lex_op = (OP*)pm;
9954 pl_yylval.ival = OP_SUBST;
9959 S_scan_trans(pTHX_ char *start)
9966 bool nondestruct = 0;
9969 PERL_ARGS_ASSERT_SCAN_TRANS;
9971 pl_yylval.ival = OP_NULL;
9973 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9975 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9979 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9981 SvREFCNT_dec_NN(PL_lex_stuff);
9982 PL_lex_stuff = NULL;
9983 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9986 complement = del = squash = 0;
9990 complement = OPpTRANS_COMPLEMENT;
9993 del = OPpTRANS_DELETE;
9996 squash = OPpTRANS_SQUASH;
10008 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
10009 o->op_private &= ~OPpTRANS_ALL;
10010 o->op_private |= del|squash|complement|
10011 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
10012 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
10015 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
10022 Takes a pointer to the first < in <<FOO.
10023 Returns a pointer to the byte following <<FOO.
10025 This function scans a heredoc, which involves different methods
10026 depending on whether we are in a string eval, quoted construct, etc.
10027 This is because PL_linestr could containing a single line of input, or
10028 a whole string being evalled, or the contents of the current quote-
10031 The two basic methods are:
10032 - Steal lines from the input stream
10033 - Scan the heredoc in PL_linestr and remove it therefrom
10035 In a file scope or filtered eval, the first method is used; in a
10036 string eval, the second.
10038 In a quote-like operator, we have to choose between the two,
10039 depending on where we can find a newline. We peek into outer lex-
10040 ing scopes until we find one with a newline in it. If we reach the
10041 outermost lexing scope and it is a file, we use the stream method.
10042 Otherwise it is treated as an eval.
10046 S_scan_heredoc(pTHX_ char *s)
10048 I32 op_type = OP_SCALAR;
10056 I32 indent_len = 0;
10057 bool indented = FALSE;
10058 const bool infile = PL_rsfp || PL_parser->filtered;
10059 const line_t origline = CopLINE(PL_curcop);
10060 LEXSHARED *shared = PL_parser->lex_shared;
10062 PERL_ARGS_ASSERT_SCAN_HEREDOC;
10065 d = PL_tokenbuf + 1;
10066 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10067 *PL_tokenbuf = '\n';
10070 if (*peek == '~') {
10075 while (SPACE_OR_TAB(*peek))
10078 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10081 s = delimcpy(d, e, s, PL_bufend, term, &len);
10082 if (s == PL_bufend)
10083 Perl_croak(aTHX_ "Unterminated delimiter for here document");
10089 /* <<\FOO is equivalent to <<'FOO' */
10094 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10095 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10099 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10100 peek += UTF ? UTF8SKIP(peek) : 1;
10103 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10104 Copy(s, d, len, char);
10109 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10110 Perl_croak(aTHX_ "Delimiter for here document is too long");
10114 len = d - PL_tokenbuf;
10116 #ifndef PERL_STRICT_CR
10117 d = (char *) memchr(s, '\r', PL_bufend - s);
10119 char * const olds = s;
10121 while (s < PL_bufend) {
10127 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10136 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10141 tmpstr = newSV_type(SVt_PVIV);
10142 SvGROW(tmpstr, 80);
10143 if (term == '\'') {
10144 op_type = OP_CONST;
10145 SvIV_set(tmpstr, -1);
10147 else if (term == '`') {
10148 op_type = OP_BACKTICK;
10149 SvIV_set(tmpstr, '\\');
10152 PL_multi_start = origline + 1 + PL_parser->herelines;
10153 PL_multi_open = PL_multi_close = '<';
10155 /* inside a string eval or quote-like operator */
10156 if (!infile || PL_lex_inwhat) {
10159 char * const olds = s;
10160 PERL_CONTEXT * const cx = CX_CUR();
10161 /* These two fields are not set until an inner lexing scope is
10162 entered. But we need them set here. */
10163 shared->ls_bufptr = s;
10164 shared->ls_linestr = PL_linestr;
10166 if (PL_lex_inwhat) {
10167 /* Look for a newline. If the current buffer does not have one,
10168 peek into the line buffer of the parent lexing scope, going
10169 up as many levels as necessary to find one with a newline
10172 while (!(s = (char *)memchr(
10173 (void *)shared->ls_bufptr, '\n',
10174 SvEND(shared->ls_linestr)-shared->ls_bufptr
10177 shared = shared->ls_prev;
10178 /* shared is only null if we have gone beyond the outermost
10179 lexing scope. In a file, we will have broken out of the
10180 loop in the previous iteration. In an eval, the string buf-
10181 fer ends with "\n;", so the while condition above will have
10182 evaluated to false. So shared can never be null. Or so you
10183 might think. Odd syntax errors like s;@{<<; can gobble up
10184 the implicit semicolon at the end of a flie, causing the
10185 file handle to be closed even when we are not in a string
10186 eval. So shared may be null in that case.
10187 (Closing '>>}' here to balance the earlier open brace for
10188 editors that look for matched pairs.) */
10189 if (UNLIKELY(!shared))
10191 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10192 most lexing scope. In a file, shared->ls_linestr at that
10193 level is just one line, so there is no body to steal. */
10194 if (infile && !shared->ls_prev) {
10200 else { /* eval or we've already hit EOF */
10201 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10206 linestr = shared->ls_linestr;
10207 bufend = SvEND(linestr);
10212 while (s < bufend - len + 1) {
10214 ++PL_parser->herelines;
10216 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10220 /* Only valid if it's preceded by whitespace only */
10221 while (backup != myolds && --backup >= myolds) {
10222 if (! SPACE_OR_TAB(*backup)) {
10228 /* No whitespace or all! */
10229 if (backup == s || *backup == '\n') {
10230 Newx(indent, indent_len + 1, char);
10231 memcpy(indent, backup + 1, indent_len);
10232 indent[indent_len] = 0;
10233 s--; /* before our delimiter */
10234 PL_parser->herelines--; /* this line doesn't count */
10241 while (s < bufend - len + 1
10242 && memNE(s,PL_tokenbuf,len) )
10245 ++PL_parser->herelines;
10249 if (s >= bufend - len + 1) {
10253 sv_setpvn(tmpstr,d+1,s-d);
10255 /* the preceding stmt passes a newline */
10256 PL_parser->herelines++;
10258 /* s now points to the newline after the heredoc terminator.
10259 d points to the newline before the body of the heredoc.
10262 /* We are going to modify linestr in place here, so set
10263 aside copies of the string if necessary for re-evals or
10265 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10266 check shared->re_eval_str. */
10267 if (shared->re_eval_start || shared->re_eval_str) {
10268 /* Set aside the rest of the regexp */
10269 if (!shared->re_eval_str)
10270 shared->re_eval_str =
10271 newSVpvn(shared->re_eval_start,
10272 bufend - shared->re_eval_start);
10273 shared->re_eval_start -= s-d;
10276 if (cxstack_ix >= 0
10277 && CxTYPE(cx) == CXt_EVAL
10278 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10279 && cx->blk_eval.cur_text == linestr)
10281 cx->blk_eval.cur_text = newSVsv(linestr);
10282 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10285 /* Copy everything from s onwards back to d. */
10286 Move(s,d,bufend-s + 1,char);
10287 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10288 /* Setting PL_bufend only applies when we have not dug deeper
10289 into other scopes, because sublex_done sets PL_bufend to
10290 SvEND(PL_linestr). */
10291 if (shared == PL_parser->lex_shared)
10292 PL_bufend = SvEND(linestr);
10297 char *oldbufptr_save;
10298 char *oldoldbufptr_save;
10300 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10301 term = PL_tokenbuf[1];
10303 linestr_save = PL_linestr; /* must restore this afterwards */
10304 d = s; /* and this */
10305 oldbufptr_save = PL_oldbufptr;
10306 oldoldbufptr_save = PL_oldoldbufptr;
10307 PL_linestr = newSVpvs("");
10308 PL_bufend = SvPVX(PL_linestr);
10311 PL_bufptr = PL_bufend;
10312 CopLINE_set(PL_curcop,
10313 origline + 1 + PL_parser->herelines);
10315 if ( !lex_next_chunk(LEX_NO_TERM)
10316 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n'))
10318 /* Simply freeing linestr_save might seem simpler here, as it
10319 does not matter what PL_linestr points to, since we are
10320 about to croak; but in a quote-like op, linestr_save
10321 will have been prospectively freed already, via
10322 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10323 restore PL_linestr. */
10324 SvREFCNT_dec_NN(PL_linestr);
10325 PL_linestr = linestr_save;
10326 PL_oldbufptr = oldbufptr_save;
10327 PL_oldoldbufptr = oldoldbufptr_save;
10331 CopLINE_set(PL_curcop, origline);
10333 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10334 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10335 /* ^That should be enough to avoid this needing to grow: */
10336 sv_catpvs(PL_linestr, "\n\0");
10337 assert(s == SvPVX(PL_linestr));
10338 PL_bufend = SvEND(PL_linestr);
10342 PL_parser->herelines++;
10343 PL_last_lop = PL_last_uni = NULL;
10345 #ifndef PERL_STRICT_CR
10346 if (PL_bufend - PL_linestart >= 2) {
10347 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10348 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10350 PL_bufend[-2] = '\n';
10352 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10354 else if (PL_bufend[-1] == '\r')
10355 PL_bufend[-1] = '\n';
10357 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10358 PL_bufend[-1] = '\n';
10361 if (indented && (PL_bufend-s) >= len) {
10362 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10365 char *backup = found;
10368 /* Only valid if it's preceded by whitespace only */
10369 while (backup != s && --backup >= s) {
10370 if (! SPACE_OR_TAB(*backup)) {
10376 /* All whitespace or none! */
10377 if (backup == found || SPACE_OR_TAB(*backup)) {
10378 Newx(indent, indent_len + 1, char);
10379 memcpy(indent, backup, indent_len);
10380 indent[indent_len] = 0;
10381 SvREFCNT_dec(PL_linestr);
10382 PL_linestr = linestr_save;
10383 PL_linestart = SvPVX(linestr_save);
10384 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10385 PL_oldbufptr = oldbufptr_save;
10386 PL_oldoldbufptr = oldoldbufptr_save;
10392 /* Didn't find it */
10393 sv_catsv(tmpstr,PL_linestr);
10396 if (*s == term && PL_bufend-s >= len
10397 && memEQ(s,PL_tokenbuf + 1,len))
10399 SvREFCNT_dec(PL_linestr);
10400 PL_linestr = linestr_save;
10401 PL_linestart = SvPVX(linestr_save);
10402 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10403 PL_oldbufptr = oldbufptr_save;
10404 PL_oldoldbufptr = oldoldbufptr_save;
10409 sv_catsv(tmpstr,PL_linestr);
10415 PL_multi_end = origline + PL_parser->herelines;
10417 if (indented && indent) {
10418 STRLEN linecount = 1;
10419 STRLEN herelen = SvCUR(tmpstr);
10420 char *ss = SvPVX(tmpstr);
10421 char *se = ss + herelen;
10422 SV *newstr = newSV(herelen+1);
10425 /* Trim leading whitespace */
10427 /* newline only? Copy and move on */
10429 sv_catpvs(newstr,"\n");
10433 /* Found our indentation? Strip it */
10435 else if (se - ss >= indent_len
10436 && memEQ(ss, indent, indent_len))
10441 while ((ss + le) < se && *(ss + le) != '\n')
10444 sv_catpvn(newstr, ss, le);
10447 /* Line doesn't begin with our indentation? Croak */
10452 "Indentation on line %d of here-doc doesn't match delimiter",
10458 /* avoid sv_setsv() as we dont wan't to COW here */
10459 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10461 SvREFCNT_dec_NN(newstr);
10464 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10465 SvPV_shrink_to_cur(tmpstr);
10469 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10473 PL_lex_stuff = tmpstr;
10474 pl_yylval.ival = op_type;
10480 SvREFCNT_dec(tmpstr);
10481 CopLINE_set(PL_curcop, origline);
10482 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10486 /* scan_inputsymbol
10487 takes: position of first '<' in input buffer
10488 returns: position of first char following the matching '>' in
10490 side-effects: pl_yylval and lex_op are set.
10495 <<>> read from ARGV without magic open
10496 <FH> read from filehandle
10497 <pkg::FH> read from package qualified filehandle
10498 <pkg'FH> read from package qualified filehandle
10499 <$fh> read from filehandle in $fh
10500 <*.h> filename glob
10505 S_scan_inputsymbol(pTHX_ char *start)
10507 char *s = start; /* current position in buffer */
10510 bool nomagicopen = FALSE;
10511 char *d = PL_tokenbuf; /* start of temp holding space */
10512 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10514 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10516 end = (char *) memchr(s, '\n', PL_bufend - s);
10519 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10520 nomagicopen = TRUE;
10526 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10528 /* die if we didn't have space for the contents of the <>,
10529 or if it didn't end, or if we see a newline
10532 if (len >= (I32)sizeof PL_tokenbuf)
10533 Perl_croak(aTHX_ "Excessively long <> operator");
10535 Perl_croak(aTHX_ "Unterminated <> operator");
10540 Remember, only scalar variables are interpreted as filehandles by
10541 this code. Anything more complex (e.g., <$fh{$num}>) will be
10542 treated as a glob() call.
10543 This code makes use of the fact that except for the $ at the front,
10544 a scalar variable and a filehandle look the same.
10546 if (*d == '$' && d[1]) d++;
10548 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10549 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10550 d += UTF ? UTF8SKIP(d) : 1;
10553 /* If we've tried to read what we allow filehandles to look like, and
10554 there's still text left, then it must be a glob() and not a getline.
10555 Use scan_str to pull out the stuff between the <> and treat it
10556 as nothing more than a string.
10559 if (d - PL_tokenbuf != len) {
10560 pl_yylval.ival = OP_GLOB;
10561 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10563 Perl_croak(aTHX_ "Glob not terminated");
10567 bool readline_overriden = FALSE;
10569 /* we're in a filehandle read situation */
10572 /* turn <> into <ARGV> */
10574 Copy("ARGV",d,5,char);
10576 /* Check whether readline() is overriden */
10577 if ((gv_readline = gv_override("readline",8)))
10578 readline_overriden = TRUE;
10580 /* if <$fh>, create the ops to turn the variable into a
10584 /* try to find it in the pad for this block, otherwise find
10585 add symbol table ops
10587 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10588 if (tmp != NOT_IN_PAD) {
10589 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10590 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10591 HEK * const stashname = HvNAME_HEK(stash);
10592 SV * const sym = sv_2mortal(newSVhek(stashname));
10593 sv_catpvs(sym, "::");
10594 sv_catpv(sym, d+1);
10599 OP * const o = newOP(OP_PADSV, 0);
10601 PL_lex_op = readline_overriden
10602 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10603 op_append_elem(OP_LIST, o,
10604 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10605 : newUNOP(OP_READLINE, 0, o);
10613 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10615 PL_lex_op = readline_overriden
10616 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10617 op_append_elem(OP_LIST,
10618 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10619 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10620 : newUNOP(OP_READLINE, 0,
10621 newUNOP(OP_RV2SV, 0,
10622 newGVOP(OP_GV, 0, gv)));
10624 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10625 pl_yylval.ival = OP_NULL;
10628 /* If it's none of the above, it must be a literal filehandle
10629 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10631 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10632 PL_lex_op = readline_overriden
10633 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10634 op_append_elem(OP_LIST,
10635 newGVOP(OP_GV, 0, gv),
10636 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10637 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10638 pl_yylval.ival = OP_NULL;
10648 start position in buffer
10649 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10650 only if they are of the open/close form
10651 keep_delims preserve the delimiters around the string
10652 re_reparse compiling a run-time /(?{})/:
10653 collapse // to /, and skip encoding src
10654 delimp if non-null, this is set to the position of
10655 the closing delimiter, or just after it if
10656 the closing and opening delimiters differ
10657 (i.e., the opening delimiter of a substitu-
10659 returns: position to continue reading from buffer
10660 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10661 updates the read buffer.
10663 This subroutine pulls a string out of the input. It is called for:
10664 q single quotes q(literal text)
10665 ' single quotes 'literal text'
10666 qq double quotes qq(interpolate $here please)
10667 " double quotes "interpolate $here please"
10668 qx backticks qx(/bin/ls -l)
10669 ` backticks `/bin/ls -l`
10670 qw quote words @EXPORT_OK = qw( func() $spam )
10671 m// regexp match m/this/
10672 s/// regexp substitute s/this/that/
10673 tr/// string transliterate tr/this/that/
10674 y/// string transliterate y/this/that/
10675 ($*@) sub prototypes sub foo ($)
10676 (stuff) sub attr parameters sub foo : attr(stuff)
10677 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10679 In most of these cases (all but <>, patterns and transliterate)
10680 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10681 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10682 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10685 It skips whitespace before the string starts, and treats the first
10686 character as the delimiter. If the delimiter is one of ([{< then
10687 the corresponding "close" character )]}> is used as the closing
10688 delimiter. It allows quoting of delimiters, and if the string has
10689 balanced delimiters ([{<>}]) it allows nesting.
10691 On success, the SV with the resulting string is put into lex_stuff or,
10692 if that is already non-NULL, into lex_repl. The second case occurs only
10693 when parsing the RHS of the special constructs s/// and tr/// (y///).
10694 For convenience, the terminating delimiter character is stuffed into
10699 Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10703 SV *sv; /* scalar value: string */
10704 const char *tmps; /* temp string, used for delimiter matching */
10705 char *s = start; /* current position in the buffer */
10706 char term; /* terminating character */
10707 char *to; /* current position in the sv's data */
10708 I32 brackets = 1; /* bracket nesting level */
10709 bool d_is_utf8 = FALSE; /* is there any utf8 content? */
10710 IV termcode; /* terminating char. code */
10711 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
10712 STRLEN termlen; /* length of terminating string */
10715 /* The delimiters that have a mirror-image closing one */
10716 const char * opening_delims = "([{<";
10717 const char * closing_delims = ")]}>";
10719 /* The only non-UTF character that isn't a stand alone grapheme is
10720 * white-space, hence can't be a delimiter. */
10721 const char * non_grapheme_msg = "Use of unassigned code point or"
10722 " non-standalone grapheme for a delimiter"
10724 PERL_ARGS_ASSERT_SCAN_STR;
10726 /* skip space before the delimiter */
10731 /* mark where we are, in case we need to report errors */
10734 /* after skipping whitespace, the next character is the terminator */
10736 if (!UTF || UTF8_IS_INVARIANT(term)) {
10737 termcode = termstr[0] = term;
10741 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10742 if (UTF && UNLIKELY(! _is_grapheme((U8 *) start,
10747 yyerror(non_grapheme_msg);
10750 Copy(s, termstr, termlen, U8);
10753 /* mark where we are */
10754 PL_multi_start = CopLINE(PL_curcop);
10755 PL_multi_open = termcode;
10756 herelines = PL_parser->herelines;
10758 /* If the delimiter has a mirror-image closing one, get it */
10759 if (term && (tmps = strchr(opening_delims, term))) {
10760 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10763 PL_multi_close = termcode;
10765 if (PL_multi_open == PL_multi_close) {
10766 keep_bracketed_quoted = FALSE;
10769 /* create a new SV to hold the contents. 79 is the SV's initial length.
10770 What a random number. */
10771 sv = newSV_type(SVt_PVIV);
10773 SvIV_set(sv, termcode);
10774 (void)SvPOK_only(sv); /* validate pointer */
10776 /* move past delimiter and try to read a complete string */
10778 sv_catpvn(sv, s, termlen);
10781 /* extend sv if need be */
10782 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10783 /* set 'to' to the next character in the sv's string */
10784 to = SvPVX(sv)+SvCUR(sv);
10786 /* if open delimiter is the close delimiter read unbridle */
10787 if (PL_multi_open == PL_multi_close) {
10788 for (; s < PL_bufend; s++,to++) {
10789 /* embedded newlines increment the current line number */
10790 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10791 COPLINE_INC_WITH_HERELINES;
10792 /* handle quoted delimiters */
10793 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10794 if (!keep_bracketed_quoted
10796 || (re_reparse && s[1] == '\\'))
10799 else /* any other quotes are simply copied straight through */
10802 /* terminate when run out of buffer (the for() condition), or
10803 have found the terminator */
10804 else if (*s == term) { /* First byte of terminator matches */
10805 if (termlen == 1) /* If is the only byte, are done */
10808 /* If the remainder of the terminator matches, also are
10809 * done, after checking that is a separate grapheme */
10810 if ( s + termlen <= PL_bufend
10811 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10814 && UNLIKELY(! _is_grapheme((U8 *) start,
10819 yyerror(non_grapheme_msg);
10824 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10832 /* if the terminator isn't the same as the start character (e.g.,
10833 matched brackets), we have to allow more in the quoting, and
10834 be prepared for nested brackets.
10837 /* read until we run out of string, or we find the terminator */
10838 for (; s < PL_bufend; s++,to++) {
10839 /* embedded newlines increment the line count */
10840 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10841 COPLINE_INC_WITH_HERELINES;
10842 /* backslashes can escape the open or closing characters */
10843 if (*s == '\\' && s+1 < PL_bufend) {
10844 if (!keep_bracketed_quoted
10845 && ( ((UV)s[1] == PL_multi_open)
10846 || ((UV)s[1] == PL_multi_close) ))
10853 /* allow nested opens and closes */
10854 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10856 else if ((UV)*s == PL_multi_open)
10858 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10863 /* terminate the copied string and update the sv's end-of-string */
10865 SvCUR_set(sv, to - SvPVX_const(sv));
10868 * this next chunk reads more into the buffer if we're not done yet
10872 break; /* handle case where we are done yet :-) */
10874 #ifndef PERL_STRICT_CR
10875 if (to - SvPVX_const(sv) >= 2) {
10876 if ( (to[-2] == '\r' && to[-1] == '\n')
10877 || (to[-2] == '\n' && to[-1] == '\r'))
10881 SvCUR_set(sv, to - SvPVX_const(sv));
10883 else if (to[-1] == '\r')
10886 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10890 /* if we're out of file, or a read fails, bail and reset the current
10891 line marker so we can report where the unterminated string began
10893 COPLINE_INC_WITH_HERELINES;
10894 PL_bufptr = PL_bufend;
10895 if (!lex_next_chunk(0)) {
10897 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10900 s = start = PL_bufptr;
10903 /* at this point, we have successfully read the delimited string */
10906 sv_catpvn(sv, s, termlen);
10912 PL_multi_end = CopLINE(PL_curcop);
10913 CopLINE_set(PL_curcop, PL_multi_start);
10914 PL_parser->herelines = herelines;
10916 /* if we allocated too much space, give some back */
10917 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10918 SvLEN_set(sv, SvCUR(sv) + 1);
10919 SvPV_renew(sv, SvLEN(sv));
10922 /* decide whether this is the first or second quoted string we've read
10927 PL_parser->lex_sub_repl = sv;
10930 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10936 takes: pointer to position in buffer
10937 returns: pointer to new position in buffer
10938 side-effects: builds ops for the constant in pl_yylval.op
10940 Read a number in any of the formats that Perl accepts:
10942 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10943 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10944 0b[01](_?[01])* binary integers
10945 0[0-7](_?[0-7])* octal integers
10946 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10947 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10949 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10952 If it reads a number without a decimal point or an exponent, it will
10953 try converting the number to an integer and see if it can do so
10954 without loss of precision.
10958 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10960 const char *s = start; /* current position in buffer */
10961 char *d; /* destination in temp buffer */
10962 char *e; /* end of temp buffer */
10963 NV nv; /* number read, as a double */
10964 SV *sv = NULL; /* place to put the converted number */
10965 bool floatit; /* boolean: int or float? */
10966 const char *lastub = NULL; /* position of last underbar */
10967 static const char* const number_too_long = "Number too long";
10968 bool warned_about_underscore = 0;
10969 #define WARN_ABOUT_UNDERSCORE() \
10971 if (!warned_about_underscore) { \
10972 warned_about_underscore = 1; \
10973 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10974 "Misplaced _ in number"); \
10977 /* Hexadecimal floating point.
10979 * In many places (where we have quads and NV is IEEE 754 double)
10980 * we can fit the mantissa bits of a NV into an unsigned quad.
10981 * (Note that UVs might not be quads even when we have quads.)
10982 * This will not work everywhere, though (either no quads, or
10983 * using long doubles), in which case we have to resort to NV,
10984 * which will probably mean horrible loss of precision due to
10985 * multiple fp operations. */
10986 bool hexfp = FALSE;
10987 int total_bits = 0;
10988 int significant_bits = 0;
10989 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10990 # define HEXFP_UQUAD
10991 Uquad_t hexfp_uquad = 0;
10992 int hexfp_frac_bits = 0;
10997 NV hexfp_mult = 1.0;
10998 UV high_non_zero = 0; /* highest digit */
10999 int non_zero_integer_digits = 0;
11001 PERL_ARGS_ASSERT_SCAN_NUM;
11003 /* We use the first character to decide what type of number this is */
11007 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
11009 /* if it starts with a 0, it could be an octal number, a decimal in
11010 0.13 disguise, or a hexadecimal number, or a binary number. */
11014 u holds the "number so far"
11015 shift the power of 2 of the base
11016 (hex == 4, octal == 3, binary == 1)
11017 overflowed was the number more than we can hold?
11019 Shift is used when we add a digit. It also serves as an "are
11020 we in octal/hex/binary?" indicator to disallow hex characters
11021 when in octal mode.
11026 bool overflowed = FALSE;
11027 bool just_zero = TRUE; /* just plain 0 or binary number? */
11028 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11029 static const char* const bases[5] =
11030 { "", "binary", "", "octal", "hexadecimal" };
11031 static const char* const Bases[5] =
11032 { "", "Binary", "", "Octal", "Hexadecimal" };
11033 static const char* const maxima[5] =
11035 "0b11111111111111111111111111111111",
11039 const char *base, *Base, *max;
11041 /* check for hex */
11042 if (isALPHA_FOLD_EQ(s[1], 'x')) {
11046 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
11051 /* check for a decimal in disguise */
11052 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
11054 /* so it must be octal */
11061 WARN_ABOUT_UNDERSCORE();
11065 base = bases[shift];
11066 Base = Bases[shift];
11067 max = maxima[shift];
11069 /* read the rest of the number */
11071 /* x is used in the overflow test,
11072 b is the digit we're adding on. */
11077 /* if we don't mention it, we're done */
11081 /* _ are ignored -- but warned about if consecutive */
11083 if (lastub && s == lastub + 1)
11084 WARN_ABOUT_UNDERSCORE();
11088 /* 8 and 9 are not octal */
11089 case '8': case '9':
11091 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11095 case '2': case '3': case '4':
11096 case '5': case '6': case '7':
11098 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11101 case '0': case '1':
11102 b = *s++ & 15; /* ASCII digit -> value of digit */
11106 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11107 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11108 /* make sure they said 0x */
11111 b = (*s++ & 7) + 9;
11113 /* Prepare to put the digit we have onto the end
11114 of the number so far. We check for overflows.
11120 assert(shift >= 0);
11121 x = u << shift; /* make room for the digit */
11123 total_bits += shift;
11125 if ((x >> shift) != u
11126 && !(PL_hints & HINT_NEW_BINARY)) {
11129 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11130 "Integer overflow in %s number",
11133 u = x | b; /* add the digit to the end */
11136 n *= nvshift[shift];
11137 /* If an NV has not enough bits in its
11138 * mantissa to represent an UV this summing of
11139 * small low-order numbers is a waste of time
11140 * (because the NV cannot preserve the
11141 * low-order bits anyway): we could just
11142 * remember when did we overflow and in the
11143 * end just multiply n by the right
11148 if (high_non_zero == 0 && b > 0)
11152 non_zero_integer_digits++;
11154 /* this could be hexfp, but peek ahead
11155 * to avoid matching ".." */
11156 if (UNLIKELY(HEXFP_PEEK(s))) {
11164 /* if we get here, we had success: make a scalar value from
11169 /* final misplaced underbar check */
11171 WARN_ABOUT_UNDERSCORE();
11173 if (UNLIKELY(HEXFP_PEEK(s))) {
11174 /* Do sloppy (on the underbars) but quick detection
11175 * (and value construction) for hexfp, the decimal
11176 * detection will shortly be more thorough with the
11177 * underbar checks. */
11179 significant_bits = non_zero_integer_digits * shift;
11182 #else /* HEXFP_NV */
11185 /* Ignore the leading zero bits of
11186 * the high (first) non-zero digit. */
11187 if (high_non_zero) {
11188 if (high_non_zero < 0x8)
11189 significant_bits--;
11190 if (high_non_zero < 0x4)
11191 significant_bits--;
11192 if (high_non_zero < 0x2)
11193 significant_bits--;
11200 bool accumulate = TRUE;
11202 int lim = 1 << shift;
11203 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11205 if (isXDIGIT(*h)) {
11206 significant_bits += shift;
11209 if (significant_bits < NV_MANT_DIG) {
11210 /* We are in the long "run" of xdigits,
11211 * accumulate the full four bits. */
11212 assert(shift >= 0);
11213 hexfp_uquad <<= shift;
11215 hexfp_frac_bits += shift;
11216 } else if (significant_bits - shift < NV_MANT_DIG) {
11217 /* We are at a hexdigit either at,
11218 * or straddling, the edge of mantissa.
11219 * We will try grabbing as many as
11220 * possible bits. */
11222 significant_bits - NV_MANT_DIG;
11226 hexfp_uquad <<= tail;
11227 assert((shift - tail) >= 0);
11228 hexfp_uquad |= b >> (shift - tail);
11229 hexfp_frac_bits += tail;
11231 /* Ignore the trailing zero bits
11232 * of the last non-zero xdigit.
11234 * The assumption here is that if
11235 * one has input of e.g. the xdigit
11236 * eight (0x8), there is only one
11237 * bit being input, not the full
11238 * four bits. Conversely, if one
11239 * specifies a zero xdigit, the
11240 * assumption is that one really
11241 * wants all those bits to be zero. */
11243 if ((b & 0x1) == 0x0) {
11244 significant_bits--;
11245 if ((b & 0x2) == 0x0) {
11246 significant_bits--;
11247 if ((b & 0x4) == 0x0) {
11248 significant_bits--;
11254 accumulate = FALSE;
11257 /* Keep skipping the xdigits, and
11258 * accumulating the significant bits,
11259 * but do not shift the uquad
11260 * (which would catastrophically drop
11261 * high-order bits) or accumulate the
11262 * xdigits anymore. */
11264 #else /* HEXFP_NV */
11266 nv_mult /= nvshift[shift];
11268 hexfp_nv += b * nv_mult;
11270 accumulate = FALSE;
11274 if (significant_bits >= NV_MANT_DIG)
11275 accumulate = FALSE;
11279 if ((total_bits > 0 || significant_bits > 0) &&
11280 isALPHA_FOLD_EQ(*h, 'p')) {
11281 bool negexp = FALSE;
11285 else if (*h == '-') {
11291 while (isDIGIT(*h) || *h == '_') {
11294 hexfp_exp += *h - '0';
11297 && -hexfp_exp < NV_MIN_EXP - 1) {
11298 /* NOTE: this means that the exponent
11299 * underflow warning happens for
11300 * the IEEE 754 subnormals (denormals),
11301 * because DBL_MIN_EXP etc are the lowest
11302 * possible binary (or, rather, DBL_RADIX-base)
11303 * exponent for normals, not subnormals.
11305 * This may or may not be a good thing. */
11306 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11307 "Hexadecimal float: exponent underflow");
11313 && hexfp_exp > NV_MAX_EXP - 1) {
11314 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11315 "Hexadecimal float: exponent overflow");
11323 hexfp_exp = -hexfp_exp;
11325 hexfp_exp -= hexfp_frac_bits;
11327 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11335 if (n > 4294967295.0)
11336 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11337 "%s number > %s non-portable",
11343 if (u > 0xffffffff)
11344 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11345 "%s number > %s non-portable",
11350 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11351 sv = new_constant(start, s - start, "integer",
11352 sv, NULL, NULL, 0, NULL);
11353 else if (PL_hints & HINT_NEW_BINARY)
11354 sv = new_constant(start, s - start, "binary",
11355 sv, NULL, NULL, 0, NULL);
11360 handle decimal numbers.
11361 we're also sent here when we read a 0 as the first digit
11363 case '1': case '2': case '3': case '4': case '5':
11364 case '6': case '7': case '8': case '9': case '.':
11367 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11376 /* read next group of digits and _ and copy into d */
11379 || UNLIKELY(hexfp && isXDIGIT(*s)))
11381 /* skip underscores, checking for misplaced ones
11385 if (lastub && s == lastub + 1)
11386 WARN_ABOUT_UNDERSCORE();
11390 /* check for end of fixed-length buffer */
11392 Perl_croak(aTHX_ "%s", number_too_long);
11393 /* if we're ok, copy the character */
11398 /* final misplaced underbar check */
11399 if (lastub && s == lastub + 1)
11400 WARN_ABOUT_UNDERSCORE();
11402 /* read a decimal portion if there is one. avoid
11403 3..5 being interpreted as the number 3. followed
11406 if (*s == '.' && s[1] != '.') {
11411 WARN_ABOUT_UNDERSCORE();
11415 /* copy, ignoring underbars, until we run out of digits.
11419 || UNLIKELY(hexfp && isXDIGIT(*s));
11422 /* fixed length buffer check */
11424 Perl_croak(aTHX_ "%s", number_too_long);
11426 if (lastub && s == lastub + 1)
11427 WARN_ABOUT_UNDERSCORE();
11433 /* fractional part ending in underbar? */
11435 WARN_ABOUT_UNDERSCORE();
11436 if (*s == '.' && isDIGIT(s[1])) {
11437 /* oops, it's really a v-string, but without the "v" */
11443 /* read exponent part, if present */
11444 if ((isALPHA_FOLD_EQ(*s, 'e')
11445 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11446 && strchr("+-0123456789_", s[1]))
11448 int exp_digits = 0;
11449 const char *save_s = s;
11452 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11453 ditto for p (hexfloats) */
11454 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11455 /* At least some Mach atof()s don't grok 'E' */
11458 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11465 /* stray preinitial _ */
11467 WARN_ABOUT_UNDERSCORE();
11471 /* allow positive or negative exponent */
11472 if (*s == '+' || *s == '-')
11475 /* stray initial _ */
11477 WARN_ABOUT_UNDERSCORE();
11481 /* read digits of exponent */
11482 while (isDIGIT(*s) || *s == '_') {
11486 Perl_croak(aTHX_ "%s", number_too_long);
11490 if (((lastub && s == lastub + 1)
11491 || (!isDIGIT(s[1]) && s[1] != '_')))
11492 WARN_ABOUT_UNDERSCORE();
11498 /* no exponent digits, the [eEpP] could be for something else,
11499 * though in practice we don't get here for p since that's preparsed
11500 * earlier, and results in only the 0xX being consumed, so behave similarly
11501 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11514 We try to do an integer conversion first if no characters
11515 indicating "float" have been found.
11520 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11522 if (flags == IS_NUMBER_IN_UV) {
11524 sv = newSViv(uv); /* Prefer IVs over UVs. */
11527 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11528 if (uv <= (UV) IV_MIN)
11529 sv = newSViv(-(IV)uv);
11536 /* terminate the string */
11538 if (UNLIKELY(hexfp)) {
11539 # ifdef NV_MANT_DIG
11540 if (significant_bits > NV_MANT_DIG)
11541 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11542 "Hexadecimal float: mantissa overflow");
11545 nv = hexfp_uquad * hexfp_mult;
11546 #else /* HEXFP_NV */
11547 nv = hexfp_nv * hexfp_mult;
11550 nv = Atof(PL_tokenbuf);
11556 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11557 const char *const key = floatit ? "float" : "integer";
11558 const STRLEN keylen = floatit ? 5 : 7;
11559 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11560 key, keylen, sv, NULL, NULL, 0, NULL);
11564 /* if it starts with a v, it could be a v-string */
11567 sv = newSV(5); /* preallocate storage space */
11568 ENTER_with_name("scan_vstring");
11570 s = scan_vstring(s, PL_bufend, sv);
11571 SvREFCNT_inc_simple_void_NN(sv);
11572 LEAVE_with_name("scan_vstring");
11576 /* make the op for the constant and return */
11579 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11581 lvalp->opval = NULL;
11587 S_scan_formline(pTHX_ char *s)
11589 SV * const stuff = newSVpvs("");
11590 bool needargs = FALSE;
11591 bool eofmt = FALSE;
11593 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11595 while (!needargs) {
11599 #ifdef PERL_STRICT_CR
11600 while (SPACE_OR_TAB(*t))
11603 while (SPACE_OR_TAB(*t) || *t == '\r')
11606 if (*t == '\n' || t == PL_bufend) {
11611 eol = (char *) memchr(s,'\n',PL_bufend-s);
11616 for (t = s; t < eol; t++) {
11617 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11619 goto enough; /* ~~ must be first line in formline */
11621 if (*t == '@' || *t == '^')
11625 sv_catpvn(stuff, s, eol-s);
11626 #ifndef PERL_STRICT_CR
11627 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11628 char *end = SvPVX(stuff) + SvCUR(stuff);
11631 SvCUR_set(stuff, SvCUR(stuff) - 1);
11639 if ((PL_rsfp || PL_parser->filtered)
11640 && PL_parser->form_lex_state == LEX_NORMAL) {
11642 PL_bufptr = PL_bufend;
11643 COPLINE_INC_WITH_HERELINES;
11644 got_some = lex_next_chunk(0);
11645 CopLINE_dec(PL_curcop);
11650 incline(s, PL_bufend);
11653 if (!SvCUR(stuff) || needargs)
11654 PL_lex_state = PL_parser->form_lex_state;
11655 if (SvCUR(stuff)) {
11656 PL_expect = XSTATE;
11658 const char *s2 = s;
11659 while (isSPACE(*s2) && *s2 != '\n')
11662 PL_expect = XTERMBLOCK;
11663 NEXTVAL_NEXTTOKE.ival = 0;
11666 NEXTVAL_NEXTTOKE.ival = 0;
11667 force_next(FORMLBRACK);
11670 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11673 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11677 SvREFCNT_dec(stuff);
11679 PL_lex_formbrack = 0;
11685 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11687 const I32 oldsavestack_ix = PL_savestack_ix;
11688 CV* const outsidecv = PL_compcv;
11690 SAVEI32(PL_subline);
11691 save_item(PL_subname);
11692 SAVESPTR(PL_compcv);
11694 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11695 CvFLAGS(PL_compcv) |= flags;
11697 PL_subline = CopLINE(PL_curcop);
11698 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11699 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11700 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11701 if (outsidecv && CvPADLIST(outsidecv))
11702 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11704 return oldsavestack_ix;
11708 /* Do extra initialisation of a CV (typically one just created by
11709 * start_subparse()) if that CV is for a named sub
11713 Perl_init_named_cv(pTHX_ CV *cv, OP *nameop)
11715 PERL_ARGS_ASSERT_INIT_NAMED_CV;
11717 if (nameop->op_type == OP_CONST) {
11718 const char *const name = SvPV_nolen_const(((SVOP*)nameop)->op_sv);
11719 if ( strEQ(name, "BEGIN")
11720 || strEQ(name, "END")
11721 || strEQ(name, "INIT")
11722 || strEQ(name, "CHECK")
11723 || strEQ(name, "UNITCHECK")
11728 /* State subs inside anonymous subs need to be
11729 clonable themselves. */
11730 if ( CvANON(CvOUTSIDE(cv))
11731 || CvCLONE(CvOUTSIDE(cv))
11732 || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
11734 ))[nameop->op_targ])
11741 S_yywarn(pTHX_ const char *const s, U32 flags)
11743 PERL_ARGS_ASSERT_YYWARN;
11745 PL_in_eval |= EVAL_WARNONLY;
11746 yyerror_pv(s, flags);
11751 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11753 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11756 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11759 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11761 NOT_REACHED; /* NOTREACHED */
11767 /* Called, after at least one error has been found, to abort the parse now,
11768 * instead of trying to forge ahead */
11770 yyerror_pvn(NULL, 0, 0);
11774 Perl_yyerror(pTHX_ const char *const s)
11776 PERL_ARGS_ASSERT_YYERROR;
11777 return yyerror_pvn(s, strlen(s), 0);
11781 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11783 PERL_ARGS_ASSERT_YYERROR_PV;
11784 return yyerror_pvn(s, strlen(s), flags);
11788 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11790 const char *context = NULL;
11793 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11794 int yychar = PL_parser->yychar;
11796 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11797 * apply. If the number of errors found is large enough, it abandons
11798 * parsing. If 's' is NULL, there is no message, and it abandons
11799 * processing unconditionally */
11802 if (!yychar || (yychar == ';' && !PL_rsfp))
11803 sv_catpvs(where_sv, "at EOF");
11804 else if ( PL_oldoldbufptr
11805 && PL_bufptr > PL_oldoldbufptr
11806 && PL_bufptr - PL_oldoldbufptr < 200
11807 && PL_oldoldbufptr != PL_oldbufptr
11808 && PL_oldbufptr != PL_bufptr)
11812 The code below is removed for NetWare because it
11813 abends/crashes on NetWare when the script has error such as
11814 not having the closing quotes like:
11815 if ($var eq "value)
11816 Checking of white spaces is anyway done in NetWare code.
11819 while (isSPACE(*PL_oldoldbufptr))
11822 context = PL_oldoldbufptr;
11823 contlen = PL_bufptr - PL_oldoldbufptr;
11825 else if ( PL_oldbufptr
11826 && PL_bufptr > PL_oldbufptr
11827 && PL_bufptr - PL_oldbufptr < 200
11828 && PL_oldbufptr != PL_bufptr) {
11831 The code below is removed for NetWare because it
11832 abends/crashes on NetWare when the script has error such as
11833 not having the closing quotes like:
11834 if ($var eq "value)
11835 Checking of white spaces is anyway done in NetWare code.
11838 while (isSPACE(*PL_oldbufptr))
11841 context = PL_oldbufptr;
11842 contlen = PL_bufptr - PL_oldbufptr;
11844 else if (yychar > 255)
11845 sv_catpvs(where_sv, "next token ???");
11846 else if (yychar == YYEMPTY) {
11847 if (PL_lex_state == LEX_NORMAL)
11848 sv_catpvs(where_sv, "at end of line");
11849 else if (PL_lex_inpat)
11850 sv_catpvs(where_sv, "within pattern");
11852 sv_catpvs(where_sv, "within string");
11855 sv_catpvs(where_sv, "next char ");
11857 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11858 else if (isPRINT_LC(yychar)) {
11859 const char string = yychar;
11860 sv_catpvn(where_sv, &string, 1);
11863 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11865 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11866 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11867 OutCopFILE(PL_curcop),
11868 (IV)(PL_parser->preambling == NOLINE
11869 ? CopLINE(PL_curcop)
11870 : PL_parser->preambling));
11872 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11873 UTF8fARG(UTF, contlen, context));
11875 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11876 if ( PL_multi_start < PL_multi_end
11877 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11879 Perl_sv_catpvf(aTHX_ msg,
11880 " (Might be a runaway multi-line %c%c string starting on"
11881 " line %" IVdf ")\n",
11882 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11885 if (PL_in_eval & EVAL_WARNONLY) {
11886 PL_in_eval &= ~EVAL_WARNONLY;
11887 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11893 if (s == NULL || PL_error_count >= 10) {
11894 const char * msg = "";
11895 const char * const name = OutCopFILE(PL_curcop);
11898 SV * errsv = ERRSV;
11899 if (SvCUR(errsv)) {
11900 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11905 abort_execution(msg, name);
11908 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11912 PL_in_my_stash = NULL;
11917 S_swallow_bom(pTHX_ U8 *s)
11919 const STRLEN slen = SvCUR(PL_linestr);
11921 PERL_ARGS_ASSERT_SWALLOW_BOM;
11925 if (s[1] == 0xFE) {
11926 /* UTF-16 little-endian? (or UTF-32LE?) */
11927 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11928 /* diag_listed_as: Unsupported script encoding %s */
11929 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11930 #ifndef PERL_NO_UTF16_FILTER
11932 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11935 if (PL_bufend > (char*)s) {
11936 s = add_utf16_textfilter(s, TRUE);
11939 /* diag_listed_as: Unsupported script encoding %s */
11940 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11945 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11946 #ifndef PERL_NO_UTF16_FILTER
11948 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11951 if (PL_bufend > (char *)s) {
11952 s = add_utf16_textfilter(s, FALSE);
11955 /* diag_listed_as: Unsupported script encoding %s */
11956 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11960 case BOM_UTF8_FIRST_BYTE: {
11961 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
11963 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11965 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
11972 if (s[2] == 0xFE && s[3] == 0xFF) {
11973 /* UTF-32 big-endian */
11974 /* diag_listed_as: Unsupported script encoding %s */
11975 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11978 else if (s[2] == 0 && s[3] != 0) {
11981 * are a good indicator of UTF-16BE. */
11982 #ifndef PERL_NO_UTF16_FILTER
11984 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11986 s = add_utf16_textfilter(s, FALSE);
11988 /* diag_listed_as: Unsupported script encoding %s */
11989 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11996 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11999 * are a good indicator of UTF-16LE. */
12000 #ifndef PERL_NO_UTF16_FILTER
12002 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12004 s = add_utf16_textfilter(s, TRUE);
12006 /* diag_listed_as: Unsupported script encoding %s */
12007 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
12015 #ifndef PERL_NO_UTF16_FILTER
12017 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12019 SV *const filter = FILTER_DATA(idx);
12020 /* We re-use this each time round, throwing the contents away before we
12022 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
12023 SV *const utf8_buffer = filter;
12024 IV status = IoPAGE(filter);
12025 const bool reverse = cBOOL(IoLINES(filter));
12028 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
12030 /* As we're automatically added, at the lowest level, and hence only called
12031 from this file, we can be sure that we're not called in block mode. Hence
12032 don't bother writing code to deal with block mode. */
12034 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
12037 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
12039 DEBUG_P(PerlIO_printf(Perl_debug_log,
12040 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12041 FPTR2DPTR(void *, S_utf16_textfilter),
12042 reverse ? 'l' : 'b', idx, maxlen, status,
12043 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12050 /* First, look in our buffer of existing UTF-8 data: */
12051 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
12055 } else if (status == 0) {
12057 IoPAGE(filter) = 0;
12058 nl = SvEND(utf8_buffer);
12061 STRLEN got = nl - SvPVX(utf8_buffer);
12062 /* Did we have anything to append? */
12064 sv_catpvn(sv, SvPVX(utf8_buffer), got);
12065 /* Everything else in this code works just fine if SVp_POK isn't
12066 set. This, however, needs it, and we need it to work, else
12067 we loop infinitely because the buffer is never consumed. */
12068 sv_chop(utf8_buffer, nl);
12072 /* OK, not a complete line there, so need to read some more UTF-16.
12073 Read an extra octect if the buffer currently has an odd number. */
12077 if (SvCUR(utf16_buffer) >= 2) {
12078 /* Location of the high octet of the last complete code point.
12079 Gosh, UTF-16 is a pain. All the benefits of variable length,
12080 *coupled* with all the benefits of partial reads and
12082 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
12083 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
12085 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
12089 /* We have the first half of a surrogate. Read more. */
12090 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
12093 status = FILTER_READ(idx + 1, utf16_buffer,
12094 160 + (SvCUR(utf16_buffer) & 1));
12095 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
12096 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
12099 IoPAGE(filter) = status;
12104 /* 'chars' isn't quite the right name, as code points above 0xFFFF
12105 * require 4 bytes per char */
12106 chars = SvCUR(utf16_buffer) >> 1;
12107 have = SvCUR(utf8_buffer);
12109 /* Assume the worst case size as noted by the functions: twice the
12110 * number of input bytes */
12111 SvGROW(utf8_buffer, have + chars * 4 + 1);
12114 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12115 (U8*)SvPVX_const(utf8_buffer) + have,
12116 chars * 2, &newlen);
12118 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12119 (U8*)SvPVX_const(utf8_buffer) + have,
12120 chars * 2, &newlen);
12122 SvCUR_set(utf8_buffer, have + newlen);
12125 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12126 it's private to us, and utf16_to_utf8{,reversed} take a
12127 (pointer,length) pair, rather than a NUL-terminated string. */
12128 if(SvCUR(utf16_buffer) & 1) {
12129 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12130 SvCUR_set(utf16_buffer, 1);
12132 SvCUR_set(utf16_buffer, 0);
12135 DEBUG_P(PerlIO_printf(Perl_debug_log,
12136 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12138 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12139 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12144 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12146 SV *filter = filter_add(S_utf16_textfilter, NULL);
12148 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12150 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12152 IoLINES(filter) = reversed;
12153 IoPAGE(filter) = 1; /* Not EOF */
12155 /* Sadly, we have to return a valid pointer, come what may, so we have to
12156 ignore any error return from this. */
12157 SvCUR_set(PL_linestr, 0);
12158 if (FILTER_READ(0, PL_linestr, 0)) {
12159 SvUTF8_on(PL_linestr);
12161 SvUTF8_on(PL_linestr);
12163 PL_bufend = SvEND(PL_linestr);
12164 return (U8*)SvPVX(PL_linestr);
12169 Returns a pointer to the next character after the parsed
12170 vstring, as well as updating the passed in sv.
12172 Function must be called like
12174 sv = sv_2mortal(newSV(5));
12175 s = scan_vstring(s,e,sv);
12177 where s and e are the start and end of the string.
12178 The sv should already be large enough to store the vstring
12179 passed in, for performance reasons.
12181 This function may croak if fatal warnings are enabled in the
12182 calling scope, hence the sv_2mortal in the example (to prevent
12183 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12189 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12191 const char *pos = s;
12192 const char *start = s;
12194 PERL_ARGS_ASSERT_SCAN_VSTRING;
12196 if (*pos == 'v') pos++; /* get past 'v' */
12197 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12199 if ( *pos != '.') {
12200 /* this may not be a v-string if followed by => */
12201 const char *next = pos;
12202 while (next < e && isSPACE(*next))
12204 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12205 /* return string not v-string */
12206 sv_setpvn(sv,(char *)s,pos-s);
12207 return (char *)pos;
12211 if (!isALPHA(*pos)) {
12212 U8 tmpbuf[UTF8_MAXBYTES+1];
12215 s++; /* get past 'v' */
12220 /* this is atoi() that tolerates underscores */
12223 const char *end = pos;
12225 while (--end >= s) {
12227 const UV orev = rev;
12228 rev += (*end - '0') * mult;
12231 /* diag_listed_as: Integer overflow in %s number */
12232 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12233 "Integer overflow in decimal number");
12237 /* Append native character for the rev point */
12238 tmpend = uvchr_to_utf8(tmpbuf, rev);
12239 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12240 if (!UVCHR_IS_INVARIANT(rev))
12242 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12248 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12252 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12259 Perl_keyword_plugin_standard(pTHX_
12260 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12262 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12263 PERL_UNUSED_CONTEXT;
12264 PERL_UNUSED_ARG(keyword_ptr);
12265 PERL_UNUSED_ARG(keyword_len);
12266 PERL_UNUSED_ARG(op_ptr);
12267 return KEYWORD_PLUGIN_DECLINE;
12271 =for apidoc wrap_keyword_plugin
12273 Puts a C function into the chain of keyword plugins. This is the
12274 preferred way to manipulate the L</PL_keyword_plugin> variable.
12275 C<new_plugin> is a pointer to the C function that is to be added to the
12276 keyword plugin chain, and C<old_plugin_p> points to the storage location
12277 where a pointer to the next function in the chain will be stored. The
12278 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12279 while the value previously stored there is written to C<*old_plugin_p>.
12281 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12282 to hook keyword parsing may find itself invoked more than once per
12283 process, typically in different threads. To handle that situation, this
12284 function is idempotent. The location C<*old_plugin_p> must initially
12285 (once per process) contain a null pointer. A C variable of static
12286 duration (declared at file scope, typically also marked C<static> to give
12287 it internal linkage) will be implicitly initialised appropriately, if it
12288 does not have an explicit initialiser. This function will only actually
12289 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12290 function is also thread safe on the small scale. It uses appropriate
12291 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12293 When this function is called, the function referenced by C<new_plugin>
12294 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12295 In a threading situation, C<new_plugin> may be called immediately, even
12296 before this function has returned. C<*old_plugin_p> will always be
12297 appropriately set before C<new_plugin> is called. If C<new_plugin>
12298 decides not to do anything special with the identifier that it is given
12299 (which is the usual case for most calls to a keyword plugin), it must
12300 chain the plugin function referenced by C<*old_plugin_p>.
12302 Taken all together, XS code to install a keyword plugin should typically
12303 look something like this:
12305 static Perl_keyword_plugin_t next_keyword_plugin;
12306 static OP *my_keyword_plugin(pTHX_
12307 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12309 if (memEQs(keyword_ptr, keyword_len,
12310 "my_new_keyword")) {
12313 return next_keyword_plugin(aTHX_
12314 keyword_ptr, keyword_len, op_ptr);
12318 wrap_keyword_plugin(my_keyword_plugin,
12319 &next_keyword_plugin);
12321 Direct access to L</PL_keyword_plugin> should be avoided.
12327 Perl_wrap_keyword_plugin(pTHX_
12328 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12332 PERL_UNUSED_CONTEXT;
12333 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12334 if (*old_plugin_p) return;
12335 KEYWORD_PLUGIN_MUTEX_LOCK;
12336 if (!*old_plugin_p) {
12337 *old_plugin_p = PL_keyword_plugin;
12338 PL_keyword_plugin = new_plugin;
12340 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12343 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12345 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12347 SAVEI32(PL_lex_brackets);
12348 if (PL_lex_brackets > 100)
12349 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12350 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12351 SAVEI32(PL_lex_allbrackets);
12352 PL_lex_allbrackets = 0;
12353 SAVEI8(PL_lex_fakeeof);
12354 PL_lex_fakeeof = (U8)fakeeof;
12355 if(yyparse(gramtype) && !PL_parser->error_count)
12356 qerror(Perl_mess(aTHX_ "Parse error"));
12359 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12361 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12365 SAVEVPTR(PL_eval_root);
12366 PL_eval_root = NULL;
12367 parse_recdescent(gramtype, fakeeof);
12373 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12375 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12378 if (flags & ~PARSE_OPTIONAL)
12379 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12380 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12381 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12382 if (!PL_parser->error_count)
12383 qerror(Perl_mess(aTHX_ "Parse error"));
12384 exprop = newOP(OP_NULL, 0);
12390 =for apidoc parse_arithexpr
12392 Parse a Perl arithmetic expression. This may contain operators of precedence
12393 down to the bit shift operators. The expression must be followed (and thus
12394 terminated) either by a comparison or lower-precedence operator or by
12395 something that would normally terminate an expression such as semicolon.
12396 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12397 otherwise it is mandatory. It is up to the caller to ensure that the
12398 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12399 the source of the code to be parsed and the lexical context for the
12402 The op tree representing the expression is returned. If an optional
12403 expression is absent, a null pointer is returned, otherwise the pointer
12406 If an error occurs in parsing or compilation, in most cases a valid op
12407 tree is returned anyway. The error is reflected in the parser state,
12408 normally resulting in a single exception at the top level of parsing
12409 which covers all the compilation errors that occurred. Some compilation
12410 errors, however, will throw an exception immediately.
12416 Perl_parse_arithexpr(pTHX_ U32 flags)
12418 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12422 =for apidoc parse_termexpr
12424 Parse a Perl term expression. This may contain operators of precedence
12425 down to the assignment operators. The expression must be followed (and thus
12426 terminated) either by a comma or lower-precedence operator or by
12427 something that would normally terminate an expression such as semicolon.
12428 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12429 otherwise it is mandatory. It is up to the caller to ensure that the
12430 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12431 the source of the code to be parsed and the lexical context for the
12434 The op tree representing the expression is returned. If an optional
12435 expression is absent, a null pointer is returned, otherwise the pointer
12438 If an error occurs in parsing or compilation, in most cases a valid op
12439 tree is returned anyway. The error is reflected in the parser state,
12440 normally resulting in a single exception at the top level of parsing
12441 which covers all the compilation errors that occurred. Some compilation
12442 errors, however, will throw an exception immediately.
12448 Perl_parse_termexpr(pTHX_ U32 flags)
12450 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12454 =for apidoc parse_listexpr
12456 Parse a Perl list expression. This may contain operators of precedence
12457 down to the comma operator. The expression must be followed (and thus
12458 terminated) either by a low-precedence logic operator such as C<or> or by
12459 something that would normally terminate an expression such as semicolon.
12460 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12461 otherwise it is mandatory. It is up to the caller to ensure that the
12462 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12463 the source of the code to be parsed and the lexical context for the
12466 The op tree representing the expression is returned. If an optional
12467 expression is absent, a null pointer is returned, otherwise the pointer
12470 If an error occurs in parsing or compilation, in most cases a valid op
12471 tree is returned anyway. The error is reflected in the parser state,
12472 normally resulting in a single exception at the top level of parsing
12473 which covers all the compilation errors that occurred. Some compilation
12474 errors, however, will throw an exception immediately.
12480 Perl_parse_listexpr(pTHX_ U32 flags)
12482 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12486 =for apidoc parse_fullexpr
12488 Parse a single complete Perl expression. This allows the full
12489 expression grammar, including the lowest-precedence operators such
12490 as C<or>. The expression must be followed (and thus terminated) by a
12491 token that an expression would normally be terminated by: end-of-file,
12492 closing bracketing punctuation, semicolon, or one of the keywords that
12493 signals a postfix expression-statement modifier. If C<flags> has the
12494 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12495 mandatory. It is up to the caller to ensure that the dynamic parser
12496 state (L</PL_parser> et al) is correctly set to reflect the source of
12497 the code to be parsed and the lexical context for the expression.
12499 The op tree representing the expression is returned. If an optional
12500 expression is absent, a null pointer is returned, otherwise the pointer
12503 If an error occurs in parsing or compilation, in most cases a valid op
12504 tree is returned anyway. The error is reflected in the parser state,
12505 normally resulting in a single exception at the top level of parsing
12506 which covers all the compilation errors that occurred. Some compilation
12507 errors, however, will throw an exception immediately.
12513 Perl_parse_fullexpr(pTHX_ U32 flags)
12515 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12519 =for apidoc parse_block
12521 Parse a single complete Perl code block. This consists of an opening
12522 brace, a sequence of statements, and a closing brace. The block
12523 constitutes a lexical scope, so C<my> variables and various compile-time
12524 effects can be contained within it. It is up to the caller to ensure
12525 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12526 reflect the source of the code to be parsed and the lexical context for
12529 The op tree representing the code block is returned. This is always a
12530 real op, never a null pointer. It will normally be a C<lineseq> list,
12531 including C<nextstate> or equivalent ops. No ops to construct any kind
12532 of runtime scope are included by virtue of it being a block.
12534 If an error occurs in parsing or compilation, in most cases a valid op
12535 tree (most likely null) is returned anyway. The error is reflected in
12536 the parser state, normally resulting in a single exception at the top
12537 level of parsing which covers all the compilation errors that occurred.
12538 Some compilation errors, however, will throw an exception immediately.
12540 The C<flags> parameter is reserved for future use, and must always
12547 Perl_parse_block(pTHX_ U32 flags)
12550 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12551 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12555 =for apidoc parse_barestmt
12557 Parse a single unadorned Perl statement. This may be a normal imperative
12558 statement or a declaration that has compile-time effect. It does not
12559 include any label or other affixture. It is up to the caller to ensure
12560 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12561 reflect the source of the code to be parsed and the lexical context for
12564 The op tree representing the statement is returned. This may be a
12565 null pointer if the statement is null, for example if it was actually
12566 a subroutine definition (which has compile-time side effects). If not
12567 null, it will be ops directly implementing the statement, suitable to
12568 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12569 equivalent op (except for those embedded in a scope contained entirely
12570 within the statement).
12572 If an error occurs in parsing or compilation, in most cases a valid op
12573 tree (most likely null) is returned anyway. The error is reflected in
12574 the parser state, normally resulting in a single exception at the top
12575 level of parsing which covers all the compilation errors that occurred.
12576 Some compilation errors, however, will throw an exception immediately.
12578 The C<flags> parameter is reserved for future use, and must always
12585 Perl_parse_barestmt(pTHX_ U32 flags)
12588 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12589 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12593 =for apidoc parse_label
12595 Parse a single label, possibly optional, of the type that may prefix a
12596 Perl statement. It is up to the caller to ensure that the dynamic parser
12597 state (L</PL_parser> et al) is correctly set to reflect the source of
12598 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12599 label is optional, otherwise it is mandatory.
12601 The name of the label is returned in the form of a fresh scalar. If an
12602 optional label is absent, a null pointer is returned.
12604 If an error occurs in parsing, which can only occur if the label is
12605 mandatory, a valid label is returned anyway. The error is reflected in
12606 the parser state, normally resulting in a single exception at the top
12607 level of parsing which covers all the compilation errors that occurred.
12613 Perl_parse_label(pTHX_ U32 flags)
12615 if (flags & ~PARSE_OPTIONAL)
12616 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12618 PL_parser->yychar = yylex();
12619 if (PL_parser->yychar == LABEL) {
12620 SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv;
12621 PL_parser->yychar = YYEMPTY;
12622 cSVOPx(pl_yylval.opval)->op_sv = NULL;
12623 op_free(pl_yylval.opval);
12631 STRLEN wlen, bufptr_pos;
12634 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12636 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12637 if (word_takes_any_delimiter(s, wlen))
12639 bufptr_pos = s - SvPVX(PL_linestr);
12641 lex_read_space(LEX_KEEP_PREVIOUS);
12643 s = SvPVX(PL_linestr) + bufptr_pos;
12644 if (t[0] == ':' && t[1] != ':') {
12645 PL_oldoldbufptr = PL_oldbufptr;
12648 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12652 if (flags & PARSE_OPTIONAL) {
12655 qerror(Perl_mess(aTHX_ "Parse error"));
12656 return newSVpvs("x");
12663 =for apidoc parse_fullstmt
12665 Parse a single complete Perl statement. This may be a normal imperative
12666 statement or a declaration that has compile-time effect, and may include
12667 optional labels. It is up to the caller to ensure that the dynamic
12668 parser state (L</PL_parser> et al) is correctly set to reflect the source
12669 of the code to be parsed and the lexical context for the statement.
12671 The op tree representing the statement is returned. This may be a
12672 null pointer if the statement is null, for example if it was actually
12673 a subroutine definition (which has compile-time side effects). If not
12674 null, it will be the result of a L</newSTATEOP> call, normally including
12675 a C<nextstate> or equivalent op.
12677 If an error occurs in parsing or compilation, in most cases a valid op
12678 tree (most likely null) is returned anyway. The error is reflected in
12679 the parser state, normally resulting in a single exception at the top
12680 level of parsing which covers all the compilation errors that occurred.
12681 Some compilation errors, however, will throw an exception immediately.
12683 The C<flags> parameter is reserved for future use, and must always
12690 Perl_parse_fullstmt(pTHX_ U32 flags)
12693 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12694 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12698 =for apidoc parse_stmtseq
12700 Parse a sequence of zero or more Perl statements. These may be normal
12701 imperative statements, including optional labels, or declarations
12702 that have compile-time effect, or any mixture thereof. The statement
12703 sequence ends when a closing brace or end-of-file is encountered in a
12704 place where a new statement could have validly started. It is up to
12705 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12706 is correctly set to reflect the source of the code to be parsed and the
12707 lexical context for the statements.
12709 The op tree representing the statement sequence is returned. This may
12710 be a null pointer if the statements were all null, for example if there
12711 were no statements or if there were only subroutine definitions (which
12712 have compile-time side effects). If not null, it will be a C<lineseq>
12713 list, normally including C<nextstate> or equivalent ops.
12715 If an error occurs in parsing or compilation, in most cases a valid op
12716 tree is returned anyway. The error is reflected in the parser state,
12717 normally resulting in a single exception at the top level of parsing
12718 which covers all the compilation errors that occurred. Some compilation
12719 errors, however, will throw an exception immediately.
12721 The C<flags> parameter is reserved for future use, and must always
12728 Perl_parse_stmtseq(pTHX_ U32 flags)
12733 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12734 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12735 c = lex_peek_unichar(0);
12736 if (c != -1 && c != /*{*/'}')
12737 qerror(Perl_mess(aTHX_ "Parse error"));
12742 * ex: set ts=8 sts=4 sw=4 et: