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"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_dojoin (PL_parser->lex_dojoin)
56 #define PL_lex_formbrack (PL_parser->lex_formbrack)
57 #define PL_lex_inpat (PL_parser->lex_inpat)
58 #define PL_lex_inwhat (PL_parser->lex_inwhat)
59 #define PL_lex_op (PL_parser->lex_op)
60 #define PL_lex_repl (PL_parser->lex_repl)
61 #define PL_lex_starts (PL_parser->lex_starts)
62 #define PL_lex_stuff (PL_parser->lex_stuff)
63 #define PL_multi_start (PL_parser->multi_start)
64 #define PL_multi_open (PL_parser->multi_open)
65 #define PL_multi_close (PL_parser->multi_close)
66 #define PL_preambled (PL_parser->preambled)
67 #define PL_linestr (PL_parser->linestr)
68 #define PL_expect (PL_parser->expect)
69 #define PL_copline (PL_parser->copline)
70 #define PL_bufptr (PL_parser->bufptr)
71 #define PL_oldbufptr (PL_parser->oldbufptr)
72 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
73 #define PL_linestart (PL_parser->linestart)
74 #define PL_bufend (PL_parser->bufend)
75 #define PL_last_uni (PL_parser->last_uni)
76 #define PL_last_lop (PL_parser->last_lop)
77 #define PL_last_lop_op (PL_parser->last_lop_op)
78 #define PL_lex_state (PL_parser->lex_state)
79 #define PL_rsfp (PL_parser->rsfp)
80 #define PL_rsfp_filters (PL_parser->rsfp_filters)
81 #define PL_in_my (PL_parser->in_my)
82 #define PL_in_my_stash (PL_parser->in_my_stash)
83 #define PL_tokenbuf (PL_parser->tokenbuf)
84 #define PL_multi_end (PL_parser->multi_end)
85 #define PL_error_count (PL_parser->error_count)
87 # define PL_nexttoke (PL_parser->nexttoke)
88 # define PL_nexttype (PL_parser->nexttype)
89 # define PL_nextval (PL_parser->nextval)
92 #define SvEVALED(sv) \
93 (SvTYPE(sv) >= SVt_PVNV \
94 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
96 static const char* const ident_too_long = "Identifier too long";
98 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
100 #define XENUMMASK 0x3f
101 #define XFAKEEOF 0x40
102 #define XFAKEBRACK 0x80
104 #ifdef USE_UTF8_SCRIPTS
105 # define UTF cBOOL(!IN_BYTES)
107 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
110 /* The maximum number of characters preceding the unrecognized one to display */
111 #define UNRECOGNIZED_PRECEDE_COUNT 10
113 /* In variables named $^X, these are the legal values for X.
114 * 1999-02-27 mjd-perl-patch@plover.com */
115 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
117 #define SPACE_OR_TAB(c) isBLANK_A(c)
119 #define HEXFP_PEEK(s) \
121 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
122 isALPHA_FOLD_EQ(s[0], 'p'))
124 /* LEX_* are values for PL_lex_state, the state of the lexer.
125 * They are arranged oddly so that the guard on the switch statement
126 * can get by with a single comparison (if the compiler is smart enough).
128 * These values refer to the various states within a sublex parse,
129 * i.e. within a double quotish string
132 /* #define LEX_NOTPARSING 11 is done in perl.h. */
134 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
135 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
136 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
137 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
138 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
140 /* at end of code, eg "$x" followed by: */
141 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
142 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
144 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
145 string or after \E, $foo, etc */
146 #define LEX_INTERPCONST 2 /* NOT USED */
147 #define LEX_FORMLINE 1 /* expecting a format line */
151 static const char* const lex_state_names[] = {
166 #include "keywords.h"
168 /* CLINE is a macro that ensures PL_copline has a sane value */
170 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
173 * Convenience functions to return different tokens and prime the
174 * lexer for the next token. They all take an argument.
176 * TOKEN : generic token (used for '(', DOLSHARP, etc)
177 * OPERATOR : generic operator
178 * AOPERATOR : assignment operator
179 * PREBLOCK : beginning the block after an if, while, foreach, ...
180 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
181 * PREREF : *EXPR where EXPR is not a simple identifier
182 * TERM : expression term
183 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
184 * LOOPX : loop exiting command (goto, last, dump, etc)
185 * FTST : file test operator
186 * FUN0 : zero-argument function
187 * FUN0OP : zero-argument function, with its op created in this file
188 * FUN1 : not used, except for not, which isn't a UNIOP
189 * BOop : bitwise or or xor
191 * BCop : bitwise complement
192 * SHop : shift operator
193 * PWop : power operator
194 * PMop : pattern-matching operator
195 * Aop : addition-level operator
196 * AopNOASSIGN : addition-level operator that is never part of .=
197 * Mop : multiplication-level operator
198 * Eop : equality-testing operator
199 * Rop : relational operator <= != gt
201 * Also see LOP and lop() below.
204 #ifdef DEBUGGING /* Serve -DT. */
205 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
207 # define REPORT(retval) (retval)
210 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
211 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
212 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
213 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
214 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
216 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
217 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
218 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
220 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
222 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
223 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
224 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
225 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
226 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
227 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
228 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
230 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
231 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
232 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
233 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
234 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
235 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
236 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
237 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
239 /* This bit of chicanery makes a unary function followed by
240 * a parenthesis into a function with one argument, highest precedence.
241 * The UNIDOR macro is for unary functions that can be followed by the //
242 * operator (such as C<shift // 0>).
244 #define UNI3(f,x,have_x) { \
245 pl_yylval.ival = f; \
246 if (have_x) PL_expect = x; \
248 PL_last_uni = PL_oldbufptr; \
249 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
251 return REPORT( (int)FUNC1 ); \
253 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
255 #define UNI(f) UNI3(f,XTERM,1)
256 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
257 #define UNIPROTO(f,optional) { \
258 if (optional) PL_last_uni = PL_oldbufptr; \
262 #define UNIBRACK(f) UNI3(f,0,0)
264 /* grandfather return to old style */
267 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
268 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
269 pl_yylval.ival = (f); \
275 #define COPLINE_INC_WITH_HERELINES \
277 CopLINE_inc(PL_curcop); \
278 if (PL_parser->herelines) \
279 CopLINE(PL_curcop) += PL_parser->herelines, \
280 PL_parser->herelines = 0; \
282 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
283 * is no sublex_push to follow. */
284 #define COPLINE_SET_FROM_MULTI_END \
286 CopLINE_set(PL_curcop, PL_multi_end); \
287 if (PL_multi_end != PL_multi_start) \
288 PL_parser->herelines = 0; \
294 /* how to interpret the pl_yylval associated with the token */
298 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
303 static struct debug_tokens {
305 enum token_type type;
307 } const debug_tokens[] =
309 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
310 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
311 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
312 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
313 { ARROW, TOKENTYPE_NONE, "ARROW" },
314 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
315 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
316 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
317 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
318 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
319 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
320 { DO, TOKENTYPE_NONE, "DO" },
321 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
322 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
323 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
324 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
325 { ELSE, TOKENTYPE_NONE, "ELSE" },
326 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
327 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
328 { FOR, TOKENTYPE_IVAL, "FOR" },
329 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
330 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
331 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
332 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
333 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
334 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
335 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
336 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
337 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
338 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
339 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
340 { IF, TOKENTYPE_IVAL, "IF" },
341 { LABEL, TOKENTYPE_PVAL, "LABEL" },
342 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
343 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
344 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
345 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
346 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
347 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
348 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
349 { MY, TOKENTYPE_IVAL, "MY" },
350 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
351 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
352 { OROP, TOKENTYPE_IVAL, "OROP" },
353 { OROR, TOKENTYPE_NONE, "OROR" },
354 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
355 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
356 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
357 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
358 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
359 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
360 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
361 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
362 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
363 { PREINC, TOKENTYPE_NONE, "PREINC" },
364 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
365 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
366 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
367 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
368 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
369 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
370 { SUB, TOKENTYPE_NONE, "SUB" },
371 { THING, TOKENTYPE_OPVAL, "THING" },
372 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
373 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
374 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
375 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
376 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
377 { USE, TOKENTYPE_IVAL, "USE" },
378 { WHEN, TOKENTYPE_IVAL, "WHEN" },
379 { WHILE, TOKENTYPE_IVAL, "WHILE" },
380 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
381 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
382 { 0, TOKENTYPE_NONE, NULL }
385 /* dump the returned token in rv, plus any optional arg in pl_yylval */
388 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
390 PERL_ARGS_ASSERT_TOKEREPORT;
393 const char *name = NULL;
394 enum token_type type = TOKENTYPE_NONE;
395 const struct debug_tokens *p;
396 SV* const report = newSVpvs("<== ");
398 for (p = debug_tokens; p->token; p++) {
399 if (p->token == (int)rv) {
406 Perl_sv_catpv(aTHX_ report, name);
407 else if (isGRAPH(rv))
409 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
411 sv_catpvs(report, " (pending identifier)");
414 sv_catpvs(report, "EOF");
416 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
421 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
423 case TOKENTYPE_OPNUM:
424 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
425 PL_op_name[lvalp->ival]);
428 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
430 case TOKENTYPE_OPVAL:
432 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
433 PL_op_name[lvalp->opval->op_type]);
434 if (lvalp->opval->op_type == OP_CONST) {
435 Perl_sv_catpvf(aTHX_ report, " %s",
436 SvPEEK(cSVOPx_sv(lvalp->opval)));
441 sv_catpvs(report, "(opval=null)");
444 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
450 /* print the buffer with suitable escapes */
453 S_printbuf(pTHX_ const char *const fmt, const char *const s)
455 SV* const tmp = newSVpvs("");
457 PERL_ARGS_ASSERT_PRINTBUF;
459 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
460 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
461 GCC_DIAG_RESTORE_STMT;
470 * This subroutine looks for an '=' next to the operator that has just been
471 * parsed and turns it into an ASSIGNOP if it finds one.
475 S_ao(pTHX_ int toketype)
477 if (*PL_bufptr == '=') {
479 if (toketype == ANDAND)
480 pl_yylval.ival = OP_ANDASSIGN;
481 else if (toketype == OROR)
482 pl_yylval.ival = OP_ORASSIGN;
483 else if (toketype == DORDOR)
484 pl_yylval.ival = OP_DORASSIGN;
487 return REPORT(toketype);
492 * When Perl expects an operator and finds something else, no_op
493 * prints the warning. It always prints "<something> found where
494 * operator expected. It prints "Missing semicolon on previous line?"
495 * if the surprise occurs at the start of the line. "do you need to
496 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
497 * where the compiler doesn't know if foo is a method call or a function.
498 * It prints "Missing operator before end of line" if there's nothing
499 * after the missing operator, or "... before <...>" if there is something
500 * after the missing operator.
502 * PL_bufptr is expected to point to the start of the thing that was found,
503 * and s after the next token or partial token.
507 S_no_op(pTHX_ const char *const what, char *s)
509 char * const oldbp = PL_bufptr;
510 const bool is_first = (PL_oldbufptr == PL_linestart);
512 PERL_ARGS_ASSERT_NO_OP;
518 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
519 if (ckWARN_d(WARN_SYNTAX)) {
521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
522 "\t(Missing semicolon on previous line?)\n");
523 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
528 for (t = PL_oldoldbufptr;
529 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
530 t += UTF ? UTF8SKIP(t) : 1)
534 if (t < PL_bufptr && isSPACE(*t))
535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
536 "\t(Do you need to predeclare %" UTF8f "?)\n",
537 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
541 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
542 "\t(Missing operator before %" UTF8f "?)\n",
543 UTF8fARG(UTF, s - oldbp, oldbp));
551 * Complain about missing quote/regexp/heredoc terminator.
552 * If it's called with NULL then it cauterizes the line buffer.
553 * If we're in a delimited string and the delimiter is a control
554 * character, it's reformatted into a two-char sequence like ^C.
559 S_missingterm(pTHX_ char *s, STRLEN len)
561 char tmpbuf[UTF8_MAXBYTES + 1];
566 char * const nl = (char *) my_memrchr(s, '\n', len);
573 else if (PL_multi_close < 32) {
575 tmpbuf[1] = (char)toCTRL(PL_multi_close);
581 if (LIKELY(PL_multi_close < 256)) {
582 *tmpbuf = (char)PL_multi_close;
587 char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close);
594 q = memchr(s, '"', len) ? '\'' : '"';
595 sv = sv_2mortal(newSVpvn(s, len));
598 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c"
599 " anywhere before EOF", q, SVfARG(sv), q);
605 * Check whether the named feature is enabled.
608 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
610 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
612 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
614 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
616 if (namelen > MAX_FEATURE_LEN)
618 memcpy(&he_name[8], name, namelen);
620 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
621 REFCOUNTED_HE_EXISTS));
625 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
626 * utf16-to-utf8-reversed.
629 #ifdef PERL_CR_FILTER
633 const char *s = SvPVX_const(sv);
634 const char * const e = s + SvCUR(sv);
636 PERL_ARGS_ASSERT_STRIP_RETURN;
638 /* outer loop optimized to do nothing if there are no CR-LFs */
640 if (*s++ == '\r' && *s == '\n') {
641 /* hit a CR-LF, need to copy the rest */
645 if (*s == '\r' && s[1] == '\n')
656 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
658 const I32 count = FILTER_READ(idx+1, sv, maxlen);
659 if (count > 0 && !maxlen)
666 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
668 Creates and initialises a new lexer/parser state object, supplying
669 a context in which to lex and parse from a new source of Perl code.
670 A pointer to the new state object is placed in L</PL_parser>. An entry
671 is made on the save stack so that upon unwinding, the new state object
672 will be destroyed and the former value of L</PL_parser> will be restored.
673 Nothing else need be done to clean up the parsing context.
675 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
676 non-null, provides a string (in SV form) containing code to be parsed.
677 A copy of the string is made, so subsequent modification of C<line>
678 does not affect parsing. C<rsfp>, if non-null, provides an input stream
679 from which code will be read to be parsed. If both are non-null, the
680 code in C<line> comes first and must consist of complete lines of input,
681 and C<rsfp> supplies the remainder of the source.
683 The C<flags> parameter is reserved for future use. Currently it is only
684 used by perl internally, so extensions should always pass zero.
689 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
690 can share filters with the current parser.
691 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
692 caller, hence isn't owned by the parser, so shouldn't be closed on parser
693 destruction. This is used to handle the case of defaulting to reading the
694 script from the standard input because no filename was given on the command
695 line (without getting confused by situation where STDIN has been closed, so
696 the script handle is opened on fd 0) */
699 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
701 const char *s = NULL;
702 yy_parser *parser, *oparser;
704 if (flags && flags & ~LEX_START_FLAGS)
705 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
707 /* create and initialise a parser */
709 Newxz(parser, 1, yy_parser);
710 parser->old_parser = oparser = PL_parser;
713 parser->stack = NULL;
714 parser->stack_max1 = NULL;
717 /* on scope exit, free this parser and restore any outer one */
719 parser->saved_curcop = PL_curcop;
721 /* initialise lexer state */
723 parser->nexttoke = 0;
724 parser->error_count = oparser ? oparser->error_count : 0;
725 parser->copline = parser->preambling = NOLINE;
726 parser->lex_state = LEX_NORMAL;
727 parser->expect = XSTATE;
729 parser->recheck_utf8_validity = FALSE;
730 parser->rsfp_filters =
731 !(flags & LEX_START_SAME_FILTER) || !oparser
733 : MUTABLE_AV(SvREFCNT_inc(
734 oparser->rsfp_filters
735 ? oparser->rsfp_filters
736 : (oparser->rsfp_filters = newAV())
739 Newx(parser->lex_brackstack, 120, char);
740 Newx(parser->lex_casestack, 12, char);
741 *parser->lex_casestack = '\0';
742 Newxz(parser->lex_shared, 1, LEXSHARED);
746 const U8* first_bad_char_loc;
748 s = SvPV_const(line, len);
751 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
753 &first_bad_char_loc)))
755 _force_out_malformed_utf8_message(first_bad_char_loc,
756 (U8 *) s + SvCUR(line),
758 1 /* 1 means die */ );
759 NOT_REACHED; /* NOTREACHED */
762 parser->linestr = flags & LEX_START_COPIED
763 ? SvREFCNT_inc_simple_NN(line)
764 : newSVpvn_flags(s, len, SvUTF8(line));
766 sv_catpvs(parser->linestr, "\n;");
768 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
771 parser->oldoldbufptr =
774 parser->linestart = SvPVX(parser->linestr);
775 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
776 parser->last_lop = parser->last_uni = NULL;
778 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
779 |LEX_DONT_CLOSE_RSFP));
780 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
781 |LEX_DONT_CLOSE_RSFP));
783 parser->in_pod = parser->filtered = 0;
787 /* delete a parser object */
790 Perl_parser_free(pTHX_ const yy_parser *parser)
792 PERL_ARGS_ASSERT_PARSER_FREE;
794 PL_curcop = parser->saved_curcop;
795 SvREFCNT_dec(parser->linestr);
797 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
798 PerlIO_clearerr(parser->rsfp);
799 else if (parser->rsfp && (!parser->old_parser
800 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
801 PerlIO_close(parser->rsfp);
802 SvREFCNT_dec(parser->rsfp_filters);
803 SvREFCNT_dec(parser->lex_stuff);
804 SvREFCNT_dec(parser->lex_sub_repl);
806 Safefree(parser->lex_brackstack);
807 Safefree(parser->lex_casestack);
808 Safefree(parser->lex_shared);
809 PL_parser = parser->old_parser;
814 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
816 I32 nexttoke = parser->nexttoke;
817 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
819 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
820 && parser->nextval[nexttoke].opval
821 && parser->nextval[nexttoke].opval->op_slabbed
822 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
823 op_free(parser->nextval[nexttoke].opval);
824 parser->nextval[nexttoke].opval = NULL;
831 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
833 Buffer scalar containing the chunk currently under consideration of the
834 text currently being lexed. This is always a plain string scalar (for
835 which C<SvPOK> is true). It is not intended to be used as a scalar by
836 normal scalar means; instead refer to the buffer directly by the pointer
837 variables described below.
839 The lexer maintains various C<char*> pointers to things in the
840 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
841 reallocated, all of these pointers must be updated. Don't attempt to
842 do this manually, but rather use L</lex_grow_linestr> if you need to
843 reallocate the buffer.
845 The content of the text chunk in the buffer is commonly exactly one
846 complete line of input, up to and including a newline terminator,
847 but there are situations where it is otherwise. The octets of the
848 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
849 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
850 flag on this scalar, which may disagree with it.
852 For direct examination of the buffer, the variable
853 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
854 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
855 of these pointers is usually preferable to examination of the scalar
856 through normal scalar means.
858 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
860 Direct pointer to the end of the chunk of text currently being lexed, the
861 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
862 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
863 always located at the end of the buffer, and does not count as part of
864 the buffer's contents.
866 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
868 Points to the current position of lexing inside the lexer buffer.
869 Characters around this point may be freely examined, within
870 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
871 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
872 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
874 Lexing code (whether in the Perl core or not) moves this pointer past
875 the characters that it consumes. It is also expected to perform some
876 bookkeeping whenever a newline character is consumed. This movement
877 can be more conveniently performed by the function L</lex_read_to>,
878 which handles newlines appropriately.
880 Interpretation of the buffer's octets can be abstracted out by
881 using the slightly higher-level functions L</lex_peek_unichar> and
882 L</lex_read_unichar>.
884 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
886 Points to the start of the current line inside the lexer buffer.
887 This is useful for indicating at which column an error occurred, and
888 not much else. This must be updated by any lexing code that consumes
889 a newline; the function L</lex_read_to> handles this detail.
895 =for apidoc Amx|bool|lex_bufutf8
897 Indicates whether the octets in the lexer buffer
898 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
899 of Unicode characters. If not, they should be interpreted as Latin-1
900 characters. This is analogous to the C<SvUTF8> flag for scalars.
902 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
903 contains valid UTF-8. Lexing code must be robust in the face of invalid
906 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
907 is significant, but not the whole story regarding the input character
908 encoding. Normally, when a file is being read, the scalar contains octets
909 and its C<SvUTF8> flag is off, but the octets should be interpreted as
910 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
911 however, the scalar may have the C<SvUTF8> flag on, and in this case its
912 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
913 is in effect. This logic may change in the future; use this function
914 instead of implementing the logic yourself.
920 Perl_lex_bufutf8(pTHX)
926 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
928 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
929 at least C<len> octets (including terminating C<NUL>). Returns a
930 pointer to the reallocated buffer. This is necessary before making
931 any direct modification of the buffer that would increase its length.
932 L</lex_stuff_pvn> provides a more convenient way to insert text into
935 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
936 this function updates all of the lexer's variables that point directly
943 Perl_lex_grow_linestr(pTHX_ STRLEN len)
947 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
948 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
951 linestr = PL_parser->linestr;
952 buf = SvPVX(linestr);
953 if (len <= SvLEN(linestr))
956 /* Is the lex_shared linestr SV the same as the current linestr SV?
957 * Only in this case does re_eval_start need adjusting, since it
958 * points within lex_shared->ls_linestr's buffer */
959 current = ( !PL_parser->lex_shared->ls_linestr
960 || linestr == PL_parser->lex_shared->ls_linestr);
962 bufend_pos = PL_parser->bufend - buf;
963 bufptr_pos = PL_parser->bufptr - buf;
964 oldbufptr_pos = PL_parser->oldbufptr - buf;
965 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
966 linestart_pos = PL_parser->linestart - buf;
967 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
968 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
969 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
970 PL_parser->lex_shared->re_eval_start - buf : 0;
972 buf = sv_grow(linestr, len);
974 PL_parser->bufend = buf + bufend_pos;
975 PL_parser->bufptr = buf + bufptr_pos;
976 PL_parser->oldbufptr = buf + oldbufptr_pos;
977 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
978 PL_parser->linestart = buf + linestart_pos;
979 if (PL_parser->last_uni)
980 PL_parser->last_uni = buf + last_uni_pos;
981 if (PL_parser->last_lop)
982 PL_parser->last_lop = buf + last_lop_pos;
983 if (current && PL_parser->lex_shared->re_eval_start)
984 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
989 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
991 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
992 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
993 reallocating the buffer if necessary. This means that lexing code that
994 runs later will see the characters as if they had appeared in the input.
995 It is not recommended to do this as part of normal parsing, and most
996 uses of this facility run the risk of the inserted characters being
997 interpreted in an unintended manner.
999 The string to be inserted is represented by C<len> octets starting
1000 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1001 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1002 The characters are recoded for the lexer buffer, according to how the
1003 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1004 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1005 function is more convenient.
1011 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1015 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1016 if (flags & ~(LEX_STUFF_UTF8))
1017 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1019 if (flags & LEX_STUFF_UTF8) {
1022 STRLEN highhalf = 0; /* Count of variants */
1023 const char *p, *e = pv+len;
1024 for (p = pv; p != e; p++) {
1025 if (! UTF8_IS_INVARIANT(*p)) {
1031 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1032 bufptr = PL_parser->bufptr;
1033 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1034 SvCUR_set(PL_parser->linestr,
1035 SvCUR(PL_parser->linestr) + len+highhalf);
1036 PL_parser->bufend += len+highhalf;
1037 for (p = pv; p != e; p++) {
1038 append_utf8_from_native_byte(*p, (U8 **) &bufptr);
1042 if (flags & LEX_STUFF_UTF8) {
1043 STRLEN highhalf = 0;
1044 const char *p, *e = pv+len;
1045 for (p = pv; p != e; p++) {
1047 if (UTF8_IS_ABOVE_LATIN1(c)) {
1048 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1049 "non-Latin-1 character into Latin-1 input");
1050 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1053 } else assert(UTF8_IS_INVARIANT(c));
1057 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1058 bufptr = PL_parser->bufptr;
1059 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1060 SvCUR_set(PL_parser->linestr,
1061 SvCUR(PL_parser->linestr) + len-highhalf);
1062 PL_parser->bufend += len-highhalf;
1065 if (UTF8_IS_INVARIANT(*p)) {
1071 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1077 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1078 bufptr = PL_parser->bufptr;
1079 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1080 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1081 PL_parser->bufend += len;
1082 Copy(pv, bufptr, len, char);
1088 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1090 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1091 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1092 reallocating the buffer if necessary. This means that lexing code that
1093 runs later will see the characters as if they had appeared in the input.
1094 It is not recommended to do this as part of normal parsing, and most
1095 uses of this facility run the risk of the inserted characters being
1096 interpreted in an unintended manner.
1098 The string to be inserted is represented by octets starting at C<pv>
1099 and continuing to the first nul. These octets are interpreted as either
1100 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1101 in C<flags>. The characters are recoded for the lexer buffer, according
1102 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1103 If it is not convenient to nul-terminate a string to be inserted, the
1104 L</lex_stuff_pvn> function is more appropriate.
1110 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1112 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1113 lex_stuff_pvn(pv, strlen(pv), flags);
1117 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1119 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1120 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1121 reallocating the buffer if necessary. This means that lexing code that
1122 runs later will see the characters as if they had appeared in the input.
1123 It is not recommended to do this as part of normal parsing, and most
1124 uses of this facility run the risk of the inserted characters being
1125 interpreted in an unintended manner.
1127 The string to be inserted is the string value of C<sv>. The characters
1128 are recoded for the lexer buffer, according to how the buffer is currently
1129 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1130 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1131 need to construct a scalar.
1137 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1141 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1143 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1145 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1149 =for apidoc Amx|void|lex_unstuff|char *ptr
1151 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1152 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1153 This hides the discarded text from any lexing code that runs later,
1154 as if the text had never appeared.
1156 This is not the normal way to consume lexed text. For that, use
1163 Perl_lex_unstuff(pTHX_ char *ptr)
1167 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1168 buf = PL_parser->bufptr;
1170 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1173 bufend = PL_parser->bufend;
1175 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1176 unstuff_len = ptr - buf;
1177 Move(ptr, buf, bufend+1-ptr, char);
1178 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1179 PL_parser->bufend = bufend - unstuff_len;
1183 =for apidoc Amx|void|lex_read_to|char *ptr
1185 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1186 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1187 performing the correct bookkeeping whenever a newline character is passed.
1188 This is the normal way to consume lexed text.
1190 Interpretation of the buffer's octets can be abstracted out by
1191 using the slightly higher-level functions L</lex_peek_unichar> and
1192 L</lex_read_unichar>.
1198 Perl_lex_read_to(pTHX_ char *ptr)
1201 PERL_ARGS_ASSERT_LEX_READ_TO;
1202 s = PL_parser->bufptr;
1203 if (ptr < s || ptr > PL_parser->bufend)
1204 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1205 for (; s != ptr; s++)
1207 COPLINE_INC_WITH_HERELINES;
1208 PL_parser->linestart = s+1;
1210 PL_parser->bufptr = ptr;
1214 =for apidoc Amx|void|lex_discard_to|char *ptr
1216 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1217 up to C<ptr>. The remaining content of the buffer will be moved, and
1218 all pointers into the buffer updated appropriately. C<ptr> must not
1219 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1220 it is not permitted to discard text that has yet to be lexed.
1222 Normally it is not necessarily to do this directly, because it suffices to
1223 use the implicit discarding behaviour of L</lex_next_chunk> and things
1224 based on it. However, if a token stretches across multiple lines,
1225 and the lexing code has kept multiple lines of text in the buffer for
1226 that purpose, then after completion of the token it would be wise to
1227 explicitly discard the now-unneeded earlier lines, to avoid future
1228 multi-line tokens growing the buffer without bound.
1234 Perl_lex_discard_to(pTHX_ char *ptr)
1238 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1239 buf = SvPVX(PL_parser->linestr);
1241 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1244 if (ptr > PL_parser->bufptr)
1245 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1246 discard_len = ptr - buf;
1247 if (PL_parser->oldbufptr < ptr)
1248 PL_parser->oldbufptr = ptr;
1249 if (PL_parser->oldoldbufptr < ptr)
1250 PL_parser->oldoldbufptr = ptr;
1251 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1252 PL_parser->last_uni = NULL;
1253 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1254 PL_parser->last_lop = NULL;
1255 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1256 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1257 PL_parser->bufend -= discard_len;
1258 PL_parser->bufptr -= discard_len;
1259 PL_parser->oldbufptr -= discard_len;
1260 PL_parser->oldoldbufptr -= discard_len;
1261 if (PL_parser->last_uni)
1262 PL_parser->last_uni -= discard_len;
1263 if (PL_parser->last_lop)
1264 PL_parser->last_lop -= discard_len;
1268 Perl_notify_parser_that_changed_to_utf8(pTHX)
1270 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1271 * off to on. At compile time, this has the effect of entering a 'use
1272 * utf8' section. This means that any input was not previously checked for
1273 * UTF-8 (because it was off), but now we do need to check it, or our
1274 * assumptions about the input being sane could be wrong, and we could
1275 * segfault. This routine just sets a flag so that the next time we look
1276 * at the input we do the well-formed UTF-8 check. If we aren't in the
1277 * proper phase, there may not be a parser object, but if there is, setting
1278 * the flag is harmless */
1281 PL_parser->recheck_utf8_validity = TRUE;
1286 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1288 Reads in the next chunk of text to be lexed, appending it to
1289 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1290 looked to the end of the current chunk and wants to know more. It is
1291 usual, but not necessary, for lexing to have consumed the entirety of
1292 the current chunk at this time.
1294 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1295 chunk (i.e., the current chunk has been entirely consumed), normally the
1296 current chunk will be discarded at the same time that the new chunk is
1297 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1298 will not be discarded. If the current chunk has not been entirely
1299 consumed, then it will not be discarded regardless of the flag.
1301 Returns true if some new text was added to the buffer, or false if the
1302 buffer has reached the end of the input text.
1307 #define LEX_FAKE_EOF 0x80000000
1308 #define LEX_NO_TERM 0x40000000 /* here-doc */
1311 Perl_lex_next_chunk(pTHX_ U32 flags)
1315 STRLEN old_bufend_pos, new_bufend_pos;
1316 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1317 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1318 bool got_some_for_debugger = 0;
1321 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1322 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1323 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1325 linestr = PL_parser->linestr;
1326 buf = SvPVX(linestr);
1327 if (!(flags & LEX_KEEP_PREVIOUS)
1328 && PL_parser->bufptr == PL_parser->bufend)
1330 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1332 if (PL_parser->last_uni != PL_parser->bufend)
1333 PL_parser->last_uni = NULL;
1334 if (PL_parser->last_lop != PL_parser->bufend)
1335 PL_parser->last_lop = NULL;
1336 last_uni_pos = last_lop_pos = 0;
1340 old_bufend_pos = PL_parser->bufend - buf;
1341 bufptr_pos = PL_parser->bufptr - buf;
1342 oldbufptr_pos = PL_parser->oldbufptr - buf;
1343 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1344 linestart_pos = PL_parser->linestart - buf;
1345 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1346 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1348 if (flags & LEX_FAKE_EOF) {
1350 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1352 } else if (filter_gets(linestr, old_bufend_pos)) {
1354 got_some_for_debugger = 1;
1355 } else if (flags & LEX_NO_TERM) {
1358 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1361 /* End of real input. Close filehandle (unless it was STDIN),
1362 * then add implicit termination.
1364 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1365 PerlIO_clearerr(PL_parser->rsfp);
1366 else if (PL_parser->rsfp)
1367 (void)PerlIO_close(PL_parser->rsfp);
1368 PL_parser->rsfp = NULL;
1369 PL_parser->in_pod = PL_parser->filtered = 0;
1370 if (!PL_in_eval && PL_minus_p) {
1372 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1373 PL_minus_n = PL_minus_p = 0;
1374 } else if (!PL_in_eval && PL_minus_n) {
1375 sv_catpvs(linestr, /*{*/";}");
1378 sv_catpvs(linestr, ";");
1381 buf = SvPVX(linestr);
1382 new_bufend_pos = SvCUR(linestr);
1383 PL_parser->bufend = buf + new_bufend_pos;
1384 PL_parser->bufptr = buf + bufptr_pos;
1387 const U8* first_bad_char_loc;
1388 if (UNLIKELY(! is_utf8_string_loc(
1389 (U8 *) PL_parser->bufptr,
1390 PL_parser->bufend - PL_parser->bufptr,
1391 &first_bad_char_loc)))
1393 _force_out_malformed_utf8_message(first_bad_char_loc,
1394 (U8 *) PL_parser->bufend,
1396 1 /* 1 means die */ );
1397 NOT_REACHED; /* NOTREACHED */
1401 PL_parser->oldbufptr = buf + oldbufptr_pos;
1402 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1403 PL_parser->linestart = buf + linestart_pos;
1404 if (PL_parser->last_uni)
1405 PL_parser->last_uni = buf + last_uni_pos;
1406 if (PL_parser->last_lop)
1407 PL_parser->last_lop = buf + last_lop_pos;
1408 if (PL_parser->preambling != NOLINE) {
1409 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1410 PL_parser->preambling = NOLINE;
1412 if ( got_some_for_debugger
1413 && PERLDB_LINE_OR_SAVESRC
1414 && PL_curstash != PL_debstash)
1416 /* debugger active and we're not compiling the debugger code,
1417 * so store the line into the debugger's array of lines
1419 update_debugger_info(NULL, buf+old_bufend_pos,
1420 new_bufend_pos-old_bufend_pos);
1426 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1428 Looks ahead one (Unicode) character in the text currently being lexed.
1429 Returns the codepoint (unsigned integer value) of the next character,
1430 or -1 if lexing has reached the end of the input text. To consume the
1431 peeked character, use L</lex_read_unichar>.
1433 If the next character is in (or extends into) the next chunk of input
1434 text, the next chunk will be read in. Normally the current chunk will be
1435 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1436 bit set, then the current chunk will not be discarded.
1438 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1439 is encountered, an exception is generated.
1445 Perl_lex_peek_unichar(pTHX_ U32 flags)
1449 if (flags & ~(LEX_KEEP_PREVIOUS))
1450 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1451 s = PL_parser->bufptr;
1452 bufend = PL_parser->bufend;
1458 if (!lex_next_chunk(flags))
1460 s = PL_parser->bufptr;
1461 bufend = PL_parser->bufend;
1464 if (UTF8_IS_INVARIANT(head))
1466 if (UTF8_IS_START(head)) {
1467 len = UTF8SKIP(&head);
1468 while ((STRLEN)(bufend-s) < len) {
1469 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1471 s = PL_parser->bufptr;
1472 bufend = PL_parser->bufend;
1475 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1476 if (retlen == (STRLEN)-1) {
1477 _force_out_malformed_utf8_message((U8 *) s,
1480 1 /* 1 means die */ );
1481 NOT_REACHED; /* NOTREACHED */
1486 if (!lex_next_chunk(flags))
1488 s = PL_parser->bufptr;
1495 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1497 Reads the next (Unicode) character in the text currently being lexed.
1498 Returns the codepoint (unsigned integer value) of the character read,
1499 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1500 if lexing has reached the end of the input text. To non-destructively
1501 examine the next character, use L</lex_peek_unichar> instead.
1503 If the next character is in (or extends into) the next chunk of input
1504 text, the next chunk will be read in. Normally the current chunk will be
1505 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1506 bit set, then the current chunk will not be discarded.
1508 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1509 is encountered, an exception is generated.
1515 Perl_lex_read_unichar(pTHX_ U32 flags)
1518 if (flags & ~(LEX_KEEP_PREVIOUS))
1519 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1520 c = lex_peek_unichar(flags);
1523 COPLINE_INC_WITH_HERELINES;
1525 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1527 ++(PL_parser->bufptr);
1533 =for apidoc Amx|void|lex_read_space|U32 flags
1535 Reads optional spaces, in Perl style, in the text currently being
1536 lexed. The spaces may include ordinary whitespace characters and
1537 Perl-style comments. C<#line> directives are processed if encountered.
1538 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1539 at a non-space character (or the end of the input text).
1541 If spaces extend into the next chunk of input text, the next chunk will
1542 be read in. Normally the current chunk will be discarded at the same
1543 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1544 chunk will not be discarded.
1549 #define LEX_NO_INCLINE 0x40000000
1550 #define LEX_NO_NEXT_CHUNK 0x80000000
1553 Perl_lex_read_space(pTHX_ U32 flags)
1556 const bool can_incline = !(flags & LEX_NO_INCLINE);
1557 bool need_incline = 0;
1558 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1559 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1560 s = PL_parser->bufptr;
1561 bufend = PL_parser->bufend;
1567 } while (!(c == '\n' || (c == 0 && s == bufend)));
1568 } else if (c == '\n') {
1571 PL_parser->linestart = s;
1577 } else if (isSPACE(c)) {
1579 } else if (c == 0 && s == bufend) {
1582 if (flags & LEX_NO_NEXT_CHUNK)
1584 PL_parser->bufptr = s;
1585 l = CopLINE(PL_curcop);
1586 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1587 got_more = lex_next_chunk(flags);
1588 CopLINE_set(PL_curcop, l);
1589 s = PL_parser->bufptr;
1590 bufend = PL_parser->bufend;
1593 if (can_incline && need_incline && PL_parser->rsfp) {
1603 PL_parser->bufptr = s;
1608 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1610 This function performs syntax checking on a prototype, C<proto>.
1611 If C<warn> is true, any illegal characters or mismatched brackets
1612 will trigger illegalproto warnings, declaring that they were
1613 detected in the prototype for C<name>.
1615 The return value is C<true> if this is a valid prototype, and
1616 C<false> if it is not, regardless of whether C<warn> was C<true> or
1619 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1626 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1628 STRLEN len, origlen;
1630 bool bad_proto = FALSE;
1631 bool in_brackets = FALSE;
1632 bool after_slash = FALSE;
1633 char greedy_proto = ' ';
1634 bool proto_after_greedy_proto = FALSE;
1635 bool must_be_last = FALSE;
1636 bool underscore = FALSE;
1637 bool bad_proto_after_underscore = FALSE;
1639 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1644 p = SvPV(proto, len);
1646 for (; len--; p++) {
1649 proto_after_greedy_proto = TRUE;
1651 if (!strchr(";@%", *p))
1652 bad_proto_after_underscore = TRUE;
1655 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1662 in_brackets = FALSE;
1663 else if ((*p == '@' || *p == '%')
1667 must_be_last = TRUE;
1676 after_slash = FALSE;
1681 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1684 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1685 origlen, UNI_DISPLAY_ISPRINT)
1686 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1688 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1689 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1690 sv_catpvs(name2, "::");
1691 sv_catsv(name2, (SV *)name);
1695 if (proto_after_greedy_proto)
1696 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1697 "Prototype after '%c' for %" SVf " : %s",
1698 greedy_proto, SVfARG(name), p);
1700 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1701 "Missing ']' in prototype for %" SVf " : %s",
1704 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1705 "Illegal character in prototype for %" SVf " : %s",
1707 if (bad_proto_after_underscore)
1708 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1709 "Illegal character after '_' in prototype for %" SVf " : %s",
1713 return (! (proto_after_greedy_proto || bad_proto) );
1718 * This subroutine has nothing to do with tilting, whether at windmills
1719 * or pinball tables. Its name is short for "increment line". It
1720 * increments the current line number in CopLINE(PL_curcop) and checks
1721 * to see whether the line starts with a comment of the form
1722 * # line 500 "foo.pm"
1723 * If so, it sets the current line number and file to the values in the comment.
1727 S_incline(pTHX_ const char *s, const char *end)
1735 PERL_ARGS_ASSERT_INCLINE;
1739 COPLINE_INC_WITH_HERELINES;
1740 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1741 && s+1 == PL_bufend && *s == ';') {
1742 /* fake newline in string eval */
1743 CopLINE_dec(PL_curcop);
1748 while (SPACE_OR_TAB(*s))
1750 if (memBEGINs(s, (STRLEN) (end - s), "line"))
1751 s += sizeof("line") - 1;
1754 if (SPACE_OR_TAB(*s))
1758 while (SPACE_OR_TAB(*s))
1766 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1768 while (SPACE_OR_TAB(*s))
1770 if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) {
1776 while (*t && !isSPACE(*t))
1780 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1782 if (*e != '\n' && *e != '\0')
1783 return; /* false alarm */
1785 if (!grok_atoUV(n, &uv, &e))
1787 line_num = ((line_t)uv) - 1;
1790 const STRLEN len = t - s;
1792 if (!PL_rsfp && !PL_parser->filtered) {
1793 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1794 * to *{"::_<newfilename"} */
1795 /* However, the long form of evals is only turned on by the
1796 debugger - usually they're "(eval %lu)" */
1797 GV * const cfgv = CopFILEGV(PL_curcop);
1800 STRLEN tmplen2 = len;
1804 if (tmplen2 + 2 <= sizeof smallbuf)
1807 Newx(tmpbuf2, tmplen2 + 2, char);
1812 memcpy(tmpbuf2 + 2, s, tmplen2);
1815 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1817 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1818 /* adjust ${"::_<newfilename"} to store the new file name */
1819 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1820 /* The line number may differ. If that is the case,
1821 alias the saved lines that are in the array.
1822 Otherwise alias the whole array. */
1823 if (CopLINE(PL_curcop) == line_num) {
1824 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1825 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1827 else if (GvAV(cfgv)) {
1828 AV * const av = GvAV(cfgv);
1829 const I32 start = CopLINE(PL_curcop)+1;
1830 I32 items = AvFILLp(av) - start;
1832 AV * const av2 = GvAVn(gv2);
1833 SV **svp = AvARRAY(av) + start;
1834 I32 l = (I32)line_num+1;
1836 av_store(av2, l++, SvREFCNT_inc(*svp++));
1841 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1844 CopFILE_free(PL_curcop);
1845 CopFILE_setn(PL_curcop, s, len);
1847 CopLINE_set(PL_curcop, line_num);
1851 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1853 AV *av = CopFILEAVx(PL_curcop);
1856 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1858 sv = *av_fetch(av, 0, 1);
1859 SvUPGRADE(sv, SVt_PVMG);
1861 if (!SvPOK(sv)) SvPVCLEAR(sv);
1863 sv_catsv(sv, orig_sv);
1865 sv_catpvn(sv, buf, len);
1870 if (PL_parser->preambling == NOLINE)
1871 av_store(av, CopLINE(PL_curcop), sv);
1877 * Called to gobble the appropriate amount and type of whitespace.
1878 * Skips comments as well.
1879 * Returns the next character after the whitespace that is skipped.
1882 * Same thing, but look ahead without incrementing line numbers or
1883 * adjusting PL_linestart.
1886 #define skipspace(s) skipspace_flags(s, 0)
1887 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1890 S_skipspace_flags(pTHX_ char *s, U32 flags)
1892 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1893 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1894 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1897 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1899 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1900 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1901 LEX_NO_NEXT_CHUNK : 0));
1903 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1904 if (PL_linestart > PL_bufptr)
1905 PL_bufptr = PL_linestart;
1913 * Check the unary operators to ensure there's no ambiguity in how they're
1914 * used. An ambiguous piece of code would be:
1916 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1917 * the +5 is its argument.
1925 if (PL_oldoldbufptr != PL_last_uni)
1927 while (isSPACE(*PL_last_uni))
1930 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1931 s += UTF ? UTF8SKIP(s) : 1;
1932 if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s))
1935 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1936 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1937 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1941 * LOP : macro to build a list operator. Its behaviour has been replaced
1942 * with a subroutine, S_lop() for which LOP is just another name.
1945 #define LOP(f,x) return lop(f,x,s)
1949 * Build a list operator (or something that might be one). The rules:
1950 * - if we have a next token, then it's a list operator (no parens) for
1951 * which the next token has already been parsed; e.g.,
1954 * - if the next thing is an opening paren, then it's a function
1955 * - else it's a list operator
1959 S_lop(pTHX_ I32 f, U8 x, char *s)
1961 PERL_ARGS_ASSERT_LOP;
1966 PL_last_lop = PL_oldbufptr;
1967 PL_last_lop_op = (OPCODE)f;
1972 return REPORT(FUNC);
1975 return REPORT(FUNC);
1978 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1979 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1980 return REPORT(LSTOP);
1986 * When the lexer realizes it knows the next token (for instance,
1987 * it is reordering tokens for the parser) then it can call S_force_next
1988 * to know what token to return the next time the lexer is called. Caller
1989 * will need to set PL_nextval[] and possibly PL_expect to ensure
1990 * the lexer handles the token correctly.
1994 S_force_next(pTHX_ I32 type)
1998 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1999 tokereport(type, &NEXTVAL_NEXTTOKE);
2002 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2003 PL_nexttype[PL_nexttoke] = type;
2010 * This subroutine handles postfix deref syntax after the arrow has already
2011 * been emitted. @* $* etc. are emitted as two separate tokens right here.
2012 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2013 * only the first, leaving yylex to find the next.
2017 S_postderef(pTHX_ int const funny, char const next)
2019 assert(funny == DOLSHARP || strchr("$@%&*", funny));
2021 PL_expect = XOPERATOR;
2022 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2023 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2024 PL_lex_state = LEX_INTERPEND;
2026 force_next(POSTJOIN);
2032 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2033 && !PL_lex_brackets)
2035 PL_expect = XOPERATOR;
2044 int yyc = PL_parser->yychar;
2045 if (yyc != YYEMPTY) {
2047 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2048 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2049 PL_lex_allbrackets--;
2051 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2052 } else if (yyc == '('/*)*/) {
2053 PL_lex_allbrackets--;
2058 PL_parser->yychar = YYEMPTY;
2063 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2065 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);
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_lex_state = LEX_INTERPPUSH;
2397 pl_yylval.opval = PL_lex_op;
2407 * Create a new scope to save the lexing state. The scope will be
2408 * ended in S_sublex_done. Returns a '(', starting the function arguments
2409 * to the uc, lc, etc. found before.
2410 * Sets PL_lex_state to LEX_INTERPCONCAT.
2417 const bool is_heredoc = PL_multi_close == '<';
2420 PL_lex_state = PL_parser->lex_super_state;
2421 SAVEI8(PL_lex_dojoin);
2422 SAVEI32(PL_lex_brackets);
2423 SAVEI32(PL_lex_allbrackets);
2424 SAVEI32(PL_lex_formbrack);
2425 SAVEI8(PL_lex_fakeeof);
2426 SAVEI32(PL_lex_casemods);
2427 SAVEI32(PL_lex_starts);
2428 SAVEI8(PL_lex_state);
2429 SAVESPTR(PL_lex_repl);
2430 SAVEVPTR(PL_lex_inpat);
2431 SAVEI16(PL_lex_inwhat);
2434 SAVECOPLINE(PL_curcop);
2435 SAVEI32(PL_multi_end);
2436 SAVEI32(PL_parser->herelines);
2437 PL_parser->herelines = 0;
2439 SAVEIV(PL_multi_close);
2440 SAVEPPTR(PL_bufptr);
2441 SAVEPPTR(PL_bufend);
2442 SAVEPPTR(PL_oldbufptr);
2443 SAVEPPTR(PL_oldoldbufptr);
2444 SAVEPPTR(PL_last_lop);
2445 SAVEPPTR(PL_last_uni);
2446 SAVEPPTR(PL_linestart);
2447 SAVESPTR(PL_linestr);
2448 SAVEGENERICPV(PL_lex_brackstack);
2449 SAVEGENERICPV(PL_lex_casestack);
2450 SAVEGENERICPV(PL_parser->lex_shared);
2451 SAVEBOOL(PL_parser->lex_re_reparsing);
2452 SAVEI32(PL_copline);
2454 /* The here-doc parser needs to be able to peek into outer lexing
2455 scopes to find the body of the here-doc. So we put PL_linestr and
2456 PL_bufptr into lex_shared, to ‘share’ those values.
2458 PL_parser->lex_shared->ls_linestr = PL_linestr;
2459 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2461 PL_linestr = PL_lex_stuff;
2462 PL_lex_repl = PL_parser->lex_sub_repl;
2463 PL_lex_stuff = NULL;
2464 PL_parser->lex_sub_repl = NULL;
2466 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2467 set for an inner quote-like operator and then an error causes scope-
2468 popping. We must not have a PL_lex_stuff value left dangling, as
2469 that breaks assumptions elsewhere. See bug #123617. */
2470 SAVEGENERICSV(PL_lex_stuff);
2471 SAVEGENERICSV(PL_parser->lex_sub_repl);
2473 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2474 = SvPVX(PL_linestr);
2475 PL_bufend += SvCUR(PL_linestr);
2476 PL_last_lop = PL_last_uni = NULL;
2477 SAVEFREESV(PL_linestr);
2478 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2480 PL_lex_dojoin = FALSE;
2481 PL_lex_brackets = PL_lex_formbrack = 0;
2482 PL_lex_allbrackets = 0;
2483 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2484 Newx(PL_lex_brackstack, 120, char);
2485 Newx(PL_lex_casestack, 12, char);
2486 PL_lex_casemods = 0;
2487 *PL_lex_casestack = '\0';
2489 PL_lex_state = LEX_INTERPCONCAT;
2491 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2492 PL_copline = NOLINE;
2494 Newxz(shared, 1, LEXSHARED);
2495 shared->ls_prev = PL_parser->lex_shared;
2496 PL_parser->lex_shared = shared;
2498 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2499 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2500 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2501 PL_lex_inpat = PL_parser->lex_sub_op;
2503 PL_lex_inpat = NULL;
2505 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2506 PL_in_eval &= ~EVAL_RE_REPARSING;
2513 * Restores lexer state after a S_sublex_push.
2519 if (!PL_lex_starts++) {
2520 SV * const sv = newSVpvs("");
2521 if (SvUTF8(PL_linestr))
2523 PL_expect = XOPERATOR;
2524 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2528 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2529 PL_lex_state = LEX_INTERPCASEMOD;
2533 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2534 assert(PL_lex_inwhat != OP_TRANSR);
2536 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2537 PL_linestr = PL_lex_repl;
2539 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2540 PL_bufend += SvCUR(PL_linestr);
2541 PL_last_lop = PL_last_uni = NULL;
2542 PL_lex_dojoin = FALSE;
2543 PL_lex_brackets = 0;
2544 PL_lex_allbrackets = 0;
2545 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2546 PL_lex_casemods = 0;
2547 *PL_lex_casestack = '\0';
2549 if (SvEVALED(PL_lex_repl)) {
2550 PL_lex_state = LEX_INTERPNORMAL;
2552 /* we don't clear PL_lex_repl here, so that we can check later
2553 whether this is an evalled subst; that means we rely on the
2554 logic to ensure sublex_done() is called again only via the
2555 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2558 PL_lex_state = LEX_INTERPCONCAT;
2561 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2562 CopLINE(PL_curcop) +=
2563 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2564 + PL_parser->herelines;
2565 PL_parser->herelines = 0;
2570 const line_t l = CopLINE(PL_curcop);
2572 if (PL_multi_close == '<')
2573 PL_parser->herelines += l - PL_multi_end;
2574 PL_bufend = SvPVX(PL_linestr);
2575 PL_bufend += SvCUR(PL_linestr);
2576 PL_expect = XOPERATOR;
2582 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2584 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2585 * interior, hence to the "}". Finds what the name resolves to, returning
2586 * an SV* containing it; NULL if no valid one found */
2588 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2595 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2597 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2600 SvREFCNT_dec_NN(res);
2601 /* diag_listed_as: Unknown charname '%s' */
2602 yyerror("Unknown charname ''");
2606 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2607 /* include the <}> */
2608 e - backslash_ptr + 1);
2610 SvREFCNT_dec_NN(res);
2614 /* See if the charnames handler is the Perl core's, and if so, we can skip
2615 * the validation needed for a user-supplied one, as Perl's does its own
2617 table = GvHV(PL_hintgv); /* ^H */
2618 cvp = hv_fetchs(table, "charnames", FALSE);
2619 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2620 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2622 const char * const name = HvNAME(stash);
2623 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2628 /* Here, it isn't Perl's charname handler. We can't rely on a
2629 * user-supplied handler to validate the input name. For non-ut8 input,
2630 * look to see that the first character is legal. Then loop through the
2631 * rest checking that each is a continuation */
2633 /* This code makes the reasonable assumption that the only Latin1-range
2634 * characters that begin a character name alias are alphabetic, otherwise
2635 * would have to create a isCHARNAME_BEGIN macro */
2638 if (! isALPHAU(*s)) {
2643 if (! isCHARNAME_CONT(*s)) {
2646 if (*s == ' ' && *(s-1) == ' ') {
2653 /* Similarly for utf8. For invariants can check directly; for other
2654 * Latin1, can calculate their code point and check; otherwise use a
2656 if (UTF8_IS_INVARIANT(*s)) {
2657 if (! isALPHAU(*s)) {
2661 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2662 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2668 if (! PL_utf8_charname_begin) {
2669 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2670 PL_utf8_charname_begin = _core_swash_init("utf8",
2671 "_Perl_Charname_Begin",
2673 1, 0, NULL, &flags);
2675 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2682 if (UTF8_IS_INVARIANT(*s)) {
2683 if (! isCHARNAME_CONT(*s)) {
2686 if (*s == ' ' && *(s-1) == ' ') {
2691 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2692 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2699 if (! PL_utf8_charname_continue) {
2700 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2701 PL_utf8_charname_continue = _core_swash_init("utf8",
2702 "_Perl_Charname_Continue",
2704 1, 0, NULL, &flags);
2706 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2713 if (*(s-1) == ' ') {
2714 /* diag_listed_as: charnames alias definitions may not contain
2715 trailing white-space; marked by <-- HERE in %s
2719 "charnames alias definitions may not contain trailing "
2720 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2721 (int)(s - backslash_ptr + 1), backslash_ptr,
2722 (int)(e - s + 1), s + 1
2724 UTF ? SVf_UTF8 : 0);
2728 if (SvUTF8(res)) { /* Don't accept malformed input */
2729 const U8* first_bad_char_loc;
2731 const char* const str = SvPV_const(res, len);
2732 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2733 &first_bad_char_loc)))
2735 _force_out_malformed_utf8_message(first_bad_char_loc,
2736 (U8 *) PL_parser->bufend,
2738 0 /* 0 means don't die */ );
2739 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2740 immediately after '%s' */
2743 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2744 (int) (e - backslash_ptr + 1), backslash_ptr,
2745 (int) ((char *) first_bad_char_loc - str), str
2756 /* The final %.*s makes sure that should the trailing NUL be missing
2757 * that this print won't run off the end of the string */
2758 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2762 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2763 (int)(s - backslash_ptr + 1), backslash_ptr,
2764 (int)(e - s + 1), s + 1
2766 UTF ? SVf_UTF8 : 0);
2771 /* diag_listed_as: charnames alias definitions may not contain a
2772 sequence of multiple spaces; marked by <-- HERE
2776 "charnames alias definitions may not contain a sequence of "
2777 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2778 (int)(s - backslash_ptr + 1), backslash_ptr,
2779 (int)(e - s + 1), s + 1
2781 UTF ? SVf_UTF8 : 0);
2788 Extracts the next constant part of a pattern, double-quoted string,
2789 or transliteration. This is terrifying code.
2791 For example, in parsing the double-quoted string "ab\x63$d", it would
2792 stop at the '$' and return an OP_CONST containing 'abc'.
2794 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2795 processing a pattern (PL_lex_inpat is true), a transliteration
2796 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2798 Returns a pointer to the character scanned up to. If this is
2799 advanced from the start pointer supplied (i.e. if anything was
2800 successfully parsed), will leave an OP_CONST for the substring scanned
2801 in pl_yylval. Caller must intuit reason for not parsing further
2802 by looking at the next characters herself.
2806 \N{FOO} => \N{U+hex_for_character_FOO}
2807 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2810 all other \-char, including \N and \N{ apart from \N{ABC}
2813 @ and $ where it appears to be a var, but not for $ as tail anchor
2817 In transliterations:
2818 characters are VERY literal, except for - not at the start or end
2819 of the string, which indicates a range. However some backslash sequences
2820 are recognized: \r, \n, and the like
2821 \007 \o{}, \x{}, \N{}
2822 If all elements in the transliteration are below 256,
2823 scan_const expands the range to the full set of intermediate
2824 characters. If the range is in utf8, the hyphen is replaced with
2825 a certain range mark which will be handled by pmtrans() in op.c.
2827 In double-quoted strings:
2829 all those recognized in transliterations
2830 deprecated backrefs: \1 (in substitution replacements)
2831 case and quoting: \U \Q \E
2834 scan_const does *not* construct ops to handle interpolated strings.
2835 It stops processing as soon as it finds an embedded $ or @ variable
2836 and leaves it to the caller to work out what's going on.
2838 embedded arrays (whether in pattern or not) could be:
2839 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2841 $ in double-quoted strings must be the symbol of an embedded scalar.
2843 $ in pattern could be $foo or could be tail anchor. Assumption:
2844 it's a tail anchor if $ is the last thing in the string, or if it's
2845 followed by one of "()| \r\n\t"
2847 \1 (backreferences) are turned into $1 in substitutions
2849 The structure of the code is
2850 while (there's a character to process) {
2851 handle transliteration ranges
2852 skip regexp comments /(?#comment)/ and codes /(?{code})/
2853 skip #-initiated comments in //x patterns
2854 check for embedded arrays
2855 check for embedded scalars
2857 deprecate \1 in substitution replacements
2858 handle string-changing backslashes \l \U \Q \E, etc.
2859 switch (what was escaped) {
2860 handle \- in a transliteration (becomes a literal -)
2861 if a pattern and not \N{, go treat as regular character
2862 handle \132 (octal characters)
2863 handle \x15 and \x{1234} (hex characters)
2864 handle \N{name} (named characters, also \N{3,5} in a pattern)
2865 handle \cV (control characters)
2866 handle printf-style backslashes (\f, \r, \n, etc)
2869 } (end if backslash)
2870 handle regular character
2871 } (end while character to read)
2876 S_scan_const(pTHX_ char *start)
2878 char *send = PL_bufend; /* end of the constant */
2879 SV *sv = newSV(send - start); /* sv for the constant. See note below
2881 char *s = start; /* start of the constant */
2882 char *d = SvPVX(sv); /* destination for copies */
2883 bool dorange = FALSE; /* are we in a translit range? */
2884 bool didrange = FALSE; /* did we just finish a range? */
2885 bool in_charclass = FALSE; /* within /[...]/ */
2886 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2887 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2888 UTF8? But, this can show as true
2889 when the source isn't utf8, as for
2890 example when it is entirely composed
2892 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2893 number of characters found so far
2894 that will expand (into 2 bytes)
2895 should we have to convert to
2897 SV *res; /* result from charnames */
2898 STRLEN offset_to_max = 0; /* The offset in the output to where the range
2899 high-end character is temporarily placed */
2901 /* Does something require special handling in tr/// ? This avoids extra
2902 * work in a less likely case. As such, khw didn't feel it was worth
2903 * adding any branches to the more mainline code to handle this, which
2904 * means that this doesn't get set in some circumstances when things like
2905 * \x{100} get expanded out. As a result there needs to be extra testing
2906 * done in the tr code */
2907 bool has_above_latin1 = FALSE;
2909 /* Note on sizing: The scanned constant is placed into sv, which is
2910 * initialized by newSV() assuming one byte of output for every byte of
2911 * input. This routine expects newSV() to allocate an extra byte for a
2912 * trailing NUL, which this routine will append if it gets to the end of
2913 * the input. There may be more bytes of input than output (eg., \N{LATIN
2914 * CAPITAL LETTER A}), or more output than input if the constant ends up
2915 * recoded to utf8, but each time a construct is found that might increase
2916 * the needed size, SvGROW() is called. Its size parameter each time is
2917 * based on the best guess estimate at the time, namely the length used so
2918 * far, plus the length the current construct will occupy, plus room for
2919 * the trailing NUL, plus one byte for every input byte still unscanned */
2921 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2924 int backslash_N = 0; /* ? was the character from \N{} */
2925 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2926 platform-specific like \x65 */
2929 PERL_ARGS_ASSERT_SCAN_CONST;
2931 assert(PL_lex_inwhat != OP_TRANSR);
2932 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2933 /* If we are doing a trans and we know we want UTF8 set expectation */
2934 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2935 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2938 /* Protect sv from errors and fatal warnings. */
2939 ENTER_with_name("scan_const");
2943 || dorange /* Handle tr/// range at right edge of input */
2946 /* get transliterations out of the way (they're most literal) */
2947 if (PL_lex_inwhat == OP_TRANS) {
2949 /* But there isn't any special handling necessary unless there is a
2950 * range, so for most cases we just drop down and handle the value
2951 * as any other. There are two exceptions.
2953 * 1. A hyphen indicates that we are actually going to have a
2954 * range. In this case, skip the '-', set a flag, then drop
2955 * down to handle what should be the end range value.
2956 * 2. After we've handled that value, the next time through, that
2957 * flag is set and we fix up the range.
2959 * Ranges entirely within Latin1 are expanded out entirely, in
2960 * order to make the transliteration a simple table look-up.
2961 * Ranges that extend above Latin1 have to be done differently, so
2962 * there is no advantage to expanding them here, so they are
2963 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2964 * signifies a hyphen without any possible ambiguity. On EBCDIC
2965 * machines, if the range is expressed as Unicode, the Latin1
2966 * portion is expanded out even if the range extends above
2967 * Latin1. This is because each code point in it has to be
2968 * processed here individually to get its native translation */
2972 /* Here, we don't think we're in a range. If the new character
2973 * is not a hyphen; or if it is a hyphen, but it's too close to
2974 * either edge to indicate a range, or if we haven't output any
2975 * characters yet then it's a regular character. */
2976 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
2978 /* A regular character. Process like any other, but first
2979 * clear any flags */
2983 non_portable_endpoint = 0;
2986 /* The tests here for being above Latin1 and similar ones
2987 * in the following 'else' suffice to find all such
2988 * occurences in the constant, except those added by a
2989 * backslash escape sequence, like \x{100}. Mostly, those
2990 * set 'has_above_latin1' as appropriate */
2991 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
2992 has_above_latin1 = TRUE;
2995 /* Drops down to generic code to process current byte */
2997 else { /* Is a '-' in the context where it means a range */
2998 if (didrange) { /* Something like y/A-C-Z// */
2999 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3005 s++; /* Skip past the hyphen */
3007 /* d now points to where the end-range character will be
3008 * placed. Save it so won't have to go finding it later,
3009 * and drop down to get that character. (Actually we
3010 * instead save the offset, to handle the case where a
3011 * realloc in the meantime could change the actual
3012 * pointer). We'll finish processing the range the next
3013 * time through the loop */
3014 offset_to_max = d - SvPVX_const(sv);
3016 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3017 has_above_latin1 = TRUE;
3020 /* Drops down to generic code to process current byte */
3022 } /* End of not a range */
3024 /* Here we have parsed a range. Now must handle it. At this
3026 * 'sv' is a SV* that contains the output string we are
3027 * constructing. The final two characters in that string
3028 * are the range start and range end, in order.
3029 * 'd' points to just beyond the range end in the 'sv' string,
3030 * where we would next place something
3031 * 'offset_to_max' is the offset in 'sv' at which the character
3032 * (the range's maximum end point) before 'd' begins.
3034 char * max_ptr = SvPVX(sv) + offset_to_max;
3037 IV range_max; /* last character in range */
3039 Size_t offset_to_min = 0;
3042 bool convert_unicode;
3043 IV real_range_max = 0;
3045 /* Get the code point values of the range ends. */
3047 /* We know the utf8 is valid, because we just constructed
3048 * it ourselves in previous loop iterations */
3049 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3050 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3051 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3053 /* This compensates for not all code setting
3054 * 'has_above_latin1', so that we don't skip stuff that
3055 * should be executed */
3056 if (range_max > 255) {
3057 has_above_latin1 = TRUE;
3061 min_ptr = max_ptr - 1;
3062 range_min = * (U8*) min_ptr;
3063 range_max = * (U8*) max_ptr;
3066 /* If the range is just a single code point, like tr/a-a/.../,
3067 * that code point is already in the output, twice. We can
3068 * just back up over the second instance and avoid all the rest
3069 * of the work. But if it is a variant character, it's been
3070 * counted twice, so decrement. (This unlikely scenario is
3071 * special cased, like the one for a range of 2 code points
3072 * below, only because the main-line code below needs a range
3073 * of 3 or more to work without special casing. Might as well
3074 * get it out of the way now.) */
3075 if (UNLIKELY(range_max == range_min)) {
3077 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3078 utf8_variant_count--;
3084 /* On EBCDIC platforms, we may have to deal with portable
3085 * ranges. These happen if at least one range endpoint is a
3086 * Unicode value (\N{...}), or if the range is a subset of
3087 * [A-Z] or [a-z], and both ends are literal characters,
3088 * like 'A', and not like \x{C1} */
3090 cBOOL(backslash_N) /* \N{} forces Unicode,
3091 hence portable range */
3092 || ( ! non_portable_endpoint
3093 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3094 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3095 if (convert_unicode) {
3097 /* Special handling is needed for these portable ranges.
3098 * They are defined to be in Unicode terms, which includes
3099 * all the Unicode code points between the end points.
3100 * Convert to Unicode to get the Unicode range. Later we
3101 * will convert each code point in the range back to
3103 range_min = NATIVE_TO_UNI(range_min);
3104 range_max = NATIVE_TO_UNI(range_max);
3108 if (range_min > range_max) {
3110 if (convert_unicode) {
3111 /* Need to convert back to native for meaningful
3112 * messages for this platform */
3113 range_min = UNI_TO_NATIVE(range_min);
3114 range_max = UNI_TO_NATIVE(range_max);
3117 /* Use the characters themselves for the error message if
3118 * ASCII printables; otherwise some visible representation
3120 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3122 "Invalid range \"%c-%c\" in transliteration operator",
3123 (char)range_min, (char)range_max);
3126 else if (convert_unicode) {
3127 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3129 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3130 UVXf "}\" in transliteration operator",
3131 range_min, range_max);
3135 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3137 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3138 " in transliteration operator",
3139 range_min, range_max);
3143 /* If the range is exactly two code points long, they are
3144 * already both in the output */
3145 if (UNLIKELY(range_min + 1 == range_max)) {
3149 /* Here the range contains at least 3 code points */
3153 /* If everything in the transliteration is below 256, we
3154 * can avoid special handling later. A translation table
3155 * for each of those bytes is created by op.c. So we
3156 * expand out all ranges to their constituent code points.
3157 * But if we've encountered something above 255, the
3158 * expanding won't help, so skip doing that. But if it's
3159 * EBCDIC, we may have to look at each character below 256
3160 * if we have to convert to/from Unicode values */
3161 if ( has_above_latin1
3163 && (range_min > 255 || ! convert_unicode)
3166 /* Move the high character one byte to the right; then
3167 * insert between it and the range begin, an illegal
3168 * byte which serves to indicate this is a range (using
3169 * a '-' would be ambiguous). */
3171 while (e-- > max_ptr) {
3174 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3178 /* Here, we're going to expand out the range. For EBCDIC
3179 * the range can extend above 255 (not so in ASCII), so
3180 * for EBCDIC, split it into the parts above and below
3183 if (range_max > 255) {
3184 real_range_max = range_max;
3190 /* Here we need to expand out the string to contain each
3191 * character in the range. Grow the output to handle this.
3192 * For non-UTF8, we need a byte for each code point in the
3193 * range, minus the three that we've already allocated for: the
3194 * hyphen, the min, and the max. For UTF-8, we need this
3195 * plus an extra byte for each code point that occupies two
3196 * bytes (is variant) when in UTF-8 (except we've already
3197 * allocated for the end points, including if they are
3198 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3199 * platforms, it's easy to calculate a precise number. To
3200 * start, we count the variants in the range, which we need
3201 * elsewhere in this function anyway. (For the case where it
3202 * isn't easy to calculate, 'extras' has been initialized to 0,
3203 * and the calculation is done in a loop further down.) */
3205 if (convert_unicode)
3208 /* This is executed unconditionally on ASCII, and for
3209 * Unicode ranges on EBCDIC. Under these conditions, all
3210 * code points above a certain value are variant; and none
3211 * under that value are. We just need to find out how much
3212 * of the range is above that value. We don't count the
3213 * end points here, as they will already have been counted
3214 * as they were parsed. */
3215 if (range_min >= UTF_CONTINUATION_MARK) {
3217 /* The whole range is made up of variants */
3218 extras = (range_max - 1) - (range_min + 1) + 1;
3220 else if (range_max >= UTF_CONTINUATION_MARK) {
3222 /* Only the higher portion of the range is variants */
3223 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3226 utf8_variant_count += extras;
3229 /* The base growth is the number of code points in the range,
3230 * not including the endpoints, which have already been sized
3231 * for (and output). We don't subtract for the hyphen, as it
3232 * has been parsed but not output, and the SvGROW below is
3233 * based only on what's been output plus what's left to parse.
3235 grow = (range_max - 1) - (range_min + 1) + 1;
3239 /* In some cases in EBCDIC, we haven't yet calculated a
3240 * precise amount needed for the UTF-8 variants. Just
3241 * assume the worst case, that everything will expand by a
3243 if (! convert_unicode) {
3249 /* Otherwise we know exactly how many variants there
3250 * are in the range. */
3255 /* Grow, but position the output to overwrite the range min end
3256 * point, because in some cases we overwrite that */
3257 SvCUR_set(sv, d - SvPVX_const(sv));
3258 offset_to_min = min_ptr - SvPVX_const(sv);
3260 /* See Note on sizing above. */
3261 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3264 + 1 /* Trailing NUL */ );
3266 /* Now, we can expand out the range. */
3268 if (convert_unicode) {
3271 /* Recall that the min and max are now in Unicode terms, so
3272 * we have to convert each character to its native
3275 for (i = range_min; i <= range_max; i++) {
3276 append_utf8_from_native_byte(
3277 LATIN1_TO_NATIVE((U8) i),
3282 for (i = range_min; i <= range_max; i++) {
3283 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3289 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3291 /* Here, no conversions are necessary, which means that the
3292 * first character in the range is already in 'd' and
3293 * valid, so we can skip overwriting it */
3297 for (i = range_min + 1; i <= range_max; i++) {
3298 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3304 assert(range_min + 1 <= range_max);
3305 for (i = range_min + 1; i < range_max; i++) {
3307 /* In this case on EBCDIC, we haven't calculated
3308 * the variants. Do it here, as we go along */
3309 if (! UVCHR_IS_INVARIANT(i)) {
3310 utf8_variant_count++;
3316 /* The range_max is done outside the loop so as to
3317 * avoid having to special case not incrementing
3318 * 'utf8_variant_count' on EBCDIC (it's already been
3319 * counted when originally parsed) */
3320 *d++ = (char) range_max;
3325 /* If the original range extended above 255, add in that
3327 if (real_range_max) {
3328 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3329 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3330 if (real_range_max > 0x100) {
3331 if (real_range_max > 0x101) {
3332 *d++ = (char) ILLEGAL_UTF8_BYTE;
3334 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3340 /* mark the range as done, and continue */
3344 non_portable_endpoint = 0;
3348 } /* End of is a range */
3349 } /* End of transliteration. Joins main code after these else's */
3350 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3353 while (s1 >= start && *s1-- == '\\')
3356 in_charclass = TRUE;
3358 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3361 while (s1 >= start && *s1-- == '\\')
3364 in_charclass = FALSE;
3366 /* skip for regexp comments /(?#comment)/, except for the last
3367 * char, which will be done separately. Stop on (?{..}) and
3369 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3371 while (s+1 < send && *s != ')')
3374 else if (!PL_lex_casemods
3375 && ( s[2] == '{' /* This should match regcomp.c */
3376 || (s[2] == '?' && s[3] == '{')))
3381 /* likewise skip #-initiated comments in //x patterns */
3385 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3387 while (s < send && *s != '\n')
3390 /* no further processing of single-quoted regex */
3391 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3392 goto default_action;
3394 /* check for embedded arrays
3395 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3397 else if (*s == '@' && s[1]) {
3399 ? isIDFIRST_utf8_safe(s+1, send)
3400 : isWORDCHAR_A(s[1]))
3404 if (strchr(":'{$", s[1]))
3406 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3407 break; /* in regexp, neither @+ nor @- are interpolated */
3409 /* check for embedded scalars. only stop if we're sure it's a
3411 else if (*s == '$') {
3412 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3414 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3416 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3417 "Possible unintended interpolation of $\\ in regex");
3419 break; /* in regexp, $ might be tail anchor */
3423 /* End of else if chain - OP_TRANS rejoin rest */
3425 if (UNLIKELY(s >= send)) {
3431 if (*s == '\\' && s+1 < send) {
3432 char* e; /* Can be used for ending '}', etc. */
3436 /* warn on \1 - \9 in substitution replacements, but note that \11
3437 * is an octal; and \19 is \1 followed by '9' */
3438 if (PL_lex_inwhat == OP_SUBST
3444 /* diag_listed_as: \%d better written as $%d */
3445 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3450 /* string-change backslash escapes */
3451 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3455 /* In a pattern, process \N, but skip any other backslash escapes.
3456 * This is because we don't want to translate an escape sequence
3457 * into a meta symbol and have the regex compiler use the meta
3458 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3459 * in spite of this, we do have to process \N here while the proper
3460 * charnames handler is in scope. See bugs #56444 and #62056.
3462 * There is a complication because \N in a pattern may also stand
3463 * for 'match a non-nl', and not mean a charname, in which case its
3464 * processing should be deferred to the regex compiler. To be a
3465 * charname it must be followed immediately by a '{', and not look
3466 * like \N followed by a curly quantifier, i.e., not something like
3467 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3469 else if (PL_lex_inpat
3472 || regcurly(s + 1)))
3475 goto default_action;
3481 if ((isALPHANUMERIC(*s)))
3482 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3483 "Unrecognized escape \\%c passed through",
3485 /* default action is to copy the quoted character */
3486 goto default_action;
3489 /* eg. \132 indicates the octal constant 0132 */
3490 case '0': case '1': case '2': case '3':
3491 case '4': case '5': case '6': case '7':
3493 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3495 uv = grok_oct(s, &len, &flags, NULL);
3497 if (len < 3 && s < send && isDIGIT(*s)
3498 && ckWARN(WARN_MISC))
3500 Perl_warner(aTHX_ packWARN(WARN_MISC),
3501 "%s", form_short_octal_warning(s, len));
3504 goto NUM_ESCAPE_INSERT;
3506 /* eg. \o{24} indicates the octal constant \024 */
3511 bool valid = grok_bslash_o(&s, PL_bufend,
3513 TRUE, /* Output warning */
3514 FALSE, /* Not strict */
3515 TRUE, /* Output warnings for
3520 uv = 0; /* drop through to ensure range ends are set */
3522 goto NUM_ESCAPE_INSERT;
3525 /* eg. \x24 indicates the hex constant 0x24 */
3530 bool valid = grok_bslash_x(&s, PL_bufend,
3532 TRUE, /* Output warning */
3533 FALSE, /* Not strict */
3534 TRUE, /* Output warnings for
3539 uv = 0; /* drop through to ensure range ends are set */
3544 /* Insert oct or hex escaped character. */
3546 /* Here uv is the ordinal of the next character being added */
3547 if (UVCHR_IS_INVARIANT(uv)) {
3551 if (!has_utf8 && uv > 255) {
3553 /* Here, 'uv' won't fit unless we convert to UTF-8.
3554 * If we've only seen invariants so far, all we have to
3555 * do is turn on the flag */
3556 if (utf8_variant_count == 0) {
3560 SvCUR_set(sv, d - SvPVX_const(sv));
3564 sv_utf8_upgrade_flags_grow(
3566 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3568 /* Since we're having to grow here,
3569 * make sure we have enough room for
3570 * this escape and a NUL, so the
3571 * code immediately below won't have
3572 * to actually grow again */
3574 + (STRLEN)(send - s) + 1);
3575 d = SvPVX(sv) + SvCUR(sv);
3578 has_above_latin1 = TRUE;
3584 utf8_variant_count++;
3587 /* Usually, there will already be enough room in 'sv'
3588 * since such escapes are likely longer than any UTF-8
3589 * sequence they can end up as. This isn't the case on
3590 * EBCDIC where \x{40000000} contains 12 bytes, and the
3591 * UTF-8 for it contains 14. And, we have to allow for
3592 * a trailing NUL. It probably can't happen on ASCII
3593 * platforms, but be safe. See Note on sizing above. */
3594 const STRLEN needed = d - SvPVX(sv)
3598 if (UNLIKELY(needed > SvLEN(sv))) {
3599 SvCUR_set(sv, d - SvPVX_const(sv));
3600 d = SvCUR(sv) + SvGROW(sv, needed);
3603 d = (char*)uvchr_to_utf8((U8*)d, uv);
3604 if (PL_lex_inwhat == OP_TRANS
3605 && PL_parser->lex_sub_op)
3607 PL_parser->lex_sub_op->op_private |=
3608 (PL_lex_repl ? OPpTRANS_FROM_UTF
3614 non_portable_endpoint++;
3619 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3620 * named character, like \N{LATIN SMALL LETTER A}, or a named
3621 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3622 * GRAVE} (except y/// can't handle the latter, croaking). For
3623 * convenience all three forms are referred to as "named
3624 * characters" below.
3626 * For patterns, \N also can mean to match a non-newline. Code
3627 * before this 'switch' statement should already have handled
3628 * this situation, and hence this code only has to deal with
3629 * the named character cases.
3631 * For non-patterns, the named characters are converted to
3632 * their string equivalents. In patterns, named characters are
3633 * not converted to their ultimate forms for the same reasons
3634 * that other escapes aren't (mainly that the ultimate
3635 * character could be considered a meta-symbol by the regex
3636 * compiler). Instead, they are converted to the \N{U+...}
3637 * form to get the value from the charnames that is in effect
3638 * right now, while preserving the fact that it was a named
3639 * character, so that the regex compiler knows this.
3641 * The structure of this section of code (besides checking for
3642 * errors and upgrading to utf8) is:
3643 * If the named character is of the form \N{U+...}, pass it
3644 * through if a pattern; otherwise convert the code point
3646 * Otherwise must be some \N{NAME}: convert to
3647 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3649 * Transliteration is an exception. The conversion to utf8 is
3650 * only done if the code point requires it to be representable.
3652 * Here, 's' points to the 'N'; the test below is guaranteed to
3653 * succeed if we are being called on a pattern, as we already
3654 * know from a test above that the next character is a '{'. A
3655 * non-pattern \N must mean 'named character', which requires
3659 yyerror("Missing braces on \\N{}");
3665 /* If there is no matching '}', it is an error. */
3666 if (! (e = (char *) memchr(s, '}', send - s))) {
3667 if (! PL_lex_inpat) {
3668 yyerror("Missing right brace on \\N{}");
3670 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3672 yyquit(); /* Have exhausted the input. */
3675 /* Here it looks like a named character */
3677 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3678 s += 2; /* Skip to next char after the 'U+' */
3681 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3682 /* Check the syntax. */
3685 if (!isXDIGIT(*s)) {
3688 "Invalid hexadecimal number in \\N{U+...}"
3697 else if ((*s == '.' || *s == '_')
3703 /* Pass everything through unchanged.
3704 * +1 is for the '}' */
3705 Copy(orig_s, d, e - orig_s + 1, char);
3706 d += e - orig_s + 1;
3708 else { /* Not a pattern: convert the hex to string */
3709 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3710 | PERL_SCAN_SILENT_ILLDIGIT
3711 | PERL_SCAN_DISALLOW_PREFIX;
3713 uv = grok_hex(s, &len, &flags, NULL);
3714 if (len == 0 || (len != (STRLEN)(e - s)))
3717 /* For non-tr///, if the destination is not in utf8,
3718 * unconditionally recode it to be so. This is
3719 * because \N{} implies Unicode semantics, and scalars
3720 * have to be in utf8 to guarantee those semantics.
3721 * tr/// doesn't care about Unicode rules, so no need
3722 * there to upgrade to UTF-8 for small enough code
3724 if (! has_utf8 && ( uv > 0xFF
3725 || PL_lex_inwhat != OP_TRANS))
3727 /* See Note on sizing above. */
3728 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3730 SvCUR_set(sv, d - SvPVX_const(sv));
3734 if (utf8_variant_count == 0) {
3736 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3739 sv_utf8_upgrade_flags_grow(
3741 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3743 d = SvPVX(sv) + SvCUR(sv);
3747 has_above_latin1 = TRUE;
3750 /* Add the (Unicode) code point to the output. */
3751 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3752 *d++ = (char) LATIN1_TO_NATIVE(uv);
3755 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3759 else /* Here is \N{NAME} but not \N{U+...}. */
3760 if ((res = get_and_check_backslash_N_name(s, e)))
3763 const char *str = SvPV_const(res, len);
3766 if (! len) { /* The name resolved to an empty string */
3767 Copy("\\N{}", d, 4, char);
3771 /* In order to not lose information for the regex
3772 * compiler, pass the result in the specially made
3773 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3774 * the code points in hex of each character
3775 * returned by charnames */
3777 const char *str_end = str + len;
3778 const STRLEN off = d - SvPVX_const(sv);
3780 if (! SvUTF8(res)) {
3781 /* For the non-UTF-8 case, we can determine the
3782 * exact length needed without having to parse
3783 * through the string. Each character takes up
3784 * 2 hex digits plus either a trailing dot or
3786 const char initial_text[] = "\\N{U+";
3787 const STRLEN initial_len = sizeof(initial_text)
3789 d = off + SvGROW(sv, off
3792 /* +1 for trailing NUL */
3795 + (STRLEN)(send - e));
3796 Copy(initial_text, d, initial_len, char);
3798 while (str < str_end) {
3801 my_snprintf(hex_string,
3805 /* The regex compiler is
3806 * expecting Unicode, not
3808 NATIVE_TO_LATIN1(*str));
3809 PERL_MY_SNPRINTF_POST_GUARD(len,
3810 sizeof(hex_string));
3811 Copy(hex_string, d, 3, char);
3815 d--; /* Below, we will overwrite the final
3816 dot with a right brace */
3819 STRLEN char_length; /* cur char's byte length */
3821 /* and the number of bytes after this is
3822 * translated into hex digits */
3823 STRLEN output_length;
3825 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3826 * for max('U+', '.'); and 1 for NUL */
3827 char hex_string[2 * UTF8_MAXBYTES + 5];
3829 /* Get the first character of the result. */
3830 U32 uv = utf8n_to_uvchr((U8 *) str,
3834 /* Convert first code point to Unicode hex,
3835 * including the boiler plate before it. */
3837 my_snprintf(hex_string, sizeof(hex_string),
3839 (unsigned int) NATIVE_TO_UNI(uv));
3841 /* Make sure there is enough space to hold it */
3842 d = off + SvGROW(sv, off
3844 + (STRLEN)(send - e)
3845 + 2); /* '}' + NUL */
3847 Copy(hex_string, d, output_length, char);
3850 /* For each subsequent character, append dot and
3851 * its Unicode code point in hex */
3852 while ((str += char_length) < str_end) {
3853 const STRLEN off = d - SvPVX_const(sv);
3854 U32 uv = utf8n_to_uvchr((U8 *) str,
3859 my_snprintf(hex_string,
3862 (unsigned int) NATIVE_TO_UNI(uv));
3864 d = off + SvGROW(sv, off
3866 + (STRLEN)(send - e)
3867 + 2); /* '}' + NUL */
3868 Copy(hex_string, d, output_length, char);
3873 *d++ = '}'; /* Done. Add the trailing brace */
3876 else { /* Here, not in a pattern. Convert the name to a
3879 if (PL_lex_inwhat == OP_TRANS) {
3880 str = SvPV_const(res, len);
3881 if (len > ((SvUTF8(res))
3885 yyerror(Perl_form(aTHX_
3886 "%.*s must not be a named sequence"
3887 " in transliteration operator",
3888 /* +1 to include the "}" */
3889 (int) (e + 1 - start), start));
3891 goto end_backslash_N;
3894 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3895 has_above_latin1 = TRUE;
3899 else if (! SvUTF8(res)) {
3900 /* Make sure \N{} return is UTF-8. This is because
3901 * \N{} implies Unicode semantics, and scalars have
3902 * to be in utf8 to guarantee those semantics; but
3903 * not needed in tr/// */
3904 sv_utf8_upgrade_flags(res, 0);
3905 str = SvPV_const(res, len);
3908 /* Upgrade destination to be utf8 if this new
3910 if (! has_utf8 && SvUTF8(res)) {
3911 /* See Note on sizing above. */
3912 const STRLEN extra = len + (send - s) + 1;
3914 SvCUR_set(sv, d - SvPVX_const(sv));
3918 if (utf8_variant_count == 0) {
3920 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3923 sv_utf8_upgrade_flags_grow(sv,
3924 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3926 d = SvPVX(sv) + SvCUR(sv);
3929 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3931 /* See Note on sizing above. (NOTE: SvCUR() is not
3932 * set correctly here). */
3933 const STRLEN extra = len + (send - e) + 1;
3934 const STRLEN off = d - SvPVX_const(sv);
3935 d = off + SvGROW(sv, off + extra);
3937 Copy(str, d, len, char);
3943 } /* End \N{NAME} */
3947 backslash_N++; /* \N{} is defined to be Unicode */
3949 s = e + 1; /* Point to just after the '}' */
3952 /* \c is a control character */
3956 *d++ = grok_bslash_c(*s, 1);
3959 yyerror("Missing control char name in \\c");
3960 yyquit(); /* Are at end of input, no sense continuing */
3963 non_portable_endpoint++;
3967 /* printf-style backslashes, formfeeds, newlines, etc */
3993 } /* end if (backslash) */
3996 /* Just copy the input to the output, though we may have to convert
3999 * If the input has the same representation in UTF-8 as not, it will be
4000 * a single byte, and we don't care about UTF8ness; just copy the byte */
4001 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4004 else if (! this_utf8 && ! has_utf8) {
4005 /* If neither source nor output is UTF-8, is also a single byte,
4006 * just copy it; but this byte counts should we later have to
4007 * convert to UTF-8 */
4009 utf8_variant_count++;
4011 else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
4012 const STRLEN len = UTF8SKIP(s);
4014 /* We expect the source to have already been checked for
4016 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4018 Copy(s, d, len, U8);
4022 else { /* UTF8ness matters and doesn't match, need to convert */
4024 const UV nextuv = (this_utf8)
4025 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
4027 STRLEN need = UVCHR_SKIP(nextuv);
4030 SvCUR_set(sv, d - SvPVX_const(sv));
4034 /* See Note on sizing above. */
4035 need += (STRLEN)(send - s) + 1;
4037 if (utf8_variant_count == 0) {
4039 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4042 sv_utf8_upgrade_flags_grow(sv,
4043 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4045 d = SvPVX(sv) + SvCUR(sv);
4048 } else if (need > len) {
4049 /* encoded value larger than old, may need extra space (NOTE:
4050 * SvCUR() is not set correctly here). See Note on sizing
4052 const STRLEN extra = need + (send - s) + 1;
4053 const STRLEN off = d - SvPVX_const(sv);
4054 d = off + SvGROW(sv, off + extra);
4058 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
4060 } /* while loop to process each character */
4062 /* terminate the string and set up the sv */
4064 SvCUR_set(sv, d - SvPVX_const(sv));
4065 if (SvCUR(sv) >= SvLEN(sv))
4066 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
4067 " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
4072 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4073 PL_parser->lex_sub_op->op_private |=
4074 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4078 /* shrink the sv if we allocated more than we used */
4079 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4080 SvPV_shrink_to_cur(sv);
4083 /* return the substring (via pl_yylval) only if we parsed anything */
4086 for (; s2 < s; s2++) {
4088 COPLINE_INC_WITH_HERELINES;
4090 SvREFCNT_inc_simple_void_NN(sv);
4091 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4092 && ! PL_parser->lex_re_reparsing)
4094 const char *const key = PL_lex_inpat ? "qr" : "q";
4095 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4099 if (PL_lex_inwhat == OP_TRANS) {
4102 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4105 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4113 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4116 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4118 LEAVE_with_name("scan_const");
4123 * Returns TRUE if there's more to the expression (e.g., a subscript),
4126 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4128 * ->[ and ->{ return TRUE
4129 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4130 * { and [ outside a pattern are always subscripts, so return TRUE
4131 * if we're outside a pattern and it's not { or [, then return FALSE
4132 * if we're in a pattern and the first char is a {
4133 * {4,5} (any digits around the comma) returns FALSE
4134 * if we're in a pattern and the first char is a [
4136 * [SOMETHING] has a funky algorithm to decide whether it's a
4137 * character class or not. It has to deal with things like
4138 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4139 * anything else returns TRUE
4142 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4145 S_intuit_more(pTHX_ char *s, char *e)
4147 PERL_ARGS_ASSERT_INTUIT_MORE;
4149 if (PL_lex_brackets)
4151 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4153 if (*s == '-' && s[1] == '>'
4154 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4155 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4156 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4158 if (*s != '{' && *s != '[')
4163 /* In a pattern, so maybe we have {n,m}. */
4171 /* On the other hand, maybe we have a character class */
4174 if (*s == ']' || *s == '^')
4177 /* this is terrifying, and it works */
4180 const char * const send = (char *) memchr(s, ']', e - s);
4181 unsigned char un_char, last_un_char;
4182 char tmpbuf[sizeof PL_tokenbuf * 4];
4184 if (!send) /* has to be an expression */
4186 weight = 2; /* let's weigh the evidence */
4190 else if (isDIGIT(*s)) {
4192 if (isDIGIT(s[1]) && s[2] == ']')
4198 Zero(seen,256,char);
4200 for (; s < send; s++) {
4201 last_un_char = un_char;
4202 un_char = (unsigned char)*s;
4207 weight -= seen[un_char] * 10;
4208 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4210 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4211 len = (int)strlen(tmpbuf);
4212 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4213 UTF ? SVf_UTF8 : 0, SVt_PV))
4220 && strchr("[#!%*<>()-=",s[1]))
4222 if (/*{*/ strchr("])} =",s[2]))
4231 if (strchr("wds]",s[1]))
4233 else if (seen[(U8)'\''] || seen[(U8)'"'])
4235 else if (strchr("rnftbxcav",s[1]))
4237 else if (isDIGIT(s[1])) {
4239 while (s[1] && isDIGIT(s[1]))
4249 if (strchr("aA01! ",last_un_char))
4251 if (strchr("zZ79~",s[1]))
4253 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4254 weight -= 5; /* cope with negative subscript */
4257 if (!isWORDCHAR(last_un_char)
4258 && !(last_un_char == '$' || last_un_char == '@'
4259 || last_un_char == '&')
4260 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4264 if (keyword(d, s - d, 0))
4267 if (un_char == last_un_char + 1)
4269 weight -= seen[un_char];
4274 if (weight >= 0) /* probably a character class */
4284 * Does all the checking to disambiguate
4286 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4287 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4289 * First argument is the stuff after the first token, e.g. "bar".
4291 * Not a method if foo is a filehandle.
4292 * Not a method if foo is a subroutine prototyped to take a filehandle.
4293 * Not a method if it's really "Foo $bar"
4294 * Method if it's "foo $bar"
4295 * Not a method if it's really "print foo $bar"
4296 * Method if it's really "foo package::" (interpreted as package->foo)
4297 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4298 * Not a method if bar is a filehandle or package, but is quoted with
4303 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4305 char *s = start + (*start == '$');
4306 char tmpbuf[sizeof PL_tokenbuf];
4309 /* Mustn't actually add anything to a symbol table.
4310 But also don't want to "initialise" any placeholder
4311 constants that might already be there into full
4312 blown PVGVs with attached PVCV. */
4314 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4316 PERL_ARGS_ASSERT_INTUIT_METHOD;
4318 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4320 if (cv && SvPOK(cv)) {
4321 const char *proto = CvPROTO(cv);
4323 while (*proto && (isSPACE(*proto) || *proto == ';'))
4330 if (*start == '$') {
4331 SSize_t start_off = start - SvPVX(PL_linestr);
4332 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4333 || isUPPER(*PL_tokenbuf))
4335 /* this could be $# */
4338 PL_bufptr = SvPVX(PL_linestr) + start_off;
4340 return *s == '(' ? FUNCMETH : METHOD;
4343 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4344 /* start is the beginning of the possible filehandle/object,
4345 * and s is the end of it
4346 * tmpbuf is a copy of it (but with single quotes as double colons)
4349 if (!keyword(tmpbuf, len, 0)) {
4350 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4355 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4356 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4358 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4359 && (!isGV(indirgv) || GvCVu(indirgv)))
4361 /* filehandle or package name makes it a method */
4362 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4364 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4365 return 0; /* no assumptions -- "=>" quotes bareword */
4367 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4368 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4369 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4371 force_next(BAREWORD);
4373 return *s == '(' ? FUNCMETH : METHOD;
4379 /* Encoded script support. filter_add() effectively inserts a
4380 * 'pre-processing' function into the current source input stream.
4381 * Note that the filter function only applies to the current source file
4382 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4384 * The datasv parameter (which may be NULL) can be used to pass
4385 * private data to this instance of the filter. The filter function
4386 * can recover the SV using the FILTER_DATA macro and use it to
4387 * store private buffers and state information.
4389 * The supplied datasv parameter is upgraded to a PVIO type
4390 * and the IoDIRP/IoANY field is used to store the function pointer,
4391 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4392 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4393 * private use must be set using malloc'd pointers.
4397 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4405 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4406 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4408 if (!PL_rsfp_filters)
4409 PL_rsfp_filters = newAV();
4412 SvUPGRADE(datasv, SVt_PVIO);
4413 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4414 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4415 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4416 FPTR2DPTR(void *, IoANY(datasv)),
4417 SvPV_nolen(datasv)));
4418 av_unshift(PL_rsfp_filters, 1);
4419 av_store(PL_rsfp_filters, 0, datasv) ;
4421 !PL_parser->filtered
4422 && PL_parser->lex_flags & LEX_EVALBYTES
4423 && PL_bufptr < PL_bufend
4425 const char *s = PL_bufptr;
4426 while (s < PL_bufend) {
4428 SV *linestr = PL_parser->linestr;
4429 char *buf = SvPVX(linestr);
4430 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4431 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4432 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4433 STRLEN const linestart_pos = PL_parser->linestart - buf;
4434 STRLEN const last_uni_pos =
4435 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4436 STRLEN const last_lop_pos =
4437 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4438 av_push(PL_rsfp_filters, linestr);
4439 PL_parser->linestr =
4440 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4441 buf = SvPVX(PL_parser->linestr);
4442 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4443 PL_parser->bufptr = buf + bufptr_pos;
4444 PL_parser->oldbufptr = buf + oldbufptr_pos;
4445 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4446 PL_parser->linestart = buf + linestart_pos;
4447 if (PL_parser->last_uni)
4448 PL_parser->last_uni = buf + last_uni_pos;
4449 if (PL_parser->last_lop)
4450 PL_parser->last_lop = buf + last_lop_pos;
4451 SvLEN_set(linestr, SvCUR(linestr));
4452 SvCUR_set(linestr, s - SvPVX(linestr));
4453 PL_parser->filtered = 1;
4463 /* Delete most recently added instance of this filter function. */
4465 Perl_filter_del(pTHX_ filter_t funcp)
4469 PERL_ARGS_ASSERT_FILTER_DEL;
4472 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4473 FPTR2DPTR(void*, funcp)));
4475 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4477 /* if filter is on top of stack (usual case) just pop it off */
4478 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4479 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4480 sv_free(av_pop(PL_rsfp_filters));
4484 /* we need to search for the correct entry and clear it */
4485 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4489 /* Invoke the idxth filter function for the current rsfp. */
4490 /* maxlen 0 = read one text line */
4492 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4497 /* This API is bad. It should have been using unsigned int for maxlen.
4498 Not sure if we want to change the API, but if not we should sanity
4499 check the value here. */
4500 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4502 PERL_ARGS_ASSERT_FILTER_READ;
4504 if (!PL_parser || !PL_rsfp_filters)
4506 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4507 /* Provide a default input filter to make life easy. */
4508 /* Note that we append to the line. This is handy. */
4509 DEBUG_P(PerlIO_printf(Perl_debug_log,
4510 "filter_read %d: from rsfp\n", idx));
4511 if (correct_length) {
4514 const int old_len = SvCUR(buf_sv);
4516 /* ensure buf_sv is large enough */
4517 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4518 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4519 correct_length)) <= 0) {
4520 if (PerlIO_error(PL_rsfp))
4521 return -1; /* error */
4523 return 0 ; /* end of file */
4525 SvCUR_set(buf_sv, old_len + len) ;
4526 SvPVX(buf_sv)[old_len + len] = '\0';
4529 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4530 if (PerlIO_error(PL_rsfp))
4531 return -1; /* error */
4533 return 0 ; /* end of file */
4536 return SvCUR(buf_sv);
4538 /* Skip this filter slot if filter has been deleted */
4539 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4540 DEBUG_P(PerlIO_printf(Perl_debug_log,
4541 "filter_read %d: skipped (filter deleted)\n",
4543 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4545 if (SvTYPE(datasv) != SVt_PVIO) {
4546 if (correct_length) {
4548 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4549 if (!remainder) return 0; /* eof */
4550 if (correct_length > remainder) correct_length = remainder;
4551 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4552 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4555 const char *s = SvEND(datasv);
4556 const char *send = SvPVX(datasv) + SvLEN(datasv);
4564 if (s == send) return 0; /* eof */
4565 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4566 SvCUR_set(datasv, s-SvPVX(datasv));
4568 return SvCUR(buf_sv);
4570 /* Get function pointer hidden within datasv */
4571 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4572 DEBUG_P(PerlIO_printf(Perl_debug_log,
4573 "filter_read %d: via function %p (%s)\n",
4574 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4575 /* Call function. The function is expected to */
4576 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4577 /* Return: <0:error, =0:eof, >0:not eof */
4579 save_scalar(PL_errgv);
4580 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4586 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4588 PERL_ARGS_ASSERT_FILTER_GETS;
4590 #ifdef PERL_CR_FILTER
4591 if (!PL_rsfp_filters) {
4592 filter_add(S_cr_textfilter,NULL);
4595 if (PL_rsfp_filters) {
4597 SvCUR_set(sv, 0); /* start with empty line */
4598 if (FILTER_READ(0, sv, 0) > 0)
4599 return ( SvPVX(sv) ) ;
4604 return (sv_gets(sv, PL_rsfp, append));
4608 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4612 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4614 if (memEQs(pkgname, len, "__PACKAGE__"))
4618 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4619 && (gv = gv_fetchpvn_flags(pkgname,
4621 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4623 return GvHV(gv); /* Foo:: */
4626 /* use constant CLASS => 'MyClass' */
4627 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4628 if (gv && GvCV(gv)) {
4629 SV * const sv = cv_const_sv(GvCV(gv));
4631 return gv_stashsv(sv, 0);
4634 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4639 S_tokenize_use(pTHX_ int is_use, char *s) {
4640 PERL_ARGS_ASSERT_TOKENIZE_USE;
4642 if (PL_expect != XSTATE)
4643 /* diag_listed_as: "use" not allowed in expression */
4644 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4645 is_use ? "use" : "no"));
4648 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4649 s = force_version(s, TRUE);
4650 if (*s == ';' || *s == '}'
4651 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4652 NEXTVAL_NEXTTOKE.opval = NULL;
4653 force_next(BAREWORD);
4655 else if (*s == 'v') {
4656 s = force_word(s,BAREWORD,FALSE,TRUE);
4657 s = force_version(s, FALSE);
4661 s = force_word(s,BAREWORD,FALSE,TRUE);
4662 s = force_version(s, FALSE);
4664 pl_yylval.ival = is_use;
4668 static const char* const exp_name[] =
4669 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4670 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4671 "SIGVAR", "TERMORDORDOR"
4675 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4677 S_word_takes_any_delimiter(char *p, STRLEN len)
4679 return (len == 1 && strchr("msyq", p[0]))
4681 && ((p[0] == 't' && p[1] == 'r')
4682 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4686 S_check_scalar_slice(pTHX_ char *s)
4689 while (SPACE_OR_TAB(*s)) s++;
4690 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4696 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4697 || (*s && strchr(" \t$#+-'\"", *s)))
4699 s += UTF ? UTF8SKIP(s) : 1;
4701 if (*s == '}' || *s == ']')
4702 pl_yylval.ival = OPpSLICEWARNING;
4705 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4707 S_lex_token_boundary(pTHX)
4709 PL_oldoldbufptr = PL_oldbufptr;
4710 PL_oldbufptr = PL_bufptr;
4713 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4715 S_vcs_conflict_marker(pTHX_ char *s)
4717 lex_token_boundary();
4719 yyerror("Version control conflict marker");
4720 while (s < PL_bufend && *s != '\n')
4728 Works out what to call the token just pulled out of the input
4729 stream. The yacc parser takes care of taking the ops we return and
4730 stitching them into a tree.
4733 The type of the next token
4736 Check if we have already built the token; if so, use it.
4737 Switch based on the current state:
4738 - if we have a case modifier in a string, deal with that
4739 - handle other cases of interpolation inside a string
4740 - scan the next line if we are inside a format
4741 In the normal state, switch on the next character:
4743 if alphabetic, go to key lookup
4744 unrecognized character - croak
4745 - 0/4/26: handle end-of-line or EOF
4746 - cases for whitespace
4747 - \n and #: handle comments and line numbers
4748 - various operators, brackets and sigils
4751 - 'v': vstrings (or go to key lookup)
4752 - 'x' repetition operator (or go to key lookup)
4753 - other ASCII alphanumerics (key lookup begins here):
4756 scan built-in keyword (but do nothing with it yet)
4757 check for statement label
4758 check for lexical subs
4759 goto just_a_word if there is one
4760 see whether built-in keyword is overridden
4761 switch on keyword number:
4762 - default: just_a_word:
4763 not a built-in keyword; handle bareword lookup
4764 disambiguate between method and sub call
4765 fall back to bareword
4766 - cases for built-in keywords
4774 char *s = PL_bufptr;
4778 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4782 /* orig_keyword, gvp, and gv are initialized here because
4783 * jump to the label just_a_word_zero can bypass their
4784 * initialization later. */
4785 I32 orig_keyword = 0;
4789 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4790 const U8* first_bad_char_loc;
4791 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4792 PL_bufend - PL_bufptr,
4793 &first_bad_char_loc)))
4795 _force_out_malformed_utf8_message(first_bad_char_loc,
4798 1 /* 1 means die */ );
4799 NOT_REACHED; /* NOTREACHED */
4801 PL_parser->recheck_utf8_validity = FALSE;
4804 SV* tmp = newSVpvs("");
4805 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4806 (IV)CopLINE(PL_curcop),
4807 lex_state_names[PL_lex_state],
4808 exp_name[PL_expect],
4809 pv_display(tmp, s, strlen(s), 0, 60));
4813 /* when we've already built the next token, just pull it out of the queue */
4816 pl_yylval = PL_nextval[PL_nexttoke];
4819 next_type = PL_nexttype[PL_nexttoke];
4820 if (next_type & (7<<24)) {
4821 if (next_type & (1<<24)) {
4822 if (PL_lex_brackets > 100)
4823 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4824 PL_lex_brackstack[PL_lex_brackets++] =
4825 (char) ((next_type >> 16) & 0xff);
4827 if (next_type & (2<<24))
4828 PL_lex_allbrackets++;
4829 if (next_type & (4<<24))
4830 PL_lex_allbrackets--;
4831 next_type &= 0xffff;
4833 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4837 switch (PL_lex_state) {
4839 case LEX_INTERPNORMAL:
4842 /* interpolated case modifiers like \L \U, including \Q and \E.
4843 when we get here, PL_bufptr is at the \
4845 case LEX_INTERPCASEMOD:
4847 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4849 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4850 PL_bufptr, PL_bufend, *PL_bufptr);
4852 /* handle \E or end of string */
4853 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4855 if (PL_lex_casemods) {
4856 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4857 PL_lex_casestack[PL_lex_casemods] = '\0';
4859 if (PL_bufptr != PL_bufend
4860 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4861 || oldmod == 'F')) {
4863 PL_lex_state = LEX_INTERPCONCAT;
4865 PL_lex_allbrackets--;
4868 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4869 /* Got an unpaired \E */
4870 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4871 "Useless use of \\E");
4873 if (PL_bufptr != PL_bufend)
4875 PL_lex_state = LEX_INTERPCONCAT;
4879 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4880 "### Saw case modifier\n"); });
4882 if (s[1] == '\\' && s[2] == 'E') {
4884 PL_lex_state = LEX_INTERPCONCAT;
4889 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
4890 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
4892 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4894 if ((*s == 'L' || *s == 'U' || *s == 'F')
4895 && (strpbrk(PL_lex_casestack, "LUF")))
4897 PL_lex_casestack[--PL_lex_casemods] = '\0';
4898 PL_lex_allbrackets--;
4901 if (PL_lex_casemods > 10)
4902 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4903 PL_lex_casestack[PL_lex_casemods++] = *s;
4904 PL_lex_casestack[PL_lex_casemods] = '\0';
4905 PL_lex_state = LEX_INTERPCONCAT;
4906 NEXTVAL_NEXTTOKE.ival = 0;
4907 force_next((2<<24)|'(');
4909 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4911 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4913 NEXTVAL_NEXTTOKE.ival = OP_LC;
4915 NEXTVAL_NEXTTOKE.ival = OP_UC;
4917 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4919 NEXTVAL_NEXTTOKE.ival = OP_FC;
4921 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4925 if (PL_lex_starts) {
4928 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4929 if (PL_lex_casemods == 1 && PL_lex_inpat)
4932 AopNOASSIGN(OP_CONCAT);
4938 case LEX_INTERPPUSH:
4939 return REPORT(sublex_push());
4941 case LEX_INTERPSTART:
4942 if (PL_bufptr == PL_bufend)
4943 return REPORT(sublex_done());
4944 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4945 "### Interpolated variable\n"); });
4947 /* for /@a/, we leave the joining for the regex engine to do
4948 * (unless we're within \Q etc) */
4949 PL_lex_dojoin = (*PL_bufptr == '@'
4950 && (!PL_lex_inpat || PL_lex_casemods));
4951 PL_lex_state = LEX_INTERPNORMAL;
4952 if (PL_lex_dojoin) {
4953 NEXTVAL_NEXTTOKE.ival = 0;
4955 force_ident("\"", '$');
4956 NEXTVAL_NEXTTOKE.ival = 0;
4958 NEXTVAL_NEXTTOKE.ival = 0;
4959 force_next((2<<24)|'(');
4960 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4963 /* Convert (?{...}) and friends to 'do {...}' */
4964 if (PL_lex_inpat && *PL_bufptr == '(') {
4965 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4967 if (*PL_bufptr != '{')
4969 PL_expect = XTERMBLOCK;
4973 if (PL_lex_starts++) {
4975 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4976 if (!PL_lex_casemods && PL_lex_inpat)
4979 AopNOASSIGN(OP_CONCAT);
4983 case LEX_INTERPENDMAYBE:
4984 if (intuit_more(PL_bufptr, PL_bufend)) {
4985 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4991 if (PL_lex_dojoin) {
4992 const U8 dojoin_was = PL_lex_dojoin;
4993 PL_lex_dojoin = FALSE;
4994 PL_lex_state = LEX_INTERPCONCAT;
4995 PL_lex_allbrackets--;
4996 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
4998 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4999 && SvEVALED(PL_lex_repl))
5001 if (PL_bufptr != PL_bufend)
5002 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5005 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5006 re_eval_str. If the here-doc body’s length equals the previous
5007 value of re_eval_start, re_eval_start will now be null. So
5008 check re_eval_str as well. */
5009 if (PL_parser->lex_shared->re_eval_start
5010 || PL_parser->lex_shared->re_eval_str) {
5012 if (*PL_bufptr != ')')
5013 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5015 /* having compiled a (?{..}) expression, return the original
5016 * text too, as a const */
5017 if (PL_parser->lex_shared->re_eval_str) {
5018 sv = PL_parser->lex_shared->re_eval_str;
5019 PL_parser->lex_shared->re_eval_str = NULL;
5021 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5022 SvPV_shrink_to_cur(sv);
5024 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5025 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5026 NEXTVAL_NEXTTOKE.opval =
5027 newSVOP(OP_CONST, 0,
5030 PL_parser->lex_shared->re_eval_start = NULL;
5036 case LEX_INTERPCONCAT:
5038 if (PL_lex_brackets)
5039 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5040 (long) PL_lex_brackets);
5042 if (PL_bufptr == PL_bufend)
5043 return REPORT(sublex_done());
5045 /* m'foo' still needs to be parsed for possible (?{...}) */
5046 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5047 SV *sv = newSVsv(PL_linestr);
5049 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5053 int save_error_count = PL_error_count;
5055 s = scan_const(PL_bufptr);
5057 /* Set flag if this was a pattern and there were errors. op.c will
5058 * refuse to compile a pattern with this flag set. Otherwise, we
5059 * could get segfaults, etc. */
5060 if (PL_lex_inpat && PL_error_count > save_error_count) {
5061 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5064 PL_lex_state = LEX_INTERPCASEMOD;
5066 PL_lex_state = LEX_INTERPSTART;
5069 if (s != PL_bufptr) {
5070 NEXTVAL_NEXTTOKE = pl_yylval;
5073 if (PL_lex_starts++) {
5074 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5075 if (!PL_lex_casemods && PL_lex_inpat)
5078 AopNOASSIGN(OP_CONCAT);
5088 assert(PL_lex_formbrack);
5089 s = scan_formline(PL_bufptr);
5090 if (!PL_lex_formbrack)
5099 /* We really do *not* want PL_linestr ever becoming a COW. */
5100 assert (!SvIsCOW(PL_linestr));
5102 PL_oldoldbufptr = PL_oldbufptr;
5104 PL_parser->saw_infix_sigil = 0;
5106 if (PL_in_my == KEY_sigvar) {
5107 /* we expect the sigil and optional var name part of a
5108 * signature element here. Since a '$' is not necessarily
5109 * followed by a var name, handle it specially here; the general
5110 * yylex code would otherwise try to interpret whatever follows
5111 * as a var; e.g. ($, ...) would be seen as the var '$,'
5118 PL_bufptr = s; /* for error reporting */
5123 /* spot stuff that looks like an prototype */
5124 if (strchr("$:@%&*;\\[]", *s)) {
5125 yyerror("Illegal character following sigil in a subroutine signature");
5128 /* '$#' is banned, while '$ # comment' isn't */
5130 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5134 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5135 char *dest = PL_tokenbuf + 1;
5136 /* read var name, including sigil, into PL_tokenbuf */
5137 PL_tokenbuf[0] = sigil;
5138 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5139 0, cBOOL(UTF), FALSE, FALSE);
5141 assert(PL_tokenbuf[1]); /* we have a variable name */
5149 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
5150 * as the ASSIGNOP, and exclude other tokens that start with =
5152 if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
5153 /* save now to report with the same context as we did when
5154 * all ASSIGNOPS were accepted */
5158 NEXTVAL_NEXTTOKE.ival = 0;
5159 force_next(ASSIGNOP);
5162 else if (*s == ',' || *s == ')') {
5163 PL_expect = XOPERATOR;
5166 /* make sure the context shows the unexpected character and
5167 * hopefully a bit more */
5169 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5171 PL_bufptr = s; /* for error reporting */
5172 yyerror("Illegal operator following parameter in a subroutine signature");
5176 NEXTVAL_NEXTTOKE.ival = sigil;
5177 force_next('p'); /* force a signature pending identifier */
5184 case ',': /* handle ($a,,$b) */
5189 yyerror("A signature parameter must start with '$', '@' or '%'");
5190 /* very crude error recovery: skip to likely next signature
5192 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5203 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5207 else if (isALNUMC(*s)) {
5211 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5214 STRLEN skiplen = UTF8SKIP(s);
5215 STRLEN stravail = PL_bufend - s;
5216 c = sv_uni_display(dsv, newSVpvn_flags(s,
5217 skiplen > stravail ? stravail : skiplen,
5218 SVs_TEMP | SVf_UTF8),
5219 10, UNI_DISPLAY_ISPRINT);
5222 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5225 if (s >= PL_linestart) {
5229 /* somehow (probably due to a parse failure), PL_linestart has advanced
5230 * pass PL_bufptr, get a reasonable beginning of line
5233 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
5236 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
5237 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5238 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
5241 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5242 UTF8fARG(UTF, (s - d), d),
5247 goto fake_eof; /* emulate EOF on ^D or ^Z */
5249 if ((!PL_rsfp || PL_lex_inwhat)
5250 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5254 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5256 yyerror((const char *)
5258 ? "Format not terminated"
5259 : "Missing right curly or square bracket"));
5261 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5262 "### Tokener got EOF\n");
5266 if (s++ < PL_bufend)
5267 goto retry; /* ignore stray nulls */
5270 if (!PL_in_eval && !PL_preambled) {
5271 PL_preambled = TRUE;
5273 /* Generate a string of Perl code to load the debugger.
5274 * If PERL5DB is set, it will return the contents of that,
5275 * otherwise a compile-time require of perl5db.pl. */
5277 const char * const pdb = PerlEnv_getenv("PERL5DB");
5280 sv_setpv(PL_linestr, pdb);
5281 sv_catpvs(PL_linestr,";");
5283 SETERRNO(0,SS_NORMAL);
5284 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5286 PL_parser->preambling = CopLINE(PL_curcop);
5288 SvPVCLEAR(PL_linestr);
5289 if (PL_preambleav) {
5290 SV **svp = AvARRAY(PL_preambleav);
5291 SV **const end = svp + AvFILLp(PL_preambleav);
5293 sv_catsv(PL_linestr, *svp);
5295 sv_catpvs(PL_linestr, ";");
5297 sv_free(MUTABLE_SV(PL_preambleav));
5298 PL_preambleav = NULL;
5301 sv_catpvs(PL_linestr,
5302 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5303 if (PL_minus_n || PL_minus_p) {
5304 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5306 sv_catpvs(PL_linestr,"chomp;");
5309 if ( ( *PL_splitstr == '/'
5310 || *PL_splitstr == '\''
5311 || *PL_splitstr == '"')
5312 && strchr(PL_splitstr + 1, *PL_splitstr))
5314 /* strchr is ok, because -F pattern can't contain
5316 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5319 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5320 bytes can be used as quoting characters. :-) */
5321 const char *splits = PL_splitstr;
5322 sv_catpvs(PL_linestr, "our @F=split(q\0");
5325 if (*splits == '\\')
5326 sv_catpvn(PL_linestr, splits, 1);
5327 sv_catpvn(PL_linestr, splits, 1);
5328 } while (*splits++);
5329 /* This loop will embed the trailing NUL of
5330 PL_linestr as the last thing it does before
5332 sv_catpvs(PL_linestr, ");");
5336 sv_catpvs(PL_linestr,"our @F=split(' ');");
5339 sv_catpvs(PL_linestr, "\n");
5340 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5341 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5342 PL_last_lop = PL_last_uni = NULL;
5343 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5344 update_debugger_info(PL_linestr, NULL, 0);
5349 bof = cBOOL(PL_rsfp);
5352 fake_eof = LEX_FAKE_EOF;
5354 PL_bufptr = PL_bufend;
5355 COPLINE_INC_WITH_HERELINES;
5356 if (!lex_next_chunk(fake_eof)) {
5357 CopLINE_dec(PL_curcop);
5359 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5361 CopLINE_dec(PL_curcop);
5363 /* If it looks like the start of a BOM or raw UTF-16,
5364 * check if it in fact is. */
5367 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5371 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5372 bof = (offset == (Off_t)SvCUR(PL_linestr));
5373 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5374 /* offset may include swallowed CR */
5376 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5379 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5380 s = swallow_bom((U8*)s);
5383 if (PL_parser->in_pod) {
5384 /* Incest with pod. */
5385 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
5388 SvPVCLEAR(PL_linestr);
5389 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5390 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5391 PL_last_lop = PL_last_uni = NULL;
5392 PL_parser->in_pod = 0;
5395 if (PL_rsfp || PL_parser->filtered)
5396 incline(s, PL_bufend);
5397 } while (PL_parser->in_pod);
5398 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5399 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5400 PL_last_lop = PL_last_uni = NULL;
5401 if (CopLINE(PL_curcop) == 1) {
5402 while (s < PL_bufend && isSPACE(*s))
5404 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5408 if (*s == '#' && *(s+1) == '!')
5410 #ifdef ALTERNATE_SHEBANG
5412 static char const as[] = ALTERNATE_SHEBANG;
5413 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5414 d = s + (sizeof(as) - 1);
5416 #endif /* ALTERNATE_SHEBANG */
5425 while (*d && !isSPACE(*d))
5429 #ifdef ARG_ZERO_IS_SCRIPT
5430 if (ipathend > ipath) {
5432 * HP-UX (at least) sets argv[0] to the script name,
5433 * which makes $^X incorrect. And Digital UNIX and Linux,
5434 * at least, set argv[0] to the basename of the Perl
5435 * interpreter. So, having found "#!", we'll set it right.
5437 SV* copfilesv = CopFILESV(PL_curcop);
5440 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5442 assert(SvPOK(x) || SvGMAGICAL(x));
5443 if (sv_eq(x, copfilesv)) {
5444 sv_setpvn(x, ipath, ipathend - ipath);
5450 const char *bstart = SvPV_const(copfilesv, blen);
5451 const char * const lstart = SvPV_const(x, llen);
5453 bstart += blen - llen;
5454 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5455 sv_setpvn(x, ipath, ipathend - ipath);
5462 /* Anything to do if no copfilesv? */
5464 TAINT_NOT; /* $^X is always tainted, but that's OK */
5466 #endif /* ARG_ZERO_IS_SCRIPT */
5471 d = instr(s,"perl -");
5473 d = instr(s,"perl");
5475 /* avoid getting into infinite loops when shebang
5476 * line contains "Perl" rather than "perl" */
5478 for (d = ipathend-4; d >= ipath; --d) {
5479 if (isALPHA_FOLD_EQ(*d, 'p')
5480 && !ibcmp(d, "perl", 4))
5490 #ifdef ALTERNATE_SHEBANG
5492 * If the ALTERNATE_SHEBANG on this system starts with a
5493 * character that can be part of a Perl expression, then if
5494 * we see it but not "perl", we're probably looking at the
5495 * start of Perl code, not a request to hand off to some
5496 * other interpreter. Similarly, if "perl" is there, but
5497 * not in the first 'word' of the line, we assume the line
5498 * contains the start of the Perl program.
5500 if (d && *s != '#') {
5501 const char *c = ipath;
5502 while (*c && !strchr("; \t\r\n\f\v#", *c))
5505 d = NULL; /* "perl" not in first word; ignore */
5507 *s = '#'; /* Don't try to parse shebang line */
5509 #endif /* ALTERNATE_SHEBANG */
5514 && !instr(s,"indir")
5515 && instr(PL_origargv[0],"perl"))
5522 while (s < PL_bufend && isSPACE(*s))
5524 if (s < PL_bufend) {
5525 Newx(newargv,PL_origargc+3,char*);
5527 while (s < PL_bufend && !isSPACE(*s))
5530 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5533 newargv = PL_origargv;
5536 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5538 Perl_croak(aTHX_ "Can't exec %s", ipath);
5541 while (*d && !isSPACE(*d))
5543 while (SPACE_OR_TAB(*d))
5547 const bool switches_done = PL_doswitches;
5548 const U32 oldpdb = PL_perldb;
5549 const bool oldn = PL_minus_n;
5550 const bool oldp = PL_minus_p;
5554 bool baduni = FALSE;
5556 const char *d2 = d1 + 1;
5557 if (parse_unicode_opts((const char **)&d2)
5561 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5562 const char * const m = d1;
5563 while (*d1 && !isSPACE(*d1))
5565 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5568 d1 = moreswitches(d1);
5570 if (PL_doswitches && !switches_done) {
5571 int argc = PL_origargc;
5572 char **argv = PL_origargv;
5575 } while (argc && argv[0][0] == '-' && argv[0][1]);
5576 init_argv_symbols(argc,argv);
5578 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5579 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5580 /* if we have already added "LINE: while (<>) {",
5581 we must not do it again */
5583 SvPVCLEAR(PL_linestr);
5584 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5585 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5586 PL_last_lop = PL_last_uni = NULL;
5587 PL_preambled = FALSE;
5588 if (PERLDB_LINE_OR_SAVESRC)
5589 (void)gv_fetchfile(PL_origfilename);
5596 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5597 PL_lex_state = LEX_FORMLINE;
5598 force_next(FORMRBRACK);
5603 #ifdef PERL_STRICT_CR
5604 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5606 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5608 case ' ': case '\t': case '\f': case '\v':
5613 if (PL_lex_state != LEX_NORMAL
5614 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5616 const bool in_comment = *s == '#';
5617 if (*s == '#' && s == PL_linestart && PL_in_eval
5618 && !PL_rsfp && !PL_parser->filtered) {
5619 /* handle eval qq[#line 1 "foo"\n ...] */
5620 CopLINE_dec(PL_curcop);
5621 incline(s, PL_bufend);
5624 while (d < PL_bufend && *d != '\n')
5629 if (in_comment && d == PL_bufend
5630 && PL_lex_state == LEX_INTERPNORMAL
5631 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5632 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5634 incline(s, PL_bufend);
5635 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5636 PL_lex_state = LEX_FORMLINE;
5637 force_next(FORMRBRACK);
5642 while (s < PL_bufend && *s != '\n')
5648 incline(s, PL_bufend);
5653 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5661 while (s < PL_bufend && SPACE_OR_TAB(*s))
5664 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5665 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5666 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5667 OPERATOR('-'); /* unary minus */
5670 case 'r': ftst = OP_FTEREAD; break;
5671 case 'w': ftst = OP_FTEWRITE; break;
5672 case 'x': ftst = OP_FTEEXEC; break;
5673 case 'o': ftst = OP_FTEOWNED; break;
5674 case 'R': ftst = OP_FTRREAD; break;
5675 case 'W': ftst = OP_FTRWRITE; break;
5676 case 'X': ftst = OP_FTREXEC; break;
5677 case 'O': ftst = OP_FTROWNED; break;
5678 case 'e': ftst = OP_FTIS; break;
5679 case 'z': ftst = OP_FTZERO; break;
5680 case 's': ftst = OP_FTSIZE; break;
5681 case 'f': ftst = OP_FTFILE; break;
5682 case 'd': ftst = OP_FTDIR; break;
5683 case 'l': ftst = OP_FTLINK; break;
5684 case 'p': ftst = OP_FTPIPE; break;
5685 case 'S': ftst = OP_FTSOCK; break;
5686 case 'u': ftst = OP_FTSUID; break;
5687 case 'g': ftst = OP_FTSGID; break;
5688 case 'k': ftst = OP_FTSVTX; break;
5689 case 'b': ftst = OP_FTBLK; break;
5690 case 'c': ftst = OP_FTCHR; break;
5691 case 't': ftst = OP_FTTTY; break;
5692 case 'T': ftst = OP_FTTEXT; break;
5693 case 'B': ftst = OP_FTBINARY; break;
5694 case 'M': case 'A': case 'C':
5695 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5697 case 'M': ftst = OP_FTMTIME; break;
5698 case 'A': ftst = OP_FTATIME; break;
5699 case 'C': ftst = OP_FTCTIME; break;
5707 PL_last_uni = PL_oldbufptr;
5708 PL_last_lop_op = (OPCODE)ftst;
5709 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5710 "### Saw file test %c\n", (int)tmp);
5715 /* Assume it was a minus followed by a one-letter named
5716 * subroutine call (or a -bareword), then. */
5717 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5718 "### '-%c' looked like a file test but was not\n",
5725 const char tmp = *s++;
5728 if (PL_expect == XOPERATOR)
5733 else if (*s == '>') {
5736 if (((*s == '$' || *s == '&') && s[1] == '*')
5737 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5738 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5739 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5742 PL_expect = XPOSTDEREF;
5745 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5746 s = force_word(s,METHOD,FALSE,TRUE);
5754 if (PL_expect == XOPERATOR) {
5756 && !PL_lex_allbrackets
5757 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5765 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5767 OPERATOR('-'); /* unary minus */
5773 const char tmp = *s++;
5776 if (PL_expect == XOPERATOR)
5781 if (PL_expect == XOPERATOR) {
5783 && !PL_lex_allbrackets
5784 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5792 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5799 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5800 if (PL_expect != XOPERATOR) {
5801 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5802 PL_expect = XOPERATOR;
5803 force_ident(PL_tokenbuf, '*');
5811 if (*s == '=' && !PL_lex_allbrackets
5812 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5820 && !PL_lex_allbrackets
5821 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5826 PL_parser->saw_infix_sigil = 1;
5831 if (PL_expect == XOPERATOR) {
5833 && !PL_lex_allbrackets
5834 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5839 PL_parser->saw_infix_sigil = 1;
5842 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5843 PL_tokenbuf[0] = '%';
5844 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5846 if (!PL_tokenbuf[1]) {
5849 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5850 && intuit_more(s, PL_bufend)) {
5852 PL_tokenbuf[0] = '@';
5854 PL_expect = XOPERATOR;
5855 force_ident_maybe_lex('%');
5860 bof = FEATURE_BITWISE_IS_ENABLED;
5861 if (bof && s[1] == '.')
5863 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5864 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5870 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5872 if (PL_lex_brackets > 100)
5873 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5874 PL_lex_brackstack[PL_lex_brackets++] = 0;
5875 PL_lex_allbrackets++;
5877 const char tmp = *s++;
5882 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5884 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5887 Perl_ck_warner_d(aTHX_
5888 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5889 "Smartmatch is experimental");
5893 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5895 BCop(OP_SCOMPLEMENT);
5897 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5899 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5906 goto just_a_word_zero_gv;
5912 switch (PL_expect) {
5914 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5916 PL_bufptr = s; /* update in case we back off */
5919 "Use of := for an empty attribute list is not allowed");
5926 PL_expect = XTERMBLOCK;
5930 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5933 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5934 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5935 if (tmp < 0) tmp = -tmp;
5950 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5952 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5957 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5959 COPLINE_SET_FROM_MULTI_END;
5962 sv_catsv(sv, PL_lex_stuff);
5963 attrs = op_append_elem(OP_LIST, attrs,
5964 newSVOP(OP_CONST, 0, sv));
5965 SvREFCNT_dec_NN(PL_lex_stuff);
5966 PL_lex_stuff = NULL;
5969 /* NOTE: any CV attrs applied here need to be part of
5970 the CVf_BUILTIN_ATTRS define in cv.h! */
5971 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
5973 CvLVALUE_on(PL_compcv);
5975 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
5977 CvMETHOD_on(PL_compcv);
5979 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
5982 Perl_ck_warner_d(aTHX_
5983 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5984 ":const is experimental"
5986 CvANONCONST_on(PL_compcv);
5987 if (!CvANON(PL_compcv))
5988 yyerror(":const is not permitted on named "
5991 /* After we've set the flags, it could be argued that
5992 we don't need to do the attributes.pm-based setting
5993 process, and shouldn't bother appending recognized
5994 flags. To experiment with that, uncomment the
5995 following "else". (Note that's already been
5996 uncommented. That keeps the above-applied built-in
5997 attributes from being intercepted (and possibly
5998 rejected) by a package's attribute routines, but is
5999 justified by the performance win for the common case
6000 of applying only built-in attributes.) */
6002 attrs = op_append_elem(OP_LIST, attrs,
6003 newSVOP(OP_CONST, 0,
6007 if (*s == ':' && s[1] != ':')
6010 break; /* require real whitespace or :'s */
6011 /* XXX losing whitespace on sequential attributes here */
6016 && !(PL_expect == XOPERATOR
6017 ? (*s == '=' || *s == ')')
6018 : (*s == '{' || *s == '(')))
6020 const char q = ((*s == '\'') ? '"' : '\'');
6021 /* If here for an expression, and parsed no attrs, back
6023 if (PL_expect == XOPERATOR && !attrs) {
6027 /* MUST advance bufptr here to avoid bogus "at end of line"
6028 context messages from yyerror().
6031 yyerror( (const char *)
6033 ? Perl_form(aTHX_ "Invalid separator character "
6034 "%c%c%c in attribute list", q, *s, q)
6035 : "Unterminated attribute list" ) );
6043 NEXTVAL_NEXTTOKE.opval = attrs;
6049 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6053 PL_lex_allbrackets--;
6057 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6058 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6062 PL_lex_allbrackets++;
6065 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6072 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6075 PL_lex_allbrackets--;
6081 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6084 if (PL_lex_brackets <= 0)
6085 /* diag_listed_as: Unmatched right %s bracket */
6086 yyerror("Unmatched right square bracket");
6089 PL_lex_allbrackets--;
6090 if (PL_lex_state == LEX_INTERPNORMAL) {
6091 if (PL_lex_brackets == 0) {
6092 if (*s == '-' && s[1] == '>')
6093 PL_lex_state = LEX_INTERPENDMAYBE;
6094 else if (*s != '[' && *s != '{')
6095 PL_lex_state = LEX_INTERPEND;
6102 if (PL_lex_brackets > 100) {
6103 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6105 switch (PL_expect) {
6108 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6109 PL_lex_allbrackets++;
6110 OPERATOR(HASHBRACK);
6112 while (s < PL_bufend && SPACE_OR_TAB(*s))
6115 PL_tokenbuf[0] = '\0';
6116 if (d < PL_bufend && *d == '-') {
6117 PL_tokenbuf[0] = '-';
6119 while (d < PL_bufend && SPACE_OR_TAB(*d))
6122 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6123 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6125 while (d < PL_bufend && SPACE_OR_TAB(*d))
6128 const char minus = (PL_tokenbuf[0] == '-');
6129 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6137 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6138 PL_lex_allbrackets++;
6143 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6144 PL_lex_allbrackets++;
6148 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6149 PL_lex_allbrackets++;
6154 if (PL_oldoldbufptr == PL_last_lop)
6155 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6157 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6158 PL_lex_allbrackets++;
6161 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6163 /* This hack is to get the ${} in the message. */
6165 yyerror("syntax error");
6168 OPERATOR(HASHBRACK);
6170 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6171 /* ${...} or @{...} etc., but not print {...}
6172 * Skip the disambiguation and treat this as a block.
6174 goto block_expectation;
6176 /* This hack serves to disambiguate a pair of curlies
6177 * as being a block or an anon hash. Normally, expectation
6178 * determines that, but in cases where we're not in a
6179 * position to expect anything in particular (like inside
6180 * eval"") we have to resolve the ambiguity. This code
6181 * covers the case where the first term in the curlies is a
6182 * quoted string. Most other cases need to be explicitly
6183 * disambiguated by prepending a "+" before the opening
6184 * curly in order to force resolution as an anon hash.
6186 * XXX should probably propagate the outer expectation
6187 * into eval"" to rely less on this hack, but that could
6188 * potentially break current behavior of eval"".
6192 if (*s == '\'' || *s == '"' || *s == '`') {
6193 /* common case: get past first string, handling escapes */
6194 for (t++; t < PL_bufend && *t != *s;)
6199 else if (*s == 'q') {
6202 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6203 && !isWORDCHAR(*t))))
6205 /* skip q//-like construct */
6207 char open, close, term;
6210 while (t < PL_bufend && isSPACE(*t))
6212 /* check for q => */
6213 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6214 OPERATOR(HASHBRACK);
6218 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6222 for (t++; t < PL_bufend; t++) {
6223 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6225 else if (*t == open)
6229 for (t++; t < PL_bufend; t++) {
6230 if (*t == '\\' && t+1 < PL_bufend)
6232 else if (*t == close && --brackets <= 0)
6234 else if (*t == open)
6241 /* skip plain q word */
6242 while ( t < PL_bufend
6243 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6245 t += UTF ? UTF8SKIP(t) : 1;
6248 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6249 t += UTF ? UTF8SKIP(t) : 1;
6250 while ( t < PL_bufend
6251 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6253 t += UTF ? UTF8SKIP(t) : 1;
6256 while (t < PL_bufend && isSPACE(*t))
6258 /* if comma follows first term, call it an anon hash */
6259 /* XXX it could be a comma expression with loop modifiers */
6260 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6261 || (*t == '=' && t[1] == '>')))
6262 OPERATOR(HASHBRACK);
6263 if (PL_expect == XREF)
6266 /* If there is an opening brace or 'sub:', treat it
6267 as a term to make ${{...}}{k} and &{sub:attr...}
6268 dwim. Otherwise, treat it as a statement, so
6269 map {no strict; ...} works.
6276 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6289 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6295 pl_yylval.ival = CopLINE(PL_curcop);
6296 PL_copline = NOLINE; /* invalidate current command line number */
6297 TOKEN(formbrack ? '=' : '{');
6299 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6302 assert(s != PL_bufend);
6304 if (PL_lex_brackets <= 0)
6305 /* diag_listed_as: Unmatched right %s bracket */
6306 yyerror("Unmatched right curly bracket");
6308 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6309 PL_lex_allbrackets--;
6310 if (PL_lex_state == LEX_INTERPNORMAL) {
6311 if (PL_lex_brackets == 0) {
6312 if (PL_expect & XFAKEBRACK) {
6313 PL_expect &= XENUMMASK;
6314 PL_lex_state = LEX_INTERPEND;
6316 return yylex(); /* ignore fake brackets */
6318 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6319 && SvEVALED(PL_lex_repl))
6320 PL_lex_state = LEX_INTERPEND;
6321 else if (*s == '-' && s[1] == '>')
6322 PL_lex_state = LEX_INTERPENDMAYBE;
6323 else if (*s != '[' && *s != '{')
6324 PL_lex_state = LEX_INTERPEND;
6327 if (PL_expect & XFAKEBRACK) {
6328 PL_expect &= XENUMMASK;
6330 return yylex(); /* ignore fake brackets */
6332 force_next(formbrack ? '.' : '}');
6333 if (formbrack) LEAVE_with_name("lex_format");
6334 if (formbrack == 2) { /* means . where arguments were expected */
6340 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6343 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6344 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6351 if (PL_expect == XOPERATOR) {
6352 if ( PL_bufptr == PL_linestart
6353 && ckWARN(WARN_SEMICOLON)
6354 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6356 CopLINE_dec(PL_curcop);
6357 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6358 CopLINE_inc(PL_curcop);
6361 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6363 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6364 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6370 PL_parser->saw_infix_sigil = 1;
6371 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6377 PL_tokenbuf[0] = '&';
6378 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6379 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6380 if (PL_tokenbuf[1]) {
6381 force_ident_maybe_lex('&');
6390 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6391 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6399 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6401 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6402 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6406 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6410 const char tmp = *s++;
6412 if ( (s == PL_linestart+2 || s[-3] == '\n')
6413 && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
6415 s = vcs_conflict_marker(s + 5);
6418 if (!PL_lex_allbrackets
6419 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6427 if (!PL_lex_allbrackets
6428 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6437 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6438 && strchr("+-*/%.^&|<",tmp))
6439 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6440 "Reversed %c= operator",(int)tmp);
6442 if (PL_expect == XSTATE
6444 && (s == PL_linestart+1 || s[-2] == '\n') )
6446 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6447 || PL_lex_state != LEX_NORMAL)
6452 incline(s, PL_bufend);
6453 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
6455 s = (char *) memchr(s,'\n', d - s);
6460 incline(s, PL_bufend);
6468 PL_parser->in_pod = 1;
6472 if (PL_expect == XBLOCK) {
6474 #ifdef PERL_STRICT_CR
6475 while (SPACE_OR_TAB(*t))
6477 while (SPACE_OR_TAB(*t) || *t == '\r')
6480 if (*t == '\n' || *t == '#') {
6482 ENTER_with_name("lex_format");
6483 SAVEI8(PL_parser->form_lex_state);
6484 SAVEI32(PL_lex_formbrack);
6485 PL_parser->form_lex_state = PL_lex_state;
6486 PL_lex_formbrack = PL_lex_brackets + 1;
6490 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6499 const char tmp = *s++;
6501 /* was this !=~ where !~ was meant?
6502 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6504 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6505 const char *t = s+1;
6507 while (t < PL_bufend && isSPACE(*t))
6510 if (*t == '/' || *t == '?'
6511 || ((*t == 'm' || *t == 's' || *t == 'y')
6512 && !isWORDCHAR(t[1]))
6513 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6515 "!=~ should be !~");
6517 if (!PL_lex_allbrackets
6518 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6531 if (PL_expect != XOPERATOR) {
6532 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6534 if (s[1] == '<' && s[2] != '>') {
6535 if ( (s == PL_linestart || s[-1] == '\n')
6536 && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
6538 s = vcs_conflict_marker(s + 7);
6541 s = scan_heredoc(s);
6544 s = scan_inputsymbol(s);
6545 PL_expect = XOPERATOR;
6546 TOKEN(sublex_start());
6552 if ( (s == PL_linestart+2 || s[-3] == '\n')
6553 && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
6555 s = vcs_conflict_marker(s + 5);
6558 if (*s == '=' && !PL_lex_allbrackets
6559 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6564 SHop(OP_LEFT_SHIFT);
6569 if (!PL_lex_allbrackets
6570 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6578 if (!PL_lex_allbrackets
6579 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6588 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6596 const char tmp = *s++;
6598 if ( (s == PL_linestart+2 || s[-3] == '\n')
6599 && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
6601 s = vcs_conflict_marker(s + 5);
6604 if (*s == '=' && !PL_lex_allbrackets
6605 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6610 SHop(OP_RIGHT_SHIFT);
6612 else if (tmp == '=') {
6613 if (!PL_lex_allbrackets
6614 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6623 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6632 if (PL_expect == XPOSTDEREF) {
6635 POSTDEREF(DOLSHARP);
6641 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6642 || strchr("{$:+-@", s[2])))
6644 PL_tokenbuf[0] = '@';
6645 s = scan_ident(s + 1, PL_tokenbuf + 1,
6646 sizeof PL_tokenbuf - 1, FALSE);
6647 if (PL_expect == XOPERATOR) {
6649 if (PL_bufptr > s) {
6651 PL_bufptr = PL_oldbufptr;
6653 no_op("Array length", d);
6655 if (!PL_tokenbuf[1])
6657 PL_expect = XOPERATOR;
6658 force_ident_maybe_lex('#');
6662 PL_tokenbuf[0] = '$';
6663 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6664 if (PL_expect == XOPERATOR) {
6666 if (PL_bufptr > s) {
6668 PL_bufptr = PL_oldbufptr;
6672 if (!PL_tokenbuf[1]) {
6674 yyerror("Final $ should be \\$ or $name");
6680 const char tmp = *s;
6681 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6684 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6685 && intuit_more(s, PL_bufend)) {
6687 PL_tokenbuf[0] = '@';
6688 if (ckWARN(WARN_SYNTAX)) {
6692 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6695 t += UTF ? UTF8SKIP(t) : 1;
6698 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6699 while (t < PL_bufend && *t != ']')
6701 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6702 "Multidimensional syntax %" UTF8f " not supported",
6703 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6707 else if (*s == '{') {
6709 PL_tokenbuf[0] = '%';
6710 if ( strEQ(PL_tokenbuf+1, "SIG")
6711 && ckWARN(WARN_SYNTAX)
6712 && (t = (char *) memchr(s, '}', PL_bufend - s))
6713 && (t = (char *) memchr(t, '=', PL_bufend - t)))
6715 char tmpbuf[sizeof PL_tokenbuf];
6718 } while (isSPACE(*t));
6719 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6721 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6726 && get_cvn_flags(tmpbuf, len, UTF
6730 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6731 "You need to quote \"%" UTF8f "\"",
6732 UTF8fARG(UTF, len, tmpbuf));
6739 PL_expect = XOPERATOR;
6740 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6741 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6742 if (!islop || PL_last_lop_op == OP_GREPSTART)
6743 PL_expect = XOPERATOR;
6744 else if (strchr("$@\"'`q", *s))
6745 PL_expect = XTERM; /* e.g. print $fh "foo" */
6746 else if ( strchr("&*<%", *s)
6747 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6749 PL_expect = XTERM; /* e.g. print $fh &sub */
6751 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6752 char tmpbuf[sizeof PL_tokenbuf];
6754 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6755 if ((t2 = keyword(tmpbuf, len, 0))) {
6756 /* binary operators exclude handle interpretations */
6768 PL_expect = XTERM; /* e.g. print $fh length() */
6773 PL_expect = XTERM; /* e.g. print $fh subr() */
6776 else if (isDIGIT(*s))
6777 PL_expect = XTERM; /* e.g. print $fh 3 */
6778 else if (*s == '.' && isDIGIT(s[1]))
6779 PL_expect = XTERM; /* e.g. print $fh .3 */
6780 else if ((*s == '?' || *s == '-' || *s == '+')
6781 && !isSPACE(s[1]) && s[1] != '=')
6782 PL_expect = XTERM; /* e.g. print $fh -1 */
6783 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6785 PL_expect = XTERM; /* e.g. print $fh /.../
6786 XXX except DORDOR operator
6788 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6790 PL_expect = XTERM; /* print $fh <<"EOF" */
6793 force_ident_maybe_lex('$');
6797 if (PL_expect == XPOSTDEREF)
6799 PL_tokenbuf[0] = '@';
6800 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6801 if (PL_expect == XOPERATOR) {
6803 if (PL_bufptr > s) {
6805 PL_bufptr = PL_oldbufptr;
6810 if (!PL_tokenbuf[1]) {
6813 if (PL_lex_state == LEX_NORMAL)
6815 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6816 && intuit_more(s, PL_bufend))
6819 PL_tokenbuf[0] = '%';
6821 /* Warn about @ where they meant $. */
6822 if (*s == '[' || *s == '{') {
6823 if (ckWARN(WARN_SYNTAX)) {
6824 S_check_scalar_slice(aTHX_ s);
6828 PL_expect = XOPERATOR;
6829 force_ident_maybe_lex('@');
6832 case '/': /* may be division, defined-or, or pattern */
6833 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6834 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6835 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6840 else if (PL_expect == XOPERATOR) {
6842 if (*s == '=' && !PL_lex_allbrackets
6843 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6851 /* Disable warning on "study /blah/" */
6852 if ( PL_oldoldbufptr == PL_last_uni
6853 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6854 || memNE(PL_last_uni, "study", 5)
6855 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6858 s = scan_pat(s,OP_MATCH);
6859 TERM(sublex_start());
6862 case '?': /* conditional */
6864 if (!PL_lex_allbrackets
6865 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6870 PL_lex_allbrackets++;
6874 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6875 #ifdef PERL_STRICT_CR
6878 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6880 && (s == PL_linestart || s[-1] == '\n') )
6883 formbrack = 2; /* dot seen where arguments expected */
6886 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6890 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6893 if (!PL_lex_allbrackets
6894 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6902 pl_yylval.ival = OPf_SPECIAL;
6908 if (*s == '=' && !PL_lex_allbrackets
6909 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6917 case '0': case '1': case '2': case '3': case '4':
6918 case '5': case '6': case '7': case '8': case '9':
6919 s = scan_num(s, &pl_yylval);
6920 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6921 if (PL_expect == XOPERATOR)
6926 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6928 missingterm(NULL, 0);
6929 COPLINE_SET_FROM_MULTI_END;
6930 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6931 if (PL_expect == XOPERATOR) {
6934 pl_yylval.ival = OP_CONST;
6935 TERM(sublex_start());
6938 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6941 printbuf("### Saw string before %s\n", s);
6943 PerlIO_printf(Perl_debug_log,
6944 "### Saw unterminated string\n");
6946 if (PL_expect == XOPERATOR) {
6950 missingterm(NULL, 0);
6951 pl_yylval.ival = OP_CONST;
6952 /* FIXME. I think that this can be const if char *d is replaced by
6953 more localised variables. */
6954 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6955 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6956 pl_yylval.ival = OP_STRINGIFY;
6960 if (pl_yylval.ival == OP_CONST)
6961 COPLINE_SET_FROM_MULTI_END;
6962 TERM(sublex_start());
6965 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6968 printbuf("### Saw backtick string before %s\n", s);
6970 PerlIO_printf(Perl_debug_log,
6971 "### Saw unterminated backtick string\n");
6973 if (PL_expect == XOPERATOR)
6974 no_op("Backticks",s);
6976 missingterm(NULL, 0);
6977 pl_yylval.ival = OP_BACKTICK;
6978 TERM(sublex_start());
6982 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6984 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6986 if (PL_expect == XOPERATOR)
6987 no_op("Backslash",s);
6991 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6992 char *start = s + 2;
6993 while (isDIGIT(*start) || *start == '_')
6995 if (*start == '.' && isDIGIT(start[1])) {
6996 s = scan_num(s, &pl_yylval);
6999 else if ((*start == ':' && start[1] == ':')
7000 || (PL_expect == XSTATE && *start == ':'))
7002 else if (PL_expect == XSTATE) {
7004 while (d < PL_bufend && isSPACE(*d)) d++;
7005 if (*d == ':') goto keylookup;
7007 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
7008 if (!isALPHA(*start) && (PL_expect == XTERM
7009 || PL_expect == XREF || PL_expect == XSTATE
7010 || PL_expect == XTERMORDORDOR)) {
7011 GV *const gv = gv_fetchpvn_flags(s, start - s,
7012 UTF ? SVf_UTF8 : 0, SVt_PVCV);
7014 s = scan_num(s, &pl_yylval);
7021 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7074 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7076 /* Some keywords can be followed by any delimiter, including ':' */
7077 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7079 /* x::* is just a word, unless x is "CORE" */
7080 if (!anydelim && *s == ':' && s[1] == ':') {
7081 if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
7086 while (d < PL_bufend && isSPACE(*d))
7087 d++; /* no comments skipped here, or s### is misparsed */
7089 /* Is this a word before a => operator? */
7090 if (*d == '=' && d[1] == '>') {
7094 = newSVOP(OP_CONST, 0,
7095 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7096 pl_yylval.opval->op_private = OPpCONST_BARE;
7100 /* Check for plugged-in keyword */
7104 char *saved_bufptr = PL_bufptr;
7106 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7108 if (result == KEYWORD_PLUGIN_DECLINE) {
7109 /* not a plugged-in keyword */
7110 PL_bufptr = saved_bufptr;
7111 } else if (result == KEYWORD_PLUGIN_STMT) {
7112 pl_yylval.opval = o;
7114 if (!PL_nexttoke) PL_expect = XSTATE;
7115 return REPORT(PLUGSTMT);
7116 } else if (result == KEYWORD_PLUGIN_EXPR) {
7117 pl_yylval.opval = o;
7119 if (!PL_nexttoke) PL_expect = XOPERATOR;
7120 return REPORT(PLUGEXPR);
7122 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7127 /* Check for built-in keyword */
7128 tmp = keyword(PL_tokenbuf, len, 0);
7130 /* Is this a label? */
7131 if (!anydelim && PL_expect == XSTATE
7132 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7134 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7135 pl_yylval.pval[len] = '\0';
7136 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7141 /* Check for lexical sub */
7142 if (PL_expect != XOPERATOR) {
7143 char tmpbuf[sizeof PL_tokenbuf + 1];
7145 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7146 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7147 if (off != NOT_IN_PAD) {
7148 assert(off); /* we assume this is boolean-true below */
7149 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7150 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7151 HEK * const stashname = HvNAME_HEK(stash);
7152 sv = newSVhek(stashname);
7153 sv_catpvs(sv, "::");
7154 sv_catpvn_flags(sv, PL_tokenbuf, len,
7155 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7156 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7166 rv2cv_op = newOP(OP_PADANY, 0);
7167 rv2cv_op->op_targ = off;
7168 cv = find_lexical_cv(off);
7176 if (tmp < 0) { /* second-class keyword? */
7177 GV *ogv = NULL; /* override (winner) */
7178 GV *hgv = NULL; /* hidden (loser) */
7179 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7181 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7182 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7184 && (cv = GvCVu(gv)))
7186 if (GvIMPORTED_CV(gv))
7188 else if (! CvMETHOD(cv))
7192 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7195 && (isGV_with_GP(gv)
7196 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7197 : SvPCS_IMPORTED(gv)
7198 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7206 tmp = 0; /* overridden by import or by GLOBAL */
7209 && -tmp==KEY_lock /* XXX generalizable kludge */
7212 tmp = 0; /* any sub overrides "weak" keyword */
7214 else { /* no override */
7216 if (tmp == KEY_dump) {
7217 Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED),
7218 "dump() better written as CORE::dump(). "
7219 "dump() will no longer be available "
7224 if (hgv && tmp != KEY_x) /* never ambiguous */
7225 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7226 "Ambiguous call resolved as CORE::%s(), "
7227 "qualify as such or use &",
7232 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7233 && (!anydelim || *s != '#')) {
7234 /* no override, and not s### either; skipspace is safe here
7235 * check for => on following line */
7237 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7238 STRLEN soff = s - SvPVX(PL_linestr);
7240 arrow = *s == '=' && s[1] == '>';
7241 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7242 s = SvPVX(PL_linestr) + soff;
7250 /* Trade off - by using this evil construction we can pull the
7251 variable gv into the block labelled keylookup. If not, then
7252 we have to give it function scope so that the goto from the
7253 earlier ':' case doesn't bypass the initialisation. */
7254 just_a_word_zero_gv:
7264 default: /* not a keyword */
7267 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7269 bool no_op_error = FALSE;
7271 if (PL_expect == XOPERATOR) {
7272 if (PL_bufptr == PL_linestart) {
7273 CopLINE_dec(PL_curcop);
7274 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7275 CopLINE_inc(PL_curcop);
7278 /* We want to call no_op with s pointing after the
7279 bareword, so defer it. But we want it to come
7280 before the Bad name croak. */
7284 /* Get the rest if it looks like a package qualifier */
7286 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7288 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7291 no_op("Bareword",s);
7292 no_op_error = FALSE;
7295 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7296 UTF8fARG(UTF, len, PL_tokenbuf),
7297 *s == '\'' ? "'" : "::");
7303 no_op("Bareword",s);
7305 /* See if the name is "Foo::",
7306 in which case Foo is a bareword
7307 (and a package name). */
7310 && PL_tokenbuf[len - 2] == ':'
7311 && PL_tokenbuf[len - 1] == ':')
7313 if (ckWARN(WARN_BAREWORD)
7314 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7315 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7316 "Bareword \"%" UTF8f
7317 "\" refers to nonexistent package",
7318 UTF8fARG(UTF, len, PL_tokenbuf));
7320 PL_tokenbuf[len] = '\0';
7329 /* if we saw a global override before, get the right name */
7332 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7335 SV * const tmp_sv = sv;
7336 sv = newSVpvs("CORE::GLOBAL::");
7337 sv_catsv(sv, tmp_sv);
7338 SvREFCNT_dec(tmp_sv);
7342 /* Presume this is going to be a bareword of some sort. */
7344 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7345 pl_yylval.opval->op_private = OPpCONST_BARE;
7347 /* And if "Foo::", then that's what it certainly is. */
7353 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7354 const_op->op_private = OPpCONST_BARE;
7356 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7360 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7363 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7366 /* Use this var to track whether intuit_method has been
7367 called. intuit_method returns 0 or > 255. */
7370 /* See if it's the indirect object for a list operator. */
7373 && PL_oldoldbufptr < PL_bufptr
7374 && (PL_oldoldbufptr == PL_last_lop
7375 || PL_oldoldbufptr == PL_last_uni)
7376 && /* NO SKIPSPACE BEFORE HERE! */
7378 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7381 bool immediate_paren = *s == '(';
7384 /* (Now we can afford to cross potential line boundary.) */
7387 /* intuit_method() can indirectly call lex_next_chunk(),
7390 s_off = s - SvPVX(PL_linestr);
7391 /* Two barewords in a row may indicate method call. */
7392 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7394 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7396 /* the code at method: doesn't use s */
7399 s = SvPVX(PL_linestr) + s_off;
7401 /* If not a declared subroutine, it's an indirect object. */
7402 /* (But it's an indir obj regardless for sort.) */
7403 /* Also, if "_" follows a filetest operator, it's a bareword */
7406 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7408 && (PL_last_lop_op != OP_MAPSTART
7409 && PL_last_lop_op != OP_GREPSTART))))
7410 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7411 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7415 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7420 PL_expect = XOPERATOR;
7423 /* Is this a word before a => operator? */
7424 if (*s == '=' && s[1] == '>' && !pkgname) {
7427 if (gvp || (lex && !off)) {
7428 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7429 /* This is our own scalar, created a few lines
7430 above, so this is safe. */
7432 sv_setpv(sv, PL_tokenbuf);
7433 if (UTF && !IN_BYTES
7434 && is_utf8_string((U8*)PL_tokenbuf, len))
7441 /* If followed by a paren, it's certainly a subroutine. */
7446 while (SPACE_OR_TAB(*d))
7448 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7453 NEXTVAL_NEXTTOKE.opval =
7454 off ? rv2cv_op : pl_yylval.opval;
7456 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7457 else op_free(rv2cv_op), force_next(BAREWORD);
7462 /* If followed by var or block, call it a method (unless sub) */
7464 if ((*s == '$' || *s == '{') && !cv) {
7466 PL_last_lop = PL_oldbufptr;
7467 PL_last_lop_op = OP_METHOD;
7468 if (!PL_lex_allbrackets
7469 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7471 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7473 PL_expect = XBLOCKTERM;
7475 return REPORT(METHOD);
7478 /* If followed by a bareword, see if it looks like indir obj. */
7482 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7483 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7487 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7489 sv_setpvn(sv, PL_tokenbuf, len);
7490 if (UTF && !IN_BYTES
7491 && is_utf8_string((U8*)PL_tokenbuf, len))
7493 else SvUTF8_off(sv);
7496 if (tmp == METHOD && !PL_lex_allbrackets
7497 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7499 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7504 /* Not a method, so call it a subroutine (if defined) */
7507 /* Check for a constant sub */
7508 if ((sv = cv_const_sv_or_av(cv))) {
7511 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7512 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7513 if (SvTYPE(sv) == SVt_PVAV)
7514 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7517 pl_yylval.opval->op_private = 0;
7518 pl_yylval.opval->op_folded = 1;
7519 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7524 op_free(pl_yylval.opval);
7526 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7527 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7528 PL_last_lop = PL_oldbufptr;
7529 PL_last_lop_op = OP_ENTERSUB;
7530 /* Is there a prototype? */
7534 STRLEN protolen = CvPROTOLEN(cv);
7535 const char *proto = CvPROTO(cv);
7537 proto = S_strip_spaces(aTHX_ proto, &protolen);
7540 if ((optional = *proto == ';'))
7543 while (*proto == ';');
7547 *proto == '$' || *proto == '_'
7548 || *proto == '*' || *proto == '+'
7553 *proto == '\\' && proto[1] && proto[2] == '\0'
7556 UNIPROTO(UNIOPSUB,optional);
7557 if (*proto == '\\' && proto[1] == '[') {
7558 const char *p = proto + 2;
7559 while(*p && *p != ']')
7561 if(*p == ']' && !p[1])
7562 UNIPROTO(UNIOPSUB,optional);
7564 if (*proto == '&' && *s == '{') {
7566 sv_setpvs(PL_subname, "__ANON__");
7568 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7569 if (!PL_lex_allbrackets
7570 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7572 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7577 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7579 force_next(off ? PRIVATEREF : BAREWORD);
7580 if (!PL_lex_allbrackets
7581 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7583 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7588 /* Call it a bare word */
7590 if (PL_hints & HINT_STRICT_SUBS)
7591 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7594 /* after "print" and similar functions (corresponding to
7595 * "F? L" in opcode.pl), whatever wasn't already parsed as
7596 * a filehandle should be subject to "strict subs".
7597 * Likewise for the optional indirect-object argument to system
7598 * or exec, which can't be a bareword */
7599 if ((PL_last_lop_op == OP_PRINT
7600 || PL_last_lop_op == OP_PRTF
7601 || PL_last_lop_op == OP_SAY
7602 || PL_last_lop_op == OP_SYSTEM
7603 || PL_last_lop_op == OP_EXEC)
7604 && (PL_hints & HINT_STRICT_SUBS))
7605 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7606 if (lastchar != '-') {
7607 if (ckWARN(WARN_RESERVED)) {
7611 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7613 /* PL_warn_reserved is constant */
7614 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7615 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7617 GCC_DIAG_RESTORE_STMT;
7625 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7626 && saw_infix_sigil) {
7627 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7628 "Operator or semicolon missing before %c%" UTF8f,
7630 UTF8fARG(UTF, strlen(PL_tokenbuf),
7632 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7633 "Ambiguous use of %c resolved as operator %c",
7634 lastchar, lastchar);
7641 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7646 newSVOP(OP_CONST, 0,
7647 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7650 case KEY___PACKAGE__:
7652 newSVOP(OP_CONST, 0,
7654 ? newSVhek(HvNAME_HEK(PL_curstash))
7661 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7662 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7665 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7667 gv_init(gv,stash,"DATA",4,0);
7670 GvIOp(gv) = newIO();
7671 IoIFP(GvIOp(gv)) = PL_rsfp;
7672 /* Mark this internal pseudo-handle as clean */
7673 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7674 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7675 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7677 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7678 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7679 /* if the script was opened in binmode, we need to revert
7680 * it to text mode for compatibility; but only iff it has CRs
7681 * XXX this is a questionable hack at best. */
7682 if (PL_bufend-PL_bufptr > 2
7683 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7686 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7687 loc = PerlIO_tell(PL_rsfp);
7688 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7691 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7693 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7694 #endif /* NETWARE */
7696 PerlIO_seek(PL_rsfp, loc, 0);
7700 #ifdef PERLIO_LAYERS
7703 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7712 FUN0OP(CvCLONE(PL_compcv)
7713 ? newOP(OP_RUNCV, 0)
7714 : newPVOP(OP_RUNCV,0,NULL));
7723 if (PL_expect == XSTATE) {
7734 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7735 if ((*s == ':' && s[1] == ':')
7736 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7740 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7744 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7745 UTF8fARG(UTF, len, PL_tokenbuf));
7748 else if (tmp == KEY_require || tmp == KEY_do
7750 /* that's a way to remember we saw "CORE::" */
7762 LOP(OP_ACCEPT,XTERM);
7765 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7770 LOP(OP_ATAN2,XTERM);
7776 LOP(OP_BINMODE,XTERM);
7779 LOP(OP_BLESS,XTERM);
7788 /* We have to disambiguate the two senses of
7789 "continue". If the next token is a '{' then
7790 treat it as the start of a continue block;
7791 otherwise treat it as a control operator.
7801 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7811 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7820 if (!PL_cryptseen) {
7821 PL_cryptseen = TRUE;
7825 LOP(OP_CRYPT,XTERM);
7828 LOP(OP_CHMOD,XTERM);
7831 LOP(OP_CHOWN,XTERM);
7834 LOP(OP_CONNECT,XTERM);
7854 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7856 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
7857 && !keyword(PL_tokenbuf + 1, len, 0)) {
7858 SSize_t off = s-SvPVX(PL_linestr);
7860 s = SvPVX(PL_linestr)+off;
7862 force_ident_maybe_lex('&');
7867 if (orig_keyword == KEY_do) {
7876 PL_hints |= HINT_BLOCK_SCOPE;
7886 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7887 STR_WITH_LEN("NDBM_File::"),
7888 STR_WITH_LEN("DB_File::"),
7889 STR_WITH_LEN("GDBM_File::"),
7890 STR_WITH_LEN("SDBM_File::"),
7891 STR_WITH_LEN("ODBM_File::"),
7893 LOP(OP_DBMOPEN,XTERM);
7905 pl_yylval.ival = CopLINE(PL_curcop);
7909 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7921 if (*s == '{') { /* block eval */
7922 PL_expect = XTERMBLOCK;
7923 UNIBRACK(OP_ENTERTRY);
7925 else { /* string eval */
7927 UNIBRACK(OP_ENTEREVAL);
7932 UNIBRACK(-OP_ENTEREVAL);
7946 case KEY_endhostent:
7952 case KEY_endservent:
7955 case KEY_endprotoent:
7966 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7968 pl_yylval.ival = CopLINE(PL_curcop);
7970 if ( PL_expect == XSTATE
7971 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
7974 SSize_t s_off = s - SvPVX(PL_linestr);
7976 if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
7977 && isSPACE(*(p + 2)))
7981 else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
7982 && isSPACE(*(p + 3)))
7988 /* skip optional package name, as in "for my abc $x (..)" */
7989 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
7990 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7993 if (*p != '$' && *p != '\\')
7994 Perl_croak(aTHX_ "Missing $ on loop variable");
7996 /* The buffer may have been reallocated, update s */
7997 s = SvPVX(PL_linestr) + s_off;
8002 LOP(OP_FORMLINE,XTERM);
8011 LOP(OP_FCNTL,XTERM);
8017 LOP(OP_FLOCK,XTERM);
8020 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8025 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8030 LOP(OP_GREPSTART, XREF);
8047 case KEY_getpriority:
8048 LOP(OP_GETPRIORITY,XTERM);
8050 case KEY_getprotobyname:
8053 case KEY_getprotobynumber:
8054 LOP(OP_GPBYNUMBER,XTERM);
8056 case KEY_getprotoent:
8068 case KEY_getpeername:
8069 UNI(OP_GETPEERNAME);
8071 case KEY_gethostbyname:
8074 case KEY_gethostbyaddr:
8075 LOP(OP_GHBYADDR,XTERM);
8077 case KEY_gethostent:
8080 case KEY_getnetbyname:
8083 case KEY_getnetbyaddr:
8084 LOP(OP_GNBYADDR,XTERM);
8089 case KEY_getservbyname:
8090 LOP(OP_GSBYNAME,XTERM);
8092 case KEY_getservbyport:
8093 LOP(OP_GSBYPORT,XTERM);
8095 case KEY_getservent:
8098 case KEY_getsockname:
8099 UNI(OP_GETSOCKNAME);
8101 case KEY_getsockopt:
8102 LOP(OP_GSOCKOPT,XTERM);
8117 pl_yylval.ival = CopLINE(PL_curcop);
8118 Perl_ck_warner_d(aTHX_
8119 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8120 "given is experimental");
8125 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8133 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8135 pl_yylval.ival = CopLINE(PL_curcop);
8139 LOP(OP_INDEX,XTERM);
8145 LOP(OP_IOCTL,XTERM);
8172 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8177 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8191 LOP(OP_LISTEN,XTERM);
8200 s = scan_pat(s,OP_MATCH);
8201 TERM(sublex_start());
8204 LOP(OP_MAPSTART, XREF);
8207 LOP(OP_MKDIR,XTERM);
8210 LOP(OP_MSGCTL,XTERM);
8213 LOP(OP_MSGGET,XTERM);
8216 LOP(OP_MSGRCV,XTERM);
8219 LOP(OP_MSGSND,XTERM);
8226 yyerror(Perl_form(aTHX_
8227 "Can't redeclare \"%s\" in \"%s\"",
8228 tmp == KEY_my ? "my" :
8229 tmp == KEY_state ? "state" : "our",
8230 PL_in_my == KEY_my ? "my" :
8231 PL_in_my == KEY_state ? "state" : "our"));
8233 PL_in_my = (U16)tmp;
8235 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8236 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8237 if (memEQs(PL_tokenbuf, len, "sub"))
8239 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8240 if (!PL_in_my_stash) {
8244 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8245 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8246 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8249 else if (*s == '\\') {
8250 if (!FEATURE_MYREF_IS_ENABLED)
8251 Perl_croak(aTHX_ "The experimental declared_refs "
8252 "feature is not enabled");
8253 Perl_ck_warner_d(aTHX_
8254 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8255 "Declaring references is experimental");
8263 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8268 s = tokenize_use(0, s);
8272 if (*s == '(' || (s = skipspace(s), *s == '('))
8275 if (!PL_lex_allbrackets
8276 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8278 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8285 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8287 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8289 for (t=d; isSPACE(*t);)
8291 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8293 && !(t[0] == '=' && t[1] == '>')
8294 && !(t[0] == ':' && t[1] == ':')
8295 && !keyword(s, d-s, 0)
8297 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8298 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8299 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8305 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8307 pl_yylval.ival = OP_OR;
8317 LOP(OP_OPEN_DIR,XTERM);
8320 checkcomma(s,PL_tokenbuf,"filehandle");
8324 checkcomma(s,PL_tokenbuf,"filehandle");
8343 s = force_word(s,BAREWORD,FALSE,TRUE);
8345 s = force_strict_version(s);
8349 LOP(OP_PIPE_OP,XTERM);
8352 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8354 missingterm(NULL, 0);
8355 COPLINE_SET_FROM_MULTI_END;
8356 pl_yylval.ival = OP_CONST;
8357 TERM(sublex_start());
8364 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8366 missingterm(NULL, 0);
8367 COPLINE_SET_FROM_MULTI_END;
8368 PL_expect = XOPERATOR;
8369 if (SvCUR(PL_lex_stuff)) {
8370 int warned_comma = !ckWARN(WARN_QW);
8371 int warned_comment = warned_comma;
8372 d = SvPV_force(PL_lex_stuff, len);
8374 for (; isSPACE(*d) && len; --len, ++d)
8379 if (!warned_comma || !warned_comment) {
8380 for (; !isSPACE(*d) && len; --len, ++d) {
8381 if (!warned_comma && *d == ',') {
8382 Perl_warner(aTHX_ packWARN(WARN_QW),
8383 "Possible attempt to separate words with commas");
8386 else if (!warned_comment && *d == '#') {
8387 Perl_warner(aTHX_ packWARN(WARN_QW),
8388 "Possible attempt to put comments in qw() list");
8394 for (; !isSPACE(*d) && len; --len, ++d)
8397 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8398 words = op_append_elem(OP_LIST, words,
8399 newSVOP(OP_CONST, 0, tokeq(sv)));
8404 words = newNULLLIST();
8405 SvREFCNT_dec_NN(PL_lex_stuff);
8406 PL_lex_stuff = NULL;
8407 PL_expect = XOPERATOR;
8408 pl_yylval.opval = sawparens(words);
8413 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8415 missingterm(NULL, 0);
8416 pl_yylval.ival = OP_STRINGIFY;
8417 if (SvIVX(PL_lex_stuff) == '\'')
8418 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8419 TERM(sublex_start());
8422 s = scan_pat(s,OP_QR);
8423 TERM(sublex_start());
8426 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8428 missingterm(NULL, 0);
8429 pl_yylval.ival = OP_BACKTICK;
8430 TERM(sublex_start());
8438 s = force_version(s, FALSE);
8440 else if (*s != 'v' || !isDIGIT(s[1])
8441 || (s = force_version(s, TRUE), *s == 'v'))
8443 *PL_tokenbuf = '\0';
8444 s = force_word(s,BAREWORD,TRUE,TRUE);
8445 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8446 PL_tokenbuf + sizeof(PL_tokenbuf),
8449 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8450 GV_ADD | (UTF ? SVf_UTF8 : 0));
8453 yyerror("<> at require-statement should be quotes");
8455 if (orig_keyword == KEY_require) {
8461 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8463 PL_last_uni = PL_oldbufptr;
8464 PL_last_lop_op = OP_REQUIRE;
8466 return REPORT( (int)REQUIRE );
8475 LOP(OP_RENAME,XTERM);
8484 LOP(OP_RINDEX,XTERM);
8493 UNIDOR(OP_READLINE);
8496 UNIDOR(OP_BACKTICK);
8505 LOP(OP_REVERSE,XTERM);
8508 UNIDOR(OP_READLINK);
8515 if (pl_yylval.opval)
8516 TERM(sublex_start());
8518 TOKEN(1); /* force error */
8521 checkcomma(s,PL_tokenbuf,"filehandle");
8531 LOP(OP_SELECT,XTERM);
8537 LOP(OP_SEMCTL,XTERM);
8540 LOP(OP_SEMGET,XTERM);
8543 LOP(OP_SEMOP,XTERM);
8549 LOP(OP_SETPGRP,XTERM);
8551 case KEY_setpriority:
8552 LOP(OP_SETPRIORITY,XTERM);
8554 case KEY_sethostent:
8560 case KEY_setservent:
8563 case KEY_setprotoent:
8573 LOP(OP_SEEKDIR,XTERM);
8575 case KEY_setsockopt:
8576 LOP(OP_SSOCKOPT,XTERM);
8582 LOP(OP_SHMCTL,XTERM);
8585 LOP(OP_SHMGET,XTERM);
8588 LOP(OP_SHMREAD,XTERM);
8591 LOP(OP_SHMWRITE,XTERM);
8594 LOP(OP_SHUTDOWN,XTERM);
8603 LOP(OP_SOCKET,XTERM);
8605 case KEY_socketpair:
8606 LOP(OP_SOCKPAIR,XTERM);
8609 checkcomma(s,PL_tokenbuf,"subroutine name");
8612 s = force_word(s,BAREWORD,TRUE,TRUE);
8616 LOP(OP_SPLIT,XTERM);
8619 LOP(OP_SPRINTF,XTERM);
8622 LOP(OP_SPLICE,XTERM);
8637 LOP(OP_SUBSTR,XTERM);
8643 char * const tmpbuf = PL_tokenbuf + 1;
8644 expectation attrful;
8645 bool have_name, have_proto;
8646 const int key = tmp;
8647 SV *format_name = NULL;
8649 SSize_t off = s-SvPVX(PL_linestr);
8651 d = SvPVX(PL_linestr)+off;
8653 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8655 || (*s == ':' && s[1] == ':'))
8659 attrful = XATTRBLOCK;
8660 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8662 if (key == KEY_format)
8663 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8665 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8667 PL_tokenbuf, len + 1, 0
8669 sv_setpvn(PL_subname, tmpbuf, len);
8671 sv_setsv(PL_subname,PL_curstname);
8672 sv_catpvs(PL_subname,"::");
8673 sv_catpvn(PL_subname,tmpbuf,len);
8675 if (SvUTF8(PL_linestr))
8676 SvUTF8_on(PL_subname);
8683 if (key == KEY_my || key == KEY_our || key==KEY_state)
8686 /* diag_listed_as: Missing name in "%s sub" */
8688 "Missing name in \"%s\"", PL_bufptr);
8690 PL_expect = XTERMBLOCK;
8691 attrful = XATTRTERM;
8692 sv_setpvs(PL_subname,"?");
8696 if (key == KEY_format) {
8698 NEXTVAL_NEXTTOKE.opval
8699 = newSVOP(OP_CONST,0, format_name);
8700 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8701 force_next(BAREWORD);
8706 /* Look for a prototype */
8707 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8708 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8709 COPLINE_SET_FROM_MULTI_END;
8711 Perl_croak(aTHX_ "Prototype not terminated");
8712 (void)validate_proto(PL_subname, PL_lex_stuff,
8713 ckWARN(WARN_ILLEGALPROTO), 0);
8721 if (*s == ':' && s[1] != ':')
8722 PL_expect = attrful;
8723 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8724 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8725 key == KEY_DESTROY || key == KEY_BEGIN ||
8726 key == KEY_UNITCHECK || key == KEY_CHECK ||
8727 key == KEY_INIT || key == KEY_END ||
8728 key == KEY_my || key == KEY_state ||
8731 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8732 else if (*s != ';' && *s != '}')
8733 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8737 NEXTVAL_NEXTTOKE.opval =
8738 newSVOP(OP_CONST, 0, PL_lex_stuff);
8739 PL_lex_stuff = NULL;
8744 sv_setpvs(PL_subname, "__ANON__");
8746 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8749 force_ident_maybe_lex('&');
8754 LOP(OP_SYSTEM,XREF);
8757 LOP(OP_SYMLINK,XTERM);
8760 LOP(OP_SYSCALL,XTERM);
8763 LOP(OP_SYSOPEN,XTERM);
8766 LOP(OP_SYSSEEK,XTERM);
8769 LOP(OP_SYSREAD,XTERM);
8772 LOP(OP_SYSWRITE,XTERM);
8777 TERM(sublex_start());
8798 LOP(OP_TRUNCATE,XTERM);
8810 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8812 pl_yylval.ival = CopLINE(PL_curcop);
8816 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8818 pl_yylval.ival = CopLINE(PL_curcop);
8822 LOP(OP_UNLINK,XTERM);
8828 LOP(OP_UNPACK,XTERM);
8831 LOP(OP_UTIME,XTERM);
8837 LOP(OP_UNSHIFT,XTERM);
8840 s = tokenize_use(1, s);
8850 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8852 pl_yylval.ival = CopLINE(PL_curcop);
8853 Perl_ck_warner_d(aTHX_
8854 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8855 "when is experimental");
8859 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8861 pl_yylval.ival = CopLINE(PL_curcop);
8865 PL_hints |= HINT_BLOCK_SCOPE;
8872 LOP(OP_WAITPID,XTERM);
8878 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8879 * we use the same number on EBCDIC */
8880 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8884 if (PL_expect == XOPERATOR) {
8885 if (*s == '=' && !PL_lex_allbrackets
8886 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8896 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8898 pl_yylval.ival = OP_XOR;
8907 Looks up an identifier in the pad or in a package
8909 is_sig indicates that this is a subroutine signature variable
8910 rather than a plain pad var.
8913 PRIVATEREF if this is a lexical name.
8914 BAREWORD if this belongs to a package.
8917 if we're in a my declaration
8918 croak if they tried to say my($foo::bar)
8919 build the ops for a my() declaration
8920 if it's an access to a my() variable
8921 build ops for access to a my() variable
8922 if in a dq string, and they've said @foo and we can't find @foo
8924 build ops for a bareword
8928 S_pending_ident(pTHX)
8931 const char pit = (char)pl_yylval.ival;
8932 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8933 /* All routes through this function want to know if there is a colon. */
8934 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8936 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8937 "### Pending identifier '%s'\n", PL_tokenbuf); });
8938 assert(tokenbuf_len >= 2);
8940 /* if we're in a my(), we can't allow dynamics here.
8941 $foo'bar has already been turned into $foo::bar, so
8942 just check for colons.
8944 if it's a legal name, the OP is a PADANY.
8947 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8949 /* diag_listed_as: No package name allowed for variable %s
8951 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8952 "%se %s in \"our\"",
8953 *PL_tokenbuf=='&' ?"subroutin":"variabl",
8954 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8955 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8960 /* "my" variable %s can't be in a package */
8961 /* PL_no_myglob is constant */
8962 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
8963 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8964 PL_in_my == KEY_my ? "my" : "state",
8965 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8967 UTF ? SVf_UTF8 : 0);
8968 GCC_DIAG_RESTORE_STMT;
8971 if (PL_in_my == KEY_sigvar) {
8972 /* A signature 'padop' needs in addition, an op_first to
8973 * point to a child sigdefelem, and an extra field to hold
8974 * the signature index. We can achieve both by using an
8975 * UNOP_AUX and (ab)using the op_aux field to hold the
8976 * index. If we ever need more fields, use a real malloced
8977 * aux strut instead.
8979 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
8980 INT2PTR(UNOP_AUX_item *,
8981 (PL_parser->sig_elems)));
8982 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
8983 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
8987 o = newOP(OP_PADANY, 0);
8988 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8989 UTF ? SVf_UTF8 : 0);
8990 if (PL_in_my == KEY_sigvar)
8993 pl_yylval.opval = o;
8999 build the ops for accesses to a my() variable.
9004 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9006 if (tmp != NOT_IN_PAD) {
9007 /* might be an "our" variable" */
9008 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9009 /* build ops for a bareword */
9010 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9011 HEK * const stashname = HvNAME_HEK(stash);
9012 SV * const sym = newSVhek(stashname);
9013 sv_catpvs(sym, "::");
9014 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9015 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9016 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9020 ((PL_tokenbuf[0] == '$') ? SVt_PV
9021 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9026 pl_yylval.opval = newOP(OP_PADANY, 0);
9027 pl_yylval.opval->op_targ = tmp;
9033 Whine if they've said @foo or @foo{key} in a doublequoted string,
9034 and @foo (or %foo) isn't a variable we can find in the symbol
9037 if (ckWARN(WARN_AMBIGUOUS)
9039 && PL_lex_state != LEX_NORMAL
9040 && !PL_lex_brackets)
9042 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9043 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9045 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9048 /* Downgraded from fatal to warning 20000522 mjd */
9049 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9050 "Possible unintended interpolation of %" UTF8f
9052 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9056 /* build ops for a bareword */
9057 pl_yylval.opval = newSVOP(OP_CONST, 0,
9058 newSVpvn_flags(PL_tokenbuf + 1,
9060 UTF ? SVf_UTF8 : 0 ));
9061 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9063 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9064 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9065 | ( UTF ? SVf_UTF8 : 0 ),
9066 ((PL_tokenbuf[0] == '$') ? SVt_PV
9067 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9073 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9075 PERL_ARGS_ASSERT_CHECKCOMMA;
9077 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9078 if (ckWARN(WARN_SYNTAX)) {
9081 for (w = s+2; *w && level; w++) {
9089 /* the list of chars below is for end of statements or
9090 * block / parens, boolean operators (&&, ||, //) and branch
9091 * constructs (or, and, if, until, unless, while, err, for).
9092 * Not a very solid hack... */
9093 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9094 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9095 "%s (...) interpreted as function",name);
9098 while (s < PL_bufend && isSPACE(*s))
9102 while (s < PL_bufend && isSPACE(*s))
9104 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9105 const char * const w = s;
9106 s += UTF ? UTF8SKIP(s) : 1;
9107 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9108 s += UTF ? UTF8SKIP(s) : 1;
9109 while (s < PL_bufend && isSPACE(*s))
9113 if (keyword(w, s - w, 0))
9116 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9117 if (gv && GvCVu(gv))
9122 Copy(w, tmpbuf+1, s - w, char);
9124 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9125 if (off != NOT_IN_PAD) return;
9127 Perl_croak(aTHX_ "No comma allowed after %s", what);
9132 /* S_new_constant(): do any overload::constant lookup.
9134 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9135 Best used as sv=new_constant(..., sv, ...).
9136 If s, pv are NULL, calls subroutine with one argument,
9137 and <type> is used with error messages only.
9138 <type> is assumed to be well formed UTF-8 */
9141 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9142 SV *sv, SV *pv, const char *type, STRLEN typelen)
9145 HV * table = GvHV(PL_hintgv); /* ^H */
9150 const char *why1 = "", *why2 = "", *why3 = "";
9152 PERL_ARGS_ASSERT_NEW_CONSTANT;
9153 /* We assume that this is true: */
9154 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9157 /* charnames doesn't work well if there have been errors found */
9158 if (PL_error_count > 0 && *key == 'c')
9160 SvREFCNT_dec_NN(sv);
9161 return &PL_sv_undef;
9164 sv_2mortal(sv); /* Parent created it permanently */
9166 || ! (PL_hints & HINT_LOCALIZE_HH)
9167 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9172 /* Here haven't found what we're looking for. If it is charnames,
9173 * perhaps it needs to be loaded. Try doing that before giving up */
9175 Perl_load_module(aTHX_
9177 newSVpvs("_charnames"),
9178 /* version parameter; no need to specify it, as if
9179 * we get too early a version, will fail anyway,
9180 * not being able to find '_charnames' */
9185 assert(sp == PL_stack_sp);
9186 table = GvHV(PL_hintgv);
9188 && (PL_hints & HINT_LOCALIZE_HH)
9189 && (cvp = hv_fetch(table, key, keylen, FALSE))
9195 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9196 msg = Perl_form(aTHX_
9197 "Constant(%.*s) unknown",
9198 (int)(type ? typelen : len),
9204 why3 = "} is not defined";
9207 msg = Perl_form(aTHX_
9208 /* The +3 is for '\N{'; -4 for that, plus '}' */
9209 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9213 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9214 (int)(type ? typelen : len),
9215 (type ? type: s), why1, why2, why3);
9218 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9219 return SvREFCNT_inc_simple_NN(sv);
9224 pv = newSVpvn_flags(s, len, SVs_TEMP);
9226 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9228 typesv = &PL_sv_undef;
9230 PUSHSTACKi(PERLSI_OVERLOAD);
9242 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9246 /* Check the eval first */
9247 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9249 const char * errstr;
9250 sv_catpvs(errsv, "Propagated");
9251 errstr = SvPV_const(errsv, errlen);
9252 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9254 res = SvREFCNT_inc_simple_NN(sv);
9258 SvREFCNT_inc_simple_void_NN(res);
9267 why1 = "Call to &{$^H{";
9269 why3 = "}} did not return a defined value";
9271 (void)sv_2mortal(sv);
9278 PERL_STATIC_INLINE void
9279 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9280 bool is_utf8, bool check_dollar, bool tick_warn)
9283 const char *olds = *s;
9284 PERL_ARGS_ASSERT_PARSE_IDENT;
9286 while (*s < PL_bufend) {
9288 Perl_croak(aTHX_ "%s", ident_too_long);
9289 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9290 /* The UTF-8 case must come first, otherwise things
9291 * like c\N{COMBINING TILDE} would start failing, as the
9292 * isWORDCHAR_A case below would gobble the 'c' up.
9295 char *t = *s + UTF8SKIP(*s);
9296 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9299 if (*d + (t - *s) > e)
9300 Perl_croak(aTHX_ "%s", ident_too_long);
9301 Copy(*s, *d, t - *s, char);
9305 else if ( isWORDCHAR_A(**s) ) {
9308 } while (isWORDCHAR_A(**s) && *d < e);
9310 else if ( allow_package
9312 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9319 else if (allow_package && **s == ':' && (*s)[1] == ':'
9320 /* Disallow things like Foo::$bar. For the curious, this is
9321 * the code path that triggers the "Bad name after" warning
9322 * when looking for barewords.
9324 && !(check_dollar && (*s)[2] == '$')) {
9331 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9332 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9335 Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9338 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9339 "Old package separator used in string");
9340 if (olds[-1] == '#')
9344 if (*olds == '\'') {
9351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9352 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9353 UTF8fARG(is_utf8, d2-d, d));
9358 /* Returns a NUL terminated string, with the length of the string written to
9362 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9365 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9366 bool is_utf8 = cBOOL(UTF);
9368 PERL_ARGS_ASSERT_SCAN_WORD;
9370 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9376 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9377 * iff Unicode semantics are to be used. The legal ones are any of:
9378 * a) all ASCII characters except:
9379 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9381 * The final case currently doesn't get this far in the program, so we
9382 * don't test for it. If that were to change, it would be ok to allow it.
9383 * b) When not under Unicode rules, any upper Latin1 character
9384 * c) Otherwise, when unicode rules are used, all XIDS characters.
9386 * Because all ASCII characters have the same representation whether
9387 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9388 * '{' without knowing if is UTF-8 or not. */
9389 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9390 (isGRAPH_A(*(s)) || ((is_utf8) \
9391 ? isIDFIRST_utf8_safe(s, e) \
9393 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9396 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9398 I32 herelines = PL_parser->herelines;
9399 SSize_t bracket = -1;
9402 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9403 bool is_utf8 = cBOOL(UTF);
9404 I32 orig_copline = 0, tmp_copline = 0;
9406 PERL_ARGS_ASSERT_SCAN_IDENT;
9408 if (isSPACE(*s) || !*s)
9411 while (isDIGIT(*s)) {
9413 Perl_croak(aTHX_ "%s", ident_too_long);
9417 else { /* See if it is a "normal" identifier */
9418 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9423 /* Either a digit variable, or parse_ident() found an identifier
9424 (anything valid as a bareword), so job done and return. */
9425 if (PL_lex_state != LEX_NORMAL)
9426 PL_lex_state = LEX_INTERPENDMAYBE;
9430 /* Here, it is not a run-of-the-mill identifier name */
9432 if (*s == '$' && s[1]
9433 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9434 || isDIGIT_A((U8)s[1])
9437 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9439 /* Dereferencing a value in a scalar variable.
9440 The alternatives are different syntaxes for a scalar variable.
9441 Using ' as a leading package separator isn't allowed. :: is. */
9444 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9446 bracket = s - SvPVX(PL_linestr);
9448 orig_copline = CopLINE(PL_curcop);
9449 if (s < PL_bufend && isSPACE(*s)) {
9453 if ((s <= PL_bufend - (is_utf8)
9456 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9459 const STRLEN skip = UTF8SKIP(s);
9462 for ( i = 0; i < skip; i++ )
9470 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9471 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9475 /* Warn about ambiguous code after unary operators if {...} notation isn't
9476 used. There's no difference in ambiguity; it's merely a heuristic
9477 about when not to warn. */
9478 else if (ck_uni && bracket == -1)
9480 if (bracket != -1) {
9483 /* If we were processing {...} notation then... */
9484 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9485 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9488 /* note we have to check for a normal identifier first,
9489 * as it handles utf8 symbols, and only after that has
9490 * been ruled out can we look at the caret words */
9491 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9492 /* if it starts as a valid identifier, assume that it is one.
9493 (the later check for } being at the expected point will trap
9494 cases where this doesn't pan out.) */
9495 d += is_utf8 ? UTF8SKIP(d) : 1;
9496 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
9499 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9501 while (isWORDCHAR(*s) && d < e) {
9505 Perl_croak(aTHX_ "%s", ident_too_long);
9508 tmp_copline = CopLINE(PL_curcop);
9509 if (s < PL_bufend && isSPACE(*s)) {
9512 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9513 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9514 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9515 const char * const brack =
9517 ((*s == '[') ? "[...]" : "{...}");
9518 orig_copline = CopLINE(PL_curcop);
9519 CopLINE_set(PL_curcop, tmp_copline);
9520 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9521 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9522 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9523 funny, dest, brack, funny, dest, brack);
9524 CopLINE_set(PL_curcop, orig_copline);
9527 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9528 PL_lex_allbrackets++;
9534 tmp_copline = CopLINE(PL_curcop);
9535 if ((skip = s < PL_bufend && isSPACE(*s))) {
9536 /* Avoid incrementing line numbers or resetting PL_linestart,
9537 in case we have to back up. */
9538 STRLEN s_off = s - SvPVX(PL_linestr);
9540 s = SvPVX(PL_linestr) + s_off;
9545 /* Expect to find a closing } after consuming any trailing whitespace.
9548 /* Now increment line numbers if applicable. */
9552 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9553 PL_lex_state = LEX_INTERPEND;
9556 if (PL_lex_state == LEX_NORMAL) {
9557 if (ckWARN(WARN_AMBIGUOUS)
9558 && (keyword(dest, d - dest, 0)
9559 || get_cvn_flags(dest, d - dest, is_utf8
9563 SV *tmp = newSVpvn_flags( dest, d - dest,
9564 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9567 orig_copline = CopLINE(PL_curcop);
9568 CopLINE_set(PL_curcop, tmp_copline);
9569 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9570 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9571 funny, SVfARG(tmp), funny, SVfARG(tmp));
9572 CopLINE_set(PL_curcop, orig_copline);
9577 /* Didn't find the closing } at the point we expected, so restore
9578 state such that the next thing to process is the opening { and */
9579 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9580 CopLINE_set(PL_curcop, orig_copline);
9581 PL_parser->herelines = herelines;
9585 else if ( PL_lex_state == LEX_INTERPNORMAL
9587 && !intuit_more(s, PL_bufend))
9588 PL_lex_state = LEX_INTERPEND;
9593 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9595 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9596 * found in the parse starting at 's', based on the subset that are valid
9597 * in this context input to this routine in 'valid_flags'. Advances s.
9598 * Returns TRUE if the input should be treated as a valid flag, so the next
9599 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9600 * upon first call on the current regex. This routine will set it to any
9601 * charset modifier found. The caller shouldn't change it. This way,
9602 * another charset modifier encountered in the parse can be detected as an
9603 * error, as we have decided to allow only one */
9606 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9608 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9609 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9610 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9611 UTF ? SVf_UTF8 : 0);
9613 /* Pretend that it worked, so will continue processing before
9622 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9623 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9624 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9625 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9626 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9627 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9628 case LOCALE_PAT_MOD:
9630 goto multiple_charsets;
9632 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9635 case UNICODE_PAT_MOD:
9637 goto multiple_charsets;
9639 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9642 case ASCII_RESTRICT_PAT_MOD:
9644 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9648 /* Error if previous modifier wasn't an 'a', but if it was, see
9649 * if, and accept, a second occurrence (only) */
9651 || get_regex_charset(*pmfl)
9652 != REGEX_ASCII_RESTRICTED_CHARSET)
9654 goto multiple_charsets;
9656 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9660 case DEPENDS_PAT_MOD:
9662 goto multiple_charsets;
9664 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9673 if (*charset != c) {
9674 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9676 else if (c == 'a') {
9677 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9678 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9681 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9684 /* Pretend that it worked, so will continue processing before dieing */
9690 S_scan_pat(pTHX_ char *start, I32 type)
9694 const char * const valid_flags =
9695 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9696 char charset = '\0'; /* character set modifier */
9697 unsigned int x_mod_count = 0;
9699 PERL_ARGS_ASSERT_SCAN_PAT;
9701 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9703 Perl_croak(aTHX_ "Search pattern not terminated");
9705 pm = (PMOP*)newPMOP(type, 0);
9706 if (PL_multi_open == '?') {
9707 /* This is the only point in the code that sets PMf_ONCE: */
9708 pm->op_pmflags |= PMf_ONCE;
9710 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9711 allows us to restrict the list needed by reset to just the ??
9713 assert(type != OP_TRANS);
9715 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9718 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9721 elements = mg->mg_len / sizeof(PMOP**);
9722 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9723 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9724 mg->mg_len = elements * sizeof(PMOP**);
9725 PmopSTASH_set(pm,PL_curstash);
9729 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9730 * anon CV. False positives like qr/[(?{]/ are harmless */
9732 if (type == OP_QR) {
9734 char *e, *p = SvPV(PL_lex_stuff, len);
9736 for (; p < e; p++) {
9737 if (p[0] == '(' && p[1] == '?'
9738 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9740 pm->op_pmflags |= PMf_HAS_CV;
9744 pm->op_pmflags |= PMf_IS_QR;
9747 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9748 &s, &charset, &x_mod_count))
9750 /* issue a warning if /c is specified,but /g is not */
9751 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9753 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9754 "Use of /c modifier is meaningless without /g" );
9757 PL_lex_op = (OP*)pm;
9758 pl_yylval.ival = OP_MATCH;
9763 S_scan_subst(pTHX_ char *start)
9769 line_t linediff = 0;
9771 char charset = '\0'; /* character set modifier */
9772 unsigned int x_mod_count = 0;
9775 PERL_ARGS_ASSERT_SCAN_SUBST;
9777 pl_yylval.ival = OP_NULL;
9779 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9782 Perl_croak(aTHX_ "Substitution pattern not terminated");
9786 first_start = PL_multi_start;
9787 first_line = CopLINE(PL_curcop);
9788 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9790 SvREFCNT_dec_NN(PL_lex_stuff);
9791 PL_lex_stuff = NULL;
9792 Perl_croak(aTHX_ "Substitution replacement not terminated");
9794 PL_multi_start = first_start; /* so whole substitution is taken together */
9796 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9800 if (*s == EXEC_PAT_MOD) {
9804 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9805 &s, &charset, &x_mod_count))
9811 if ((pm->op_pmflags & PMf_CONTINUE)) {
9812 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9816 SV * const repl = newSVpvs("");
9819 pm->op_pmflags |= PMf_EVAL;
9820 for (; es > 1; es--) {
9821 sv_catpvs(repl, "eval ");
9823 sv_catpvs(repl, "do {");
9824 sv_catsv(repl, PL_parser->lex_sub_repl);
9825 sv_catpvs(repl, "}");
9826 SvREFCNT_dec(PL_parser->lex_sub_repl);
9827 PL_parser->lex_sub_repl = repl;
9831 linediff = CopLINE(PL_curcop) - first_line;
9833 CopLINE_set(PL_curcop, first_line);
9835 if (linediff || es) {
9836 /* the IVX field indicates that the replacement string is a s///e;
9837 * the NVX field indicates how many src code lines the replacement
9839 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9840 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
9841 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9845 PL_lex_op = (OP*)pm;
9846 pl_yylval.ival = OP_SUBST;
9851 S_scan_trans(pTHX_ char *start)
9858 bool nondestruct = 0;
9861 PERL_ARGS_ASSERT_SCAN_TRANS;
9863 pl_yylval.ival = OP_NULL;
9865 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9867 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9871 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9873 SvREFCNT_dec_NN(PL_lex_stuff);
9874 PL_lex_stuff = NULL;
9875 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9878 complement = del = squash = 0;
9882 complement = OPpTRANS_COMPLEMENT;
9885 del = OPpTRANS_DELETE;
9888 squash = OPpTRANS_SQUASH;
9900 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9901 o->op_private &= ~OPpTRANS_ALL;
9902 o->op_private |= del|squash|complement|
9903 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9904 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9907 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9914 Takes a pointer to the first < in <<FOO.
9915 Returns a pointer to the byte following <<FOO.
9917 This function scans a heredoc, which involves different methods
9918 depending on whether we are in a string eval, quoted construct, etc.
9919 This is because PL_linestr could containing a single line of input, or
9920 a whole string being evalled, or the contents of the current quote-
9923 The two basic methods are:
9924 - Steal lines from the input stream
9925 - Scan the heredoc in PL_linestr and remove it therefrom
9927 In a file scope or filtered eval, the first method is used; in a
9928 string eval, the second.
9930 In a quote-like operator, we have to choose between the two,
9931 depending on where we can find a newline. We peek into outer lex-
9932 ing scopes until we find one with a newline in it. If we reach the
9933 outermost lexing scope and it is a file, we use the stream method.
9934 Otherwise it is treated as an eval.
9938 S_scan_heredoc(pTHX_ char *s)
9940 I32 op_type = OP_SCALAR;
9949 bool indented = FALSE;
9950 const bool infile = PL_rsfp || PL_parser->filtered;
9951 const line_t origline = CopLINE(PL_curcop);
9952 LEXSHARED *shared = PL_parser->lex_shared;
9954 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9957 d = PL_tokenbuf + 1;
9958 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9959 *PL_tokenbuf = '\n';
9965 while (SPACE_OR_TAB(*peek))
9967 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9970 s = delimcpy(d, e, s, PL_bufend, term, &len);
9972 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9978 /* <<\FOO is equivalent to <<'FOO' */
9982 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9983 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
9985 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
9986 peek += UTF ? UTF8SKIP(peek) : 1;
9988 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9989 Copy(s, d, len, char);
9993 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9994 Perl_croak(aTHX_ "Delimiter for here document is too long");
9997 len = d - PL_tokenbuf;
9999 #ifndef PERL_STRICT_CR
10000 d = (char *) memchr(s, '\r', PL_bufend - s);
10002 char * const olds = s;
10004 while (s < PL_bufend) {
10010 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10019 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10024 tmpstr = newSV_type(SVt_PVIV);
10025 SvGROW(tmpstr, 80);
10026 if (term == '\'') {
10027 op_type = OP_CONST;
10028 SvIV_set(tmpstr, -1);
10030 else if (term == '`') {
10031 op_type = OP_BACKTICK;
10032 SvIV_set(tmpstr, '\\');
10035 PL_multi_start = origline + 1 + PL_parser->herelines;
10036 PL_multi_open = PL_multi_close = '<';
10037 /* inside a string eval or quote-like operator */
10038 if (!infile || PL_lex_inwhat) {
10041 char * const olds = s;
10042 PERL_CONTEXT * const cx = CX_CUR();
10043 /* These two fields are not set until an inner lexing scope is
10044 entered. But we need them set here. */
10045 shared->ls_bufptr = s;
10046 shared->ls_linestr = PL_linestr;
10048 /* Look for a newline. If the current buffer does not have one,
10049 peek into the line buffer of the parent lexing scope, going
10050 up as many levels as necessary to find one with a newline
10053 while (!(s = (char *)memchr(
10054 (void *)shared->ls_bufptr, '\n',
10055 SvEND(shared->ls_linestr)-shared->ls_bufptr
10057 shared = shared->ls_prev;
10058 /* shared is only null if we have gone beyond the outermost
10059 lexing scope. In a file, we will have broken out of the
10060 loop in the previous iteration. In an eval, the string buf-
10061 fer ends with "\n;", so the while condition above will have
10062 evaluated to false. So shared can never be null. Or so you
10063 might think. Odd syntax errors like s;@{<<; can gobble up
10064 the implicit semicolon at the end of a flie, causing the
10065 file handle to be closed even when we are not in a string
10066 eval. So shared may be null in that case.
10067 (Closing '}' here to balance the earlier open brace for
10068 editors that look for matched pairs.) */
10069 if (UNLIKELY(!shared))
10071 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10072 most lexing scope. In a file, shared->ls_linestr at that
10073 level is just one line, so there is no body to steal. */
10074 if (infile && !shared->ls_prev) {
10079 else { /* eval or we've already hit EOF */
10080 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10084 linestr = shared->ls_linestr;
10085 bufend = SvEND(linestr);
10090 while (s < bufend - len + 1) {
10092 ++PL_parser->herelines;
10094 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10098 /* Only valid if it's preceded by whitespace only */
10099 while (backup != myolds && --backup >= myolds) {
10100 if (! SPACE_OR_TAB(*backup)) {
10107 /* No whitespace or all! */
10108 if (backup == s || *backup == '\n') {
10109 Newx(indent, indent_len + 1, char);
10110 memcpy(indent, backup + 1, indent_len);
10111 indent[indent_len] = 0;
10112 s--; /* before our delimiter */
10113 PL_parser->herelines--; /* this line doesn't count */
10119 while (s < bufend - len + 1
10120 && memNE(s,PL_tokenbuf,len) )
10123 ++PL_parser->herelines;
10127 if (s >= bufend - len + 1) {
10130 sv_setpvn(tmpstr,d+1,s-d);
10132 /* the preceding stmt passes a newline */
10133 PL_parser->herelines++;
10135 /* s now points to the newline after the heredoc terminator.
10136 d points to the newline before the body of the heredoc.
10139 /* We are going to modify linestr in place here, so set
10140 aside copies of the string if necessary for re-evals or
10142 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10143 check shared->re_eval_str. */
10144 if (shared->re_eval_start || shared->re_eval_str) {
10145 /* Set aside the rest of the regexp */
10146 if (!shared->re_eval_str)
10147 shared->re_eval_str =
10148 newSVpvn(shared->re_eval_start,
10149 bufend - shared->re_eval_start);
10150 shared->re_eval_start -= s-d;
10152 if (cxstack_ix >= 0
10153 && CxTYPE(cx) == CXt_EVAL
10154 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10155 && cx->blk_eval.cur_text == linestr)
10157 cx->blk_eval.cur_text = newSVsv(linestr);
10158 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10160 /* Copy everything from s onwards back to d. */
10161 Move(s,d,bufend-s + 1,char);
10162 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10163 /* Setting PL_bufend only applies when we have not dug deeper
10164 into other scopes, because sublex_done sets PL_bufend to
10165 SvEND(PL_linestr). */
10166 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10172 char *oldbufptr_save;
10173 char *oldoldbufptr_save;
10175 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10176 term = PL_tokenbuf[1];
10178 linestr_save = PL_linestr; /* must restore this afterwards */
10179 d = s; /* and this */
10180 oldbufptr_save = PL_oldbufptr;
10181 oldoldbufptr_save = PL_oldoldbufptr;
10182 PL_linestr = newSVpvs("");
10183 PL_bufend = SvPVX(PL_linestr);
10185 PL_bufptr = PL_bufend;
10186 CopLINE_set(PL_curcop,
10187 origline + 1 + PL_parser->herelines);
10188 if (!lex_next_chunk(LEX_NO_TERM)
10189 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10190 /* Simply freeing linestr_save might seem simpler here, as it
10191 does not matter what PL_linestr points to, since we are
10192 about to croak; but in a quote-like op, linestr_save
10193 will have been prospectively freed already, via
10194 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10195 restore PL_linestr. */
10196 SvREFCNT_dec_NN(PL_linestr);
10197 PL_linestr = linestr_save;
10198 PL_oldbufptr = oldbufptr_save;
10199 PL_oldoldbufptr = oldoldbufptr_save;
10202 CopLINE_set(PL_curcop, origline);
10203 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10204 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10205 /* ^That should be enough to avoid this needing to grow: */
10206 sv_catpvs(PL_linestr, "\n\0");
10207 assert(s == SvPVX(PL_linestr));
10208 PL_bufend = SvEND(PL_linestr);
10211 PL_parser->herelines++;
10212 PL_last_lop = PL_last_uni = NULL;
10213 #ifndef PERL_STRICT_CR
10214 if (PL_bufend - PL_linestart >= 2) {
10215 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10216 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10218 PL_bufend[-2] = '\n';
10220 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10222 else if (PL_bufend[-1] == '\r')
10223 PL_bufend[-1] = '\n';
10225 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10226 PL_bufend[-1] = '\n';
10228 if (indented && (PL_bufend-s) >= len) {
10229 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10232 char *backup = found;
10235 /* Only valid if it's preceded by whitespace only */
10236 while (backup != s && --backup >= s) {
10237 if (! SPACE_OR_TAB(*backup)) {
10243 /* All whitespace or none! */
10244 if (backup == found || SPACE_OR_TAB(*backup)) {
10245 Newx(indent, indent_len + 1, char);
10246 memcpy(indent, backup, indent_len);
10247 indent[indent_len] = 0;
10248 SvREFCNT_dec(PL_linestr);
10249 PL_linestr = linestr_save;
10250 PL_linestart = SvPVX(linestr_save);
10251 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10252 PL_oldbufptr = oldbufptr_save;
10253 PL_oldoldbufptr = oldoldbufptr_save;
10259 /* Didn't find it */
10260 sv_catsv(tmpstr,PL_linestr);
10262 if (*s == term && PL_bufend-s >= len
10263 && memEQ(s,PL_tokenbuf + 1,len))
10265 SvREFCNT_dec(PL_linestr);
10266 PL_linestr = linestr_save;
10267 PL_linestart = SvPVX(linestr_save);
10268 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10269 PL_oldbufptr = oldbufptr_save;
10270 PL_oldoldbufptr = oldoldbufptr_save;
10274 sv_catsv(tmpstr,PL_linestr);
10279 PL_multi_end = origline + PL_parser->herelines;
10280 if (indented && indent) {
10281 STRLEN linecount = 1;
10282 STRLEN herelen = SvCUR(tmpstr);
10283 char *ss = SvPVX(tmpstr);
10284 char *se = ss + herelen;
10285 SV *newstr = newSV(herelen+1);
10288 /* Trim leading whitespace */
10290 /* newline only? Copy and move on */
10292 sv_catpv(newstr,"\n");
10296 /* Found our indentation? Strip it */
10297 } else if (se - ss >= indent_len
10298 && memEQ(ss, indent, indent_len))
10304 while ((ss + le) < se && *(ss + le) != '\n')
10307 sv_catpvn(newstr, ss, le);
10311 /* Line doesn't begin with our indentation? Croak */
10314 "Indentation on line %d of here-doc doesn't match delimiter",
10319 /* avoid sv_setsv() as we dont wan't to COW here */
10320 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10322 SvREFCNT_dec_NN(newstr);
10324 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10325 SvPV_shrink_to_cur(tmpstr);
10328 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10331 PL_lex_stuff = tmpstr;
10332 pl_yylval.ival = op_type;
10336 SvREFCNT_dec(tmpstr);
10337 CopLINE_set(PL_curcop, origline);
10338 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10341 /* scan_inputsymbol
10342 takes: position of first '<' in input buffer
10343 returns: position of first char following the matching '>' in
10345 side-effects: pl_yylval and lex_op are set.
10350 <<>> read from ARGV without magic open
10351 <FH> read from filehandle
10352 <pkg::FH> read from package qualified filehandle
10353 <pkg'FH> read from package qualified filehandle
10354 <$fh> read from filehandle in $fh
10355 <*.h> filename glob
10360 S_scan_inputsymbol(pTHX_ char *start)
10362 char *s = start; /* current position in buffer */
10365 bool nomagicopen = FALSE;
10366 char *d = PL_tokenbuf; /* start of temp holding space */
10367 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10369 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10371 end = (char *) memchr(s, '\n', PL_bufend - s);
10374 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10375 nomagicopen = TRUE;
10381 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10383 /* die if we didn't have space for the contents of the <>,
10384 or if it didn't end, or if we see a newline
10387 if (len >= (I32)sizeof PL_tokenbuf)
10388 Perl_croak(aTHX_ "Excessively long <> operator");
10390 Perl_croak(aTHX_ "Unterminated <> operator");
10395 Remember, only scalar variables are interpreted as filehandles by
10396 this code. Anything more complex (e.g., <$fh{$num}>) will be
10397 treated as a glob() call.
10398 This code makes use of the fact that except for the $ at the front,
10399 a scalar variable and a filehandle look the same.
10401 if (*d == '$' && d[1]) d++;
10403 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10404 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10405 d += UTF ? UTF8SKIP(d) : 1;
10408 /* If we've tried to read what we allow filehandles to look like, and
10409 there's still text left, then it must be a glob() and not a getline.
10410 Use scan_str to pull out the stuff between the <> and treat it
10411 as nothing more than a string.
10414 if (d - PL_tokenbuf != len) {
10415 pl_yylval.ival = OP_GLOB;
10416 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10418 Perl_croak(aTHX_ "Glob not terminated");
10422 bool readline_overriden = FALSE;
10424 /* we're in a filehandle read situation */
10427 /* turn <> into <ARGV> */
10429 Copy("ARGV",d,5,char);
10431 /* Check whether readline() is overriden */
10432 if ((gv_readline = gv_override("readline",8)))
10433 readline_overriden = TRUE;
10435 /* if <$fh>, create the ops to turn the variable into a
10439 /* try to find it in the pad for this block, otherwise find
10440 add symbol table ops
10442 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10443 if (tmp != NOT_IN_PAD) {
10444 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10445 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10446 HEK * const stashname = HvNAME_HEK(stash);
10447 SV * const sym = sv_2mortal(newSVhek(stashname));
10448 sv_catpvs(sym, "::");
10449 sv_catpv(sym, d+1);
10454 OP * const o = newOP(OP_PADSV, 0);
10456 PL_lex_op = readline_overriden
10457 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10458 op_append_elem(OP_LIST, o,
10459 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10460 : newUNOP(OP_READLINE, 0, o);
10468 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10470 PL_lex_op = readline_overriden
10471 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10472 op_append_elem(OP_LIST,
10473 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10474 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10475 : newUNOP(OP_READLINE, 0,
10476 newUNOP(OP_RV2SV, 0,
10477 newGVOP(OP_GV, 0, gv)));
10479 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10480 pl_yylval.ival = OP_NULL;
10483 /* If it's none of the above, it must be a literal filehandle
10484 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10486 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10487 PL_lex_op = readline_overriden
10488 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10489 op_append_elem(OP_LIST,
10490 newGVOP(OP_GV, 0, gv),
10491 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10492 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10493 pl_yylval.ival = OP_NULL;
10503 start position in buffer
10504 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10505 only if they are of the open/close form
10506 keep_delims preserve the delimiters around the string
10507 re_reparse compiling a run-time /(?{})/:
10508 collapse // to /, and skip encoding src
10509 delimp if non-null, this is set to the position of
10510 the closing delimiter, or just after it if
10511 the closing and opening delimiters differ
10512 (i.e., the opening delimiter of a substitu-
10514 returns: position to continue reading from buffer
10515 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10516 updates the read buffer.
10518 This subroutine pulls a string out of the input. It is called for:
10519 q single quotes q(literal text)
10520 ' single quotes 'literal text'
10521 qq double quotes qq(interpolate $here please)
10522 " double quotes "interpolate $here please"
10523 qx backticks qx(/bin/ls -l)
10524 ` backticks `/bin/ls -l`
10525 qw quote words @EXPORT_OK = qw( func() $spam )
10526 m// regexp match m/this/
10527 s/// regexp substitute s/this/that/
10528 tr/// string transliterate tr/this/that/
10529 y/// string transliterate y/this/that/
10530 ($*@) sub prototypes sub foo ($)
10531 (stuff) sub attr parameters sub foo : attr(stuff)
10532 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10534 In most of these cases (all but <>, patterns and transliterate)
10535 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10536 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10537 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10540 It skips whitespace before the string starts, and treats the first
10541 character as the delimiter. If the delimiter is one of ([{< then
10542 the corresponding "close" character )]}> is used as the closing
10543 delimiter. It allows quoting of delimiters, and if the string has
10544 balanced delimiters ([{<>}]) it allows nesting.
10546 On success, the SV with the resulting string is put into lex_stuff or,
10547 if that is already non-NULL, into lex_repl. The second case occurs only
10548 when parsing the RHS of the special constructs s/// and tr/// (y///).
10549 For convenience, the terminating delimiter character is stuffed into
10554 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10558 SV *sv; /* scalar value: string */
10559 const char *tmps; /* temp string, used for delimiter matching */
10560 char *s = start; /* current position in the buffer */
10561 char term; /* terminating character */
10562 char *to; /* current position in the sv's data */
10563 I32 brackets = 1; /* bracket nesting level */
10564 bool has_utf8 = FALSE; /* is there any utf8 content? */
10565 IV termcode; /* terminating char. code */
10566 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10567 STRLEN termlen; /* length of terminating string */
10570 /* The delimiters that have a mirror-image closing one */
10571 const char * opening_delims = "([{<";
10572 const char * closing_delims = ")]}>";
10574 const char * non_grapheme_msg = "Use of unassigned code point or"
10575 " non-standalone grapheme for a delimiter"
10576 " will be a fatal error starting in Perl"
10578 /* The only non-UTF character that isn't a stand alone grapheme is
10579 * white-space, hence can't be a delimiter. So can skip for non-UTF-8 */
10580 bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED);
10582 PERL_ARGS_ASSERT_SCAN_STR;
10584 /* skip space before the delimiter */
10589 /* mark where we are, in case we need to report errors */
10592 /* after skipping whitespace, the next character is the terminator */
10594 if (!UTF || UTF8_IS_INVARIANT(term)) {
10595 termcode = termstr[0] = term;
10599 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10600 if (check_grapheme) {
10601 if ( UNLIKELY(UNICODE_IS_SUPER(termcode))
10602 || UNLIKELY(UNICODE_IS_NONCHAR(termcode)))
10604 /* These are considered graphemes, and since the ending
10605 * delimiter will be the same, we don't have to check the other
10607 check_grapheme = FALSE;
10609 else if (UNLIKELY(! _is_grapheme((U8 *) start,
10614 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "%s", non_grapheme_msg);
10616 /* Don't have to check the other end, as have already warned at
10618 check_grapheme = FALSE;
10622 Copy(s, termstr, termlen, U8);
10625 /* mark where we are */
10626 PL_multi_start = CopLINE(PL_curcop);
10627 PL_multi_open = termcode;
10628 herelines = PL_parser->herelines;
10630 /* If the delimiter has a mirror-image closing one, get it */
10631 if (term && (tmps = strchr(opening_delims, term))) {
10632 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10635 PL_multi_close = termcode;
10637 if (PL_multi_open == PL_multi_close) {
10638 keep_bracketed_quoted = FALSE;
10641 /* create a new SV to hold the contents. 79 is the SV's initial length.
10642 What a random number. */
10643 sv = newSV_type(SVt_PVIV);
10645 SvIV_set(sv, termcode);
10646 (void)SvPOK_only(sv); /* validate pointer */
10648 /* move past delimiter and try to read a complete string */
10650 sv_catpvn(sv, s, termlen);
10653 /* extend sv if need be */
10654 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10655 /* set 'to' to the next character in the sv's string */
10656 to = SvPVX(sv)+SvCUR(sv);
10658 /* if open delimiter is the close delimiter read unbridle */
10659 if (PL_multi_open == PL_multi_close) {
10660 for (; s < PL_bufend; s++,to++) {
10661 /* embedded newlines increment the current line number */
10662 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10663 COPLINE_INC_WITH_HERELINES;
10664 /* handle quoted delimiters */
10665 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10666 if (!keep_bracketed_quoted
10668 || (re_reparse && s[1] == '\\'))
10671 else /* any other quotes are simply copied straight through */
10674 /* terminate when run out of buffer (the for() condition), or
10675 have found the terminator */
10676 else if (*s == term) { /* First byte of terminator matches */
10677 if (termlen == 1) /* If is the only byte, are done */
10680 /* If the remainder of the terminator matches, also are
10681 * done, after checking that is a separate grapheme */
10682 if ( s + termlen <= PL_bufend
10683 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10685 if ( check_grapheme
10686 && UNLIKELY(! _is_grapheme((U8 *) start,
10691 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10692 "%s", non_grapheme_msg);
10697 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10705 /* if the terminator isn't the same as the start character (e.g.,
10706 matched brackets), we have to allow more in the quoting, and
10707 be prepared for nested brackets.
10710 /* read until we run out of string, or we find the terminator */
10711 for (; s < PL_bufend; s++,to++) {
10712 /* embedded newlines increment the line count */
10713 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10714 COPLINE_INC_WITH_HERELINES;
10715 /* backslashes can escape the open or closing characters */
10716 if (*s == '\\' && s+1 < PL_bufend) {
10717 if (!keep_bracketed_quoted
10718 && ( ((UV)s[1] == PL_multi_open)
10719 || ((UV)s[1] == PL_multi_close) ))
10726 /* allow nested opens and closes */
10727 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10729 else if ((UV)*s == PL_multi_open)
10731 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10736 /* terminate the copied string and update the sv's end-of-string */
10738 SvCUR_set(sv, to - SvPVX_const(sv));
10741 * this next chunk reads more into the buffer if we're not done yet
10745 break; /* handle case where we are done yet :-) */
10747 #ifndef PERL_STRICT_CR
10748 if (to - SvPVX_const(sv) >= 2) {
10749 if ( (to[-2] == '\r' && to[-1] == '\n')
10750 || (to[-2] == '\n' && to[-1] == '\r'))
10754 SvCUR_set(sv, to - SvPVX_const(sv));
10756 else if (to[-1] == '\r')
10759 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10763 /* if we're out of file, or a read fails, bail and reset the current
10764 line marker so we can report where the unterminated string began
10766 COPLINE_INC_WITH_HERELINES;
10767 PL_bufptr = PL_bufend;
10768 if (!lex_next_chunk(0)) {
10770 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10773 s = start = PL_bufptr;
10776 /* at this point, we have successfully read the delimited string */
10779 sv_catpvn(sv, s, termlen);
10785 PL_multi_end = CopLINE(PL_curcop);
10786 CopLINE_set(PL_curcop, PL_multi_start);
10787 PL_parser->herelines = herelines;
10789 /* if we allocated too much space, give some back */
10790 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10791 SvLEN_set(sv, SvCUR(sv) + 1);
10792 SvPV_renew(sv, SvLEN(sv));
10795 /* decide whether this is the first or second quoted string we've read
10800 PL_parser->lex_sub_repl = sv;
10803 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10809 takes: pointer to position in buffer
10810 returns: pointer to new position in buffer
10811 side-effects: builds ops for the constant in pl_yylval.op
10813 Read a number in any of the formats that Perl accepts:
10815 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10816 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10817 0b[01](_?[01])* binary integers
10818 0[0-7](_?[0-7])* octal integers
10819 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10820 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10822 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10825 If it reads a number without a decimal point or an exponent, it will
10826 try converting the number to an integer and see if it can do so
10827 without loss of precision.
10831 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10833 const char *s = start; /* current position in buffer */
10834 char *d; /* destination in temp buffer */
10835 char *e; /* end of temp buffer */
10836 NV nv; /* number read, as a double */
10837 SV *sv = NULL; /* place to put the converted number */
10838 bool floatit; /* boolean: int or float? */
10839 const char *lastub = NULL; /* position of last underbar */
10840 static const char* const number_too_long = "Number too long";
10841 bool warned_about_underscore = 0;
10842 #define WARN_ABOUT_UNDERSCORE() \
10844 if (!warned_about_underscore) { \
10845 warned_about_underscore = 1; \
10846 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10847 "Misplaced _ in number"); \
10850 /* Hexadecimal floating point.
10852 * In many places (where we have quads and NV is IEEE 754 double)
10853 * we can fit the mantissa bits of a NV into an unsigned quad.
10854 * (Note that UVs might not be quads even when we have quads.)
10855 * This will not work everywhere, though (either no quads, or
10856 * using long doubles), in which case we have to resort to NV,
10857 * which will probably mean horrible loss of precision due to
10858 * multiple fp operations. */
10859 bool hexfp = FALSE;
10860 int total_bits = 0;
10861 int significant_bits = 0;
10862 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10863 # define HEXFP_UQUAD
10864 Uquad_t hexfp_uquad = 0;
10865 int hexfp_frac_bits = 0;
10870 NV hexfp_mult = 1.0;
10871 UV high_non_zero = 0; /* highest digit */
10872 int non_zero_integer_digits = 0;
10874 PERL_ARGS_ASSERT_SCAN_NUM;
10876 /* We use the first character to decide what type of number this is */
10880 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10882 /* if it starts with a 0, it could be an octal number, a decimal in
10883 0.13 disguise, or a hexadecimal number, or a binary number. */
10887 u holds the "number so far"
10888 shift the power of 2 of the base
10889 (hex == 4, octal == 3, binary == 1)
10890 overflowed was the number more than we can hold?
10892 Shift is used when we add a digit. It also serves as an "are
10893 we in octal/hex/binary?" indicator to disallow hex characters
10894 when in octal mode.
10899 bool overflowed = FALSE;
10900 bool just_zero = TRUE; /* just plain 0 or binary number? */
10901 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10902 static const char* const bases[5] =
10903 { "", "binary", "", "octal", "hexadecimal" };
10904 static const char* const Bases[5] =
10905 { "", "Binary", "", "Octal", "Hexadecimal" };
10906 static const char* const maxima[5] =
10908 "0b11111111111111111111111111111111",
10912 const char *base, *Base, *max;
10914 /* check for hex */
10915 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10919 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10924 /* check for a decimal in disguise */
10925 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10927 /* so it must be octal */
10934 WARN_ABOUT_UNDERSCORE();
10938 base = bases[shift];
10939 Base = Bases[shift];
10940 max = maxima[shift];
10942 /* read the rest of the number */
10944 /* x is used in the overflow test,
10945 b is the digit we're adding on. */
10950 /* if we don't mention it, we're done */
10954 /* _ are ignored -- but warned about if consecutive */
10956 if (lastub && s == lastub + 1)
10957 WARN_ABOUT_UNDERSCORE();
10961 /* 8 and 9 are not octal */
10962 case '8': case '9':
10964 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10968 case '2': case '3': case '4':
10969 case '5': case '6': case '7':
10971 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10974 case '0': case '1':
10975 b = *s++ & 15; /* ASCII digit -> value of digit */
10979 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10980 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10981 /* make sure they said 0x */
10984 b = (*s++ & 7) + 9;
10986 /* Prepare to put the digit we have onto the end
10987 of the number so far. We check for overflows.
10993 assert(shift >= 0);
10994 x = u << shift; /* make room for the digit */
10996 total_bits += shift;
10998 if ((x >> shift) != u
10999 && !(PL_hints & HINT_NEW_BINARY)) {
11002 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11003 "Integer overflow in %s number",
11006 u = x | b; /* add the digit to the end */
11009 n *= nvshift[shift];
11010 /* If an NV has not enough bits in its
11011 * mantissa to represent an UV this summing of
11012 * small low-order numbers is a waste of time
11013 * (because the NV cannot preserve the
11014 * low-order bits anyway): we could just
11015 * remember when did we overflow and in the
11016 * end just multiply n by the right
11021 if (high_non_zero == 0 && b > 0)
11025 non_zero_integer_digits++;
11027 /* this could be hexfp, but peek ahead
11028 * to avoid matching ".." */
11029 if (UNLIKELY(HEXFP_PEEK(s))) {
11037 /* if we get here, we had success: make a scalar value from
11042 /* final misplaced underbar check */
11044 WARN_ABOUT_UNDERSCORE();
11046 if (UNLIKELY(HEXFP_PEEK(s))) {
11047 /* Do sloppy (on the underbars) but quick detection
11048 * (and value construction) for hexfp, the decimal
11049 * detection will shortly be more thorough with the
11050 * underbar checks. */
11052 significant_bits = non_zero_integer_digits * shift;
11055 #else /* HEXFP_NV */
11058 /* Ignore the leading zero bits of
11059 * the high (first) non-zero digit. */
11060 if (high_non_zero) {
11061 if (high_non_zero < 0x8)
11062 significant_bits--;
11063 if (high_non_zero < 0x4)
11064 significant_bits--;
11065 if (high_non_zero < 0x2)
11066 significant_bits--;
11073 bool accumulate = TRUE;
11075 int lim = 1 << shift;
11076 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11078 if (isXDIGIT(*h)) {
11079 significant_bits += shift;
11082 if (significant_bits < NV_MANT_DIG) {
11083 /* We are in the long "run" of xdigits,
11084 * accumulate the full four bits. */
11085 assert(shift >= 0);
11086 hexfp_uquad <<= shift;
11088 hexfp_frac_bits += shift;
11089 } else if (significant_bits - shift < NV_MANT_DIG) {
11090 /* We are at a hexdigit either at,
11091 * or straddling, the edge of mantissa.
11092 * We will try grabbing as many as
11093 * possible bits. */
11095 significant_bits - NV_MANT_DIG;
11099 hexfp_uquad <<= tail;
11100 assert((shift - tail) >= 0);
11101 hexfp_uquad |= b >> (shift - tail);
11102 hexfp_frac_bits += tail;
11104 /* Ignore the trailing zero bits
11105 * of the last non-zero xdigit.
11107 * The assumption here is that if
11108 * one has input of e.g. the xdigit
11109 * eight (0x8), there is only one
11110 * bit being input, not the full
11111 * four bits. Conversely, if one
11112 * specifies a zero xdigit, the
11113 * assumption is that one really
11114 * wants all those bits to be zero. */
11116 if ((b & 0x1) == 0x0) {
11117 significant_bits--;
11118 if ((b & 0x2) == 0x0) {
11119 significant_bits--;
11120 if ((b & 0x4) == 0x0) {
11121 significant_bits--;
11127 accumulate = FALSE;
11130 /* Keep skipping the xdigits, and
11131 * accumulating the significant bits,
11132 * but do not shift the uquad
11133 * (which would catastrophically drop
11134 * high-order bits) or accumulate the
11135 * xdigits anymore. */
11137 #else /* HEXFP_NV */
11139 nv_mult /= nvshift[shift];
11141 hexfp_nv += b * nv_mult;
11143 accumulate = FALSE;
11147 if (significant_bits >= NV_MANT_DIG)
11148 accumulate = FALSE;
11152 if ((total_bits > 0 || significant_bits > 0) &&
11153 isALPHA_FOLD_EQ(*h, 'p')) {
11154 bool negexp = FALSE;
11158 else if (*h == '-') {
11164 while (isDIGIT(*h) || *h == '_') {
11167 hexfp_exp += *h - '0';
11170 && -hexfp_exp < NV_MIN_EXP - 1) {
11171 /* NOTE: this means that the exponent
11172 * underflow warning happens for
11173 * the IEEE 754 subnormals (denormals),
11174 * because DBL_MIN_EXP etc are the lowest
11175 * possible binary (or, rather, DBL_RADIX-base)
11176 * exponent for normals, not subnormals.
11178 * This may or may not be a good thing. */
11179 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11180 "Hexadecimal float: exponent underflow");
11186 && hexfp_exp > NV_MAX_EXP - 1) {
11187 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11188 "Hexadecimal float: exponent overflow");
11196 hexfp_exp = -hexfp_exp;
11198 hexfp_exp -= hexfp_frac_bits;
11200 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11208 if (n > 4294967295.0)
11209 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11210 "%s number > %s non-portable",
11216 if (u > 0xffffffff)
11217 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11218 "%s number > %s non-portable",
11223 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11224 sv = new_constant(start, s - start, "integer",
11225 sv, NULL, NULL, 0);
11226 else if (PL_hints & HINT_NEW_BINARY)
11227 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11232 handle decimal numbers.
11233 we're also sent here when we read a 0 as the first digit
11235 case '1': case '2': case '3': case '4': case '5':
11236 case '6': case '7': case '8': case '9': case '.':
11239 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11248 /* read next group of digits and _ and copy into d */
11251 || UNLIKELY(hexfp && isXDIGIT(*s)))
11253 /* skip underscores, checking for misplaced ones
11257 if (lastub && s == lastub + 1)
11258 WARN_ABOUT_UNDERSCORE();
11262 /* check for end of fixed-length buffer */
11264 Perl_croak(aTHX_ "%s", number_too_long);
11265 /* if we're ok, copy the character */
11270 /* final misplaced underbar check */
11271 if (lastub && s == lastub + 1)
11272 WARN_ABOUT_UNDERSCORE();
11274 /* read a decimal portion if there is one. avoid
11275 3..5 being interpreted as the number 3. followed
11278 if (*s == '.' && s[1] != '.') {
11283 WARN_ABOUT_UNDERSCORE();
11287 /* copy, ignoring underbars, until we run out of digits.
11291 || UNLIKELY(hexfp && isXDIGIT(*s));
11294 /* fixed length buffer check */
11296 Perl_croak(aTHX_ "%s", number_too_long);
11298 if (lastub && s == lastub + 1)
11299 WARN_ABOUT_UNDERSCORE();
11305 /* fractional part ending in underbar? */
11307 WARN_ABOUT_UNDERSCORE();
11308 if (*s == '.' && isDIGIT(s[1])) {
11309 /* oops, it's really a v-string, but without the "v" */
11315 /* read exponent part, if present */
11316 if ((isALPHA_FOLD_EQ(*s, 'e')
11317 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11318 && strchr("+-0123456789_", s[1]))
11320 int exp_digits = 0;
11321 const char *save_s = s;
11324 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11325 ditto for p (hexfloats) */
11326 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11327 /* At least some Mach atof()s don't grok 'E' */
11330 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11337 /* stray preinitial _ */
11339 WARN_ABOUT_UNDERSCORE();
11343 /* allow positive or negative exponent */
11344 if (*s == '+' || *s == '-')
11347 /* stray initial _ */
11349 WARN_ABOUT_UNDERSCORE();
11353 /* read digits of exponent */
11354 while (isDIGIT(*s) || *s == '_') {
11358 Perl_croak(aTHX_ "%s", number_too_long);
11362 if (((lastub && s == lastub + 1)
11363 || (!isDIGIT(s[1]) && s[1] != '_')))
11364 WARN_ABOUT_UNDERSCORE();
11370 /* no exponent digits, the [eEpP] could be for something else,
11371 * though in practice we don't get here for p since that's preparsed
11372 * earlier, and results in only the 0xX being consumed, so behave similarly
11373 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11386 We try to do an integer conversion first if no characters
11387 indicating "float" have been found.
11392 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11394 if (flags == IS_NUMBER_IN_UV) {
11396 sv = newSViv(uv); /* Prefer IVs over UVs. */
11399 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11400 if (uv <= (UV) IV_MIN)
11401 sv = newSViv(-(IV)uv);
11408 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
11409 /* terminate the string */
11411 if (UNLIKELY(hexfp)) {
11412 # ifdef NV_MANT_DIG
11413 if (significant_bits > NV_MANT_DIG)
11414 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11415 "Hexadecimal float: mantissa overflow");
11418 nv = hexfp_uquad * hexfp_mult;
11419 #else /* HEXFP_NV */
11420 nv = hexfp_nv * hexfp_mult;
11423 nv = Atof(PL_tokenbuf);
11425 RESTORE_LC_NUMERIC_UNDERLYING();
11430 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11431 const char *const key = floatit ? "float" : "integer";
11432 const STRLEN keylen = floatit ? 5 : 7;
11433 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11434 key, keylen, sv, NULL, NULL, 0);
11438 /* if it starts with a v, it could be a v-string */
11441 sv = newSV(5); /* preallocate storage space */
11442 ENTER_with_name("scan_vstring");
11444 s = scan_vstring(s, PL_bufend, sv);
11445 SvREFCNT_inc_simple_void_NN(sv);
11446 LEAVE_with_name("scan_vstring");
11450 /* make the op for the constant and return */
11453 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11455 lvalp->opval = NULL;
11461 S_scan_formline(pTHX_ char *s)
11463 SV * const stuff = newSVpvs("");
11464 bool needargs = FALSE;
11465 bool eofmt = FALSE;
11467 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11469 while (!needargs) {
11473 #ifdef PERL_STRICT_CR
11474 while (SPACE_OR_TAB(*t))
11477 while (SPACE_OR_TAB(*t) || *t == '\r')
11480 if (*t == '\n' || t == PL_bufend) {
11485 eol = (char *) memchr(s,'\n',PL_bufend-s);
11490 for (t = s; t < eol; t++) {
11491 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11493 goto enough; /* ~~ must be first line in formline */
11495 if (*t == '@' || *t == '^')
11499 sv_catpvn(stuff, s, eol-s);
11500 #ifndef PERL_STRICT_CR
11501 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11502 char *end = SvPVX(stuff) + SvCUR(stuff);
11505 SvCUR_set(stuff, SvCUR(stuff) - 1);
11513 if ((PL_rsfp || PL_parser->filtered)
11514 && PL_parser->form_lex_state == LEX_NORMAL) {
11516 PL_bufptr = PL_bufend;
11517 COPLINE_INC_WITH_HERELINES;
11518 got_some = lex_next_chunk(0);
11519 CopLINE_dec(PL_curcop);
11524 incline(s, PL_bufend);
11527 if (!SvCUR(stuff) || needargs)
11528 PL_lex_state = PL_parser->form_lex_state;
11529 if (SvCUR(stuff)) {
11530 PL_expect = XSTATE;
11532 const char *s2 = s;
11533 while (isSPACE(*s2) && *s2 != '\n')
11536 PL_expect = XTERMBLOCK;
11537 NEXTVAL_NEXTTOKE.ival = 0;
11540 NEXTVAL_NEXTTOKE.ival = 0;
11541 force_next(FORMLBRACK);
11544 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11547 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11551 SvREFCNT_dec(stuff);
11553 PL_lex_formbrack = 0;
11559 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11561 const I32 oldsavestack_ix = PL_savestack_ix;
11562 CV* const outsidecv = PL_compcv;
11564 SAVEI32(PL_subline);
11565 save_item(PL_subname);
11566 SAVESPTR(PL_compcv);
11568 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11569 CvFLAGS(PL_compcv) |= flags;
11571 PL_subline = CopLINE(PL_curcop);
11572 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11573 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11574 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11575 if (outsidecv && CvPADLIST(outsidecv))
11576 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11578 return oldsavestack_ix;
11582 S_yywarn(pTHX_ const char *const s, U32 flags)
11584 PERL_ARGS_ASSERT_YYWARN;
11586 PL_in_eval |= EVAL_WARNONLY;
11587 yyerror_pv(s, flags);
11592 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11594 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11597 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11600 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11602 NOT_REACHED; /* NOTREACHED */
11608 /* Called, after at least one error has been found, to abort the parse now,
11609 * instead of trying to forge ahead */
11611 yyerror_pvn(NULL, 0, 0);
11615 Perl_yyerror(pTHX_ const char *const s)
11617 PERL_ARGS_ASSERT_YYERROR;
11618 return yyerror_pvn(s, strlen(s), 0);
11622 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11624 PERL_ARGS_ASSERT_YYERROR_PV;
11625 return yyerror_pvn(s, strlen(s), flags);
11629 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11631 const char *context = NULL;
11634 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11635 int yychar = PL_parser->yychar;
11637 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11638 * apply. If the number of errors found is large enough, it abandons
11639 * parsing. If 's' is NULL, there is no message, and it abandons
11640 * processing unconditionally */
11643 if (!yychar || (yychar == ';' && !PL_rsfp))
11644 sv_catpvs(where_sv, "at EOF");
11645 else if ( PL_oldoldbufptr
11646 && PL_bufptr > PL_oldoldbufptr
11647 && PL_bufptr - PL_oldoldbufptr < 200
11648 && PL_oldoldbufptr != PL_oldbufptr
11649 && PL_oldbufptr != PL_bufptr)
11653 The code below is removed for NetWare because it
11654 abends/crashes on NetWare when the script has error such as
11655 not having the closing quotes like:
11656 if ($var eq "value)
11657 Checking of white spaces is anyway done in NetWare code.
11660 while (isSPACE(*PL_oldoldbufptr))
11663 context = PL_oldoldbufptr;
11664 contlen = PL_bufptr - PL_oldoldbufptr;
11666 else if ( PL_oldbufptr
11667 && PL_bufptr > PL_oldbufptr
11668 && PL_bufptr - PL_oldbufptr < 200
11669 && PL_oldbufptr != PL_bufptr) {
11672 The code below is removed for NetWare because it
11673 abends/crashes on NetWare when the script has error such as
11674 not having the closing quotes like:
11675 if ($var eq "value)
11676 Checking of white spaces is anyway done in NetWare code.
11679 while (isSPACE(*PL_oldbufptr))
11682 context = PL_oldbufptr;
11683 contlen = PL_bufptr - PL_oldbufptr;
11685 else if (yychar > 255)
11686 sv_catpvs(where_sv, "next token ???");
11687 else if (yychar == YYEMPTY) {
11688 if (PL_lex_state == LEX_NORMAL)
11689 sv_catpvs(where_sv, "at end of line");
11690 else if (PL_lex_inpat)
11691 sv_catpvs(where_sv, "within pattern");
11693 sv_catpvs(where_sv, "within string");
11696 sv_catpvs(where_sv, "next char ");
11698 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11699 else if (isPRINT_LC(yychar)) {
11700 const char string = yychar;
11701 sv_catpvn(where_sv, &string, 1);
11704 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11706 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11707 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11708 OutCopFILE(PL_curcop),
11709 (IV)(PL_parser->preambling == NOLINE
11710 ? CopLINE(PL_curcop)
11711 : PL_parser->preambling));
11713 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11714 UTF8fARG(UTF, contlen, context));
11716 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11717 if ( PL_multi_start < PL_multi_end
11718 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11720 Perl_sv_catpvf(aTHX_ msg,
11721 " (Might be a runaway multi-line %c%c string starting on"
11722 " line %" IVdf ")\n",
11723 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11726 if (PL_in_eval & EVAL_WARNONLY) {
11727 PL_in_eval &= ~EVAL_WARNONLY;
11728 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11734 if (s == NULL || PL_error_count >= 10) {
11735 const char * msg = "";
11736 const char * const name = OutCopFILE(PL_curcop);
11739 SV * errsv = ERRSV;
11740 if (SvCUR(errsv)) {
11741 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11746 abort_execution(msg, name);
11749 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11753 PL_in_my_stash = NULL;
11758 S_swallow_bom(pTHX_ U8 *s)
11760 const STRLEN slen = SvCUR(PL_linestr);
11762 PERL_ARGS_ASSERT_SWALLOW_BOM;
11766 if (s[1] == 0xFE) {
11767 /* UTF-16 little-endian? (or UTF-32LE?) */
11768 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11769 /* diag_listed_as: Unsupported script encoding %s */
11770 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11771 #ifndef PERL_NO_UTF16_FILTER
11773 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11776 if (PL_bufend > (char*)s) {
11777 s = add_utf16_textfilter(s, TRUE);
11780 /* diag_listed_as: Unsupported script encoding %s */
11781 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11786 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11787 #ifndef PERL_NO_UTF16_FILTER
11789 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11792 if (PL_bufend > (char *)s) {
11793 s = add_utf16_textfilter(s, FALSE);
11796 /* diag_listed_as: Unsupported script encoding %s */
11797 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11801 case BOM_UTF8_FIRST_BYTE: {
11802 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
11804 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11806 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
11813 if (s[2] == 0xFE && s[3] == 0xFF) {
11814 /* UTF-32 big-endian */
11815 /* diag_listed_as: Unsupported script encoding %s */
11816 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11819 else if (s[2] == 0 && s[3] != 0) {
11822 * are a good indicator of UTF-16BE. */
11823 #ifndef PERL_NO_UTF16_FILTER
11825 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11827 s = add_utf16_textfilter(s, FALSE);
11829 /* diag_listed_as: Unsupported script encoding %s */
11830 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11837 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11840 * are a good indicator of UTF-16LE. */
11841 #ifndef PERL_NO_UTF16_FILTER
11843 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11845 s = add_utf16_textfilter(s, TRUE);
11847 /* diag_listed_as: Unsupported script encoding %s */
11848 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11856 #ifndef PERL_NO_UTF16_FILTER
11858 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11860 SV *const filter = FILTER_DATA(idx);
11861 /* We re-use this each time round, throwing the contents away before we
11863 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11864 SV *const utf8_buffer = filter;
11865 IV status = IoPAGE(filter);
11866 const bool reverse = cBOOL(IoLINES(filter));
11869 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11871 /* As we're automatically added, at the lowest level, and hence only called
11872 from this file, we can be sure that we're not called in block mode. Hence
11873 don't bother writing code to deal with block mode. */
11875 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11878 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11880 DEBUG_P(PerlIO_printf(Perl_debug_log,
11881 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11882 FPTR2DPTR(void *, S_utf16_textfilter),
11883 reverse ? 'l' : 'b', idx, maxlen, status,
11884 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11891 /* First, look in our buffer of existing UTF-8 data: */
11892 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11896 } else if (status == 0) {
11898 IoPAGE(filter) = 0;
11899 nl = SvEND(utf8_buffer);
11902 STRLEN got = nl - SvPVX(utf8_buffer);
11903 /* Did we have anything to append? */
11905 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11906 /* Everything else in this code works just fine if SVp_POK isn't
11907 set. This, however, needs it, and we need it to work, else
11908 we loop infinitely because the buffer is never consumed. */
11909 sv_chop(utf8_buffer, nl);
11913 /* OK, not a complete line there, so need to read some more UTF-16.
11914 Read an extra octect if the buffer currently has an odd number. */
11918 if (SvCUR(utf16_buffer) >= 2) {
11919 /* Location of the high octet of the last complete code point.
11920 Gosh, UTF-16 is a pain. All the benefits of variable length,
11921 *coupled* with all the benefits of partial reads and
11923 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11924 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11926 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11930 /* We have the first half of a surrogate. Read more. */
11931 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11934 status = FILTER_READ(idx + 1, utf16_buffer,
11935 160 + (SvCUR(utf16_buffer) & 1));
11936 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11937 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11940 IoPAGE(filter) = status;
11945 /* 'chars' isn't quite the right name, as code points above 0xFFFF
11946 * require 4 bytes per char */
11947 chars = SvCUR(utf16_buffer) >> 1;
11948 have = SvCUR(utf8_buffer);
11950 /* Assume the worst case size as noted by the functions: twice the
11951 * number of input bytes */
11952 SvGROW(utf8_buffer, have + chars * 4 + 1);
11955 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11956 (U8*)SvPVX_const(utf8_buffer) + have,
11957 chars * 2, &newlen);
11959 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11960 (U8*)SvPVX_const(utf8_buffer) + have,
11961 chars * 2, &newlen);
11963 SvCUR_set(utf8_buffer, have + newlen);
11966 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11967 it's private to us, and utf16_to_utf8{,reversed} take a
11968 (pointer,length) pair, rather than a NUL-terminated string. */
11969 if(SvCUR(utf16_buffer) & 1) {
11970 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11971 SvCUR_set(utf16_buffer, 1);
11973 SvCUR_set(utf16_buffer, 0);
11976 DEBUG_P(PerlIO_printf(Perl_debug_log,
11977 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11979 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11980 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11985 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11987 SV *filter = filter_add(S_utf16_textfilter, NULL);
11989 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11991 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11993 IoLINES(filter) = reversed;
11994 IoPAGE(filter) = 1; /* Not EOF */
11996 /* Sadly, we have to return a valid pointer, come what may, so we have to
11997 ignore any error return from this. */
11998 SvCUR_set(PL_linestr, 0);
11999 if (FILTER_READ(0, PL_linestr, 0)) {
12000 SvUTF8_on(PL_linestr);
12002 SvUTF8_on(PL_linestr);
12004 PL_bufend = SvEND(PL_linestr);
12005 return (U8*)SvPVX(PL_linestr);
12010 Returns a pointer to the next character after the parsed
12011 vstring, as well as updating the passed in sv.
12013 Function must be called like
12015 sv = sv_2mortal(newSV(5));
12016 s = scan_vstring(s,e,sv);
12018 where s and e are the start and end of the string.
12019 The sv should already be large enough to store the vstring
12020 passed in, for performance reasons.
12022 This function may croak if fatal warnings are enabled in the
12023 calling scope, hence the sv_2mortal in the example (to prevent
12024 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12030 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12032 const char *pos = s;
12033 const char *start = s;
12035 PERL_ARGS_ASSERT_SCAN_VSTRING;
12037 if (*pos == 'v') pos++; /* get past 'v' */
12038 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12040 if ( *pos != '.') {
12041 /* this may not be a v-string if followed by => */
12042 const char *next = pos;
12043 while (next < e && isSPACE(*next))
12045 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12046 /* return string not v-string */
12047 sv_setpvn(sv,(char *)s,pos-s);
12048 return (char *)pos;
12052 if (!isALPHA(*pos)) {
12053 U8 tmpbuf[UTF8_MAXBYTES+1];
12056 s++; /* get past 'v' */
12061 /* this is atoi() that tolerates underscores */
12064 const char *end = pos;
12066 while (--end >= s) {
12068 const UV orev = rev;
12069 rev += (*end - '0') * mult;
12072 /* diag_listed_as: Integer overflow in %s number */
12073 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12074 "Integer overflow in decimal number");
12078 /* Append native character for the rev point */
12079 tmpend = uvchr_to_utf8(tmpbuf, rev);
12080 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12081 if (!UVCHR_IS_INVARIANT(rev))
12083 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12089 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12093 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12100 Perl_keyword_plugin_standard(pTHX_
12101 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12103 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12104 PERL_UNUSED_CONTEXT;
12105 PERL_UNUSED_ARG(keyword_ptr);
12106 PERL_UNUSED_ARG(keyword_len);
12107 PERL_UNUSED_ARG(op_ptr);
12108 return KEYWORD_PLUGIN_DECLINE;
12112 =for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
12114 Puts a C function into the chain of keyword plugins. This is the
12115 preferred way to manipulate the L</PL_keyword_plugin> variable.
12116 C<new_plugin> is a pointer to the C function that is to be added to the
12117 keyword plugin chain, and C<old_plugin_p> points to the storage location
12118 where a pointer to the next function in the chain will be stored. The
12119 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12120 while the value previously stored there is written to C<*old_plugin_p>.
12122 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12123 to hook keyword parsing may find itself invoked more than once per
12124 process, typically in different threads. To handle that situation, this
12125 function is idempotent. The location C<*old_plugin_p> must initially
12126 (once per process) contain a null pointer. A C variable of static
12127 duration (declared at file scope, typically also marked C<static> to give
12128 it internal linkage) will be implicitly initialised appropriately, if it
12129 does not have an explicit initialiser. This function will only actually
12130 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12131 function is also thread safe on the small scale. It uses appropriate
12132 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12134 When this function is called, the function referenced by C<new_plugin>
12135 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12136 In a threading situation, C<new_plugin> may be called immediately, even
12137 before this function has returned. C<*old_plugin_p> will always be
12138 appropriately set before C<new_plugin> is called. If C<new_plugin>
12139 decides not to do anything special with the identifier that it is given
12140 (which is the usual case for most calls to a keyword plugin), it must
12141 chain the plugin function referenced by C<*old_plugin_p>.
12143 Taken all together, XS code to install a keyword plugin should typically
12144 look something like this:
12146 static Perl_keyword_plugin_t next_keyword_plugin;
12147 static OP *my_keyword_plugin(pTHX_
12148 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12150 if (memEQs(keyword_ptr, keyword_len,
12151 "my_new_keyword")) {
12154 return next_keyword_plugin(aTHX_
12155 keyword_ptr, keyword_len, op_ptr);
12159 wrap_keyword_plugin(my_keyword_plugin,
12160 &next_keyword_plugin);
12162 Direct access to L</PL_keyword_plugin> should be avoided.
12168 Perl_wrap_keyword_plugin(pTHX_
12169 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12173 PERL_UNUSED_CONTEXT;
12174 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12175 if (*old_plugin_p) return;
12176 KEYWORD_PLUGIN_MUTEX_LOCK;
12177 if (!*old_plugin_p) {
12178 *old_plugin_p = PL_keyword_plugin;
12179 PL_keyword_plugin = new_plugin;
12181 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12184 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12186 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12188 SAVEI32(PL_lex_brackets);
12189 if (PL_lex_brackets > 100)
12190 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12191 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12192 SAVEI32(PL_lex_allbrackets);
12193 PL_lex_allbrackets = 0;
12194 SAVEI8(PL_lex_fakeeof);
12195 PL_lex_fakeeof = (U8)fakeeof;
12196 if(yyparse(gramtype) && !PL_parser->error_count)
12197 qerror(Perl_mess(aTHX_ "Parse error"));
12200 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12202 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12206 SAVEVPTR(PL_eval_root);
12207 PL_eval_root = NULL;
12208 parse_recdescent(gramtype, fakeeof);
12214 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12216 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12219 if (flags & ~PARSE_OPTIONAL)
12220 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12221 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12222 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12223 if (!PL_parser->error_count)
12224 qerror(Perl_mess(aTHX_ "Parse error"));
12225 exprop = newOP(OP_NULL, 0);
12231 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12233 Parse a Perl arithmetic expression. This may contain operators of precedence
12234 down to the bit shift operators. The expression must be followed (and thus
12235 terminated) either by a comparison or lower-precedence operator or by
12236 something that would normally terminate an expression such as semicolon.
12237 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12238 otherwise it is mandatory. It is up to the caller to ensure that the
12239 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12240 the source of the code to be parsed and the lexical context for the
12243 The op tree representing the expression is returned. If an optional
12244 expression is absent, a null pointer is returned, otherwise the pointer
12247 If an error occurs in parsing or compilation, in most cases a valid op
12248 tree is returned anyway. The error is reflected in the parser state,
12249 normally resulting in a single exception at the top level of parsing
12250 which covers all the compilation errors that occurred. Some compilation
12251 errors, however, will throw an exception immediately.
12257 Perl_parse_arithexpr(pTHX_ U32 flags)
12259 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12263 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12265 Parse a Perl term expression. This may contain operators of precedence
12266 down to the assignment operators. The expression must be followed (and thus
12267 terminated) either by a comma or lower-precedence operator or by
12268 something that would normally terminate an expression such as semicolon.
12269 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12270 otherwise it is mandatory. It is up to the caller to ensure that the
12271 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12272 the source of the code to be parsed and the lexical context for the
12275 The op tree representing the expression is returned. If an optional
12276 expression is absent, a null pointer is returned, otherwise the pointer
12279 If an error occurs in parsing or compilation, in most cases a valid op
12280 tree is returned anyway. The error is reflected in the parser state,
12281 normally resulting in a single exception at the top level of parsing
12282 which covers all the compilation errors that occurred. Some compilation
12283 errors, however, will throw an exception immediately.
12289 Perl_parse_termexpr(pTHX_ U32 flags)
12291 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12295 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12297 Parse a Perl list expression. This may contain operators of precedence
12298 down to the comma operator. The expression must be followed (and thus
12299 terminated) either by a low-precedence logic operator such as C<or> or by
12300 something that would normally terminate an expression such as semicolon.
12301 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12302 otherwise it is mandatory. It is up to the caller to ensure that the
12303 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12304 the source of the code to be parsed and the lexical context for the
12307 The op tree representing the expression is returned. If an optional
12308 expression is absent, a null pointer is returned, otherwise the pointer
12311 If an error occurs in parsing or compilation, in most cases a valid op
12312 tree is returned anyway. The error is reflected in the parser state,
12313 normally resulting in a single exception at the top level of parsing
12314 which covers all the compilation errors that occurred. Some compilation
12315 errors, however, will throw an exception immediately.
12321 Perl_parse_listexpr(pTHX_ U32 flags)
12323 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12327 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12329 Parse a single complete Perl expression. This allows the full
12330 expression grammar, including the lowest-precedence operators such
12331 as C<or>. The expression must be followed (and thus terminated) by a
12332 token that an expression would normally be terminated by: end-of-file,
12333 closing bracketing punctuation, semicolon, or one of the keywords that
12334 signals a postfix expression-statement modifier. If C<flags> has the
12335 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12336 mandatory. It is up to the caller to ensure that the dynamic parser
12337 state (L</PL_parser> et al) is correctly set to reflect the source of
12338 the code to be parsed and the lexical context for the expression.
12340 The op tree representing the expression is returned. If an optional
12341 expression is absent, a null pointer is returned, otherwise the pointer
12344 If an error occurs in parsing or compilation, in most cases a valid op
12345 tree is returned anyway. The error is reflected in the parser state,
12346 normally resulting in a single exception at the top level of parsing
12347 which covers all the compilation errors that occurred. Some compilation
12348 errors, however, will throw an exception immediately.
12354 Perl_parse_fullexpr(pTHX_ U32 flags)
12356 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12360 =for apidoc Amx|OP *|parse_block|U32 flags
12362 Parse a single complete Perl code block. This consists of an opening
12363 brace, a sequence of statements, and a closing brace. The block
12364 constitutes a lexical scope, so C<my> variables and various compile-time
12365 effects can be contained within it. It is up to the caller to ensure
12366 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12367 reflect the source of the code to be parsed and the lexical context for
12370 The op tree representing the code block is returned. This is always a
12371 real op, never a null pointer. It will normally be a C<lineseq> list,
12372 including C<nextstate> or equivalent ops. No ops to construct any kind
12373 of runtime scope are included by virtue of it being a block.
12375 If an error occurs in parsing or compilation, in most cases a valid op
12376 tree (most likely null) is returned anyway. The error is reflected in
12377 the parser state, normally resulting in a single exception at the top
12378 level of parsing which covers all the compilation errors that occurred.
12379 Some compilation errors, however, will throw an exception immediately.
12381 The C<flags> parameter is reserved for future use, and must always
12388 Perl_parse_block(pTHX_ U32 flags)
12391 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12392 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12396 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12398 Parse a single unadorned Perl statement. This may be a normal imperative
12399 statement or a declaration that has compile-time effect. It does not
12400 include any label or other affixture. It is up to the caller to ensure
12401 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12402 reflect the source of the code to be parsed and the lexical context for
12405 The op tree representing the statement is returned. This may be a
12406 null pointer if the statement is null, for example if it was actually
12407 a subroutine definition (which has compile-time side effects). If not
12408 null, it will be ops directly implementing the statement, suitable to
12409 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12410 equivalent op (except for those embedded in a scope contained entirely
12411 within the statement).
12413 If an error occurs in parsing or compilation, in most cases a valid op
12414 tree (most likely null) is returned anyway. The error is reflected in
12415 the parser state, normally resulting in a single exception at the top
12416 level of parsing which covers all the compilation errors that occurred.
12417 Some compilation errors, however, will throw an exception immediately.
12419 The C<flags> parameter is reserved for future use, and must always
12426 Perl_parse_barestmt(pTHX_ U32 flags)
12429 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12430 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12434 =for apidoc Amx|SV *|parse_label|U32 flags
12436 Parse a single label, possibly optional, of the type that may prefix a
12437 Perl statement. It is up to the caller to ensure that the dynamic parser
12438 state (L</PL_parser> et al) is correctly set to reflect the source of
12439 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12440 label is optional, otherwise it is mandatory.
12442 The name of the label is returned in the form of a fresh scalar. If an
12443 optional label is absent, a null pointer is returned.
12445 If an error occurs in parsing, which can only occur if the label is
12446 mandatory, a valid label is returned anyway. The error is reflected in
12447 the parser state, normally resulting in a single exception at the top
12448 level of parsing which covers all the compilation errors that occurred.
12454 Perl_parse_label(pTHX_ U32 flags)
12456 if (flags & ~PARSE_OPTIONAL)
12457 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12459 PL_parser->yychar = yylex();
12460 if (PL_parser->yychar == LABEL) {
12461 char * const lpv = pl_yylval.pval;
12462 STRLEN llen = strlen(lpv);
12463 PL_parser->yychar = YYEMPTY;
12464 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12471 STRLEN wlen, bufptr_pos;
12474 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12476 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12477 if (word_takes_any_delimiter(s, wlen))
12479 bufptr_pos = s - SvPVX(PL_linestr);
12481 lex_read_space(LEX_KEEP_PREVIOUS);
12483 s = SvPVX(PL_linestr) + bufptr_pos;
12484 if (t[0] == ':' && t[1] != ':') {
12485 PL_oldoldbufptr = PL_oldbufptr;
12488 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12492 if (flags & PARSE_OPTIONAL) {
12495 qerror(Perl_mess(aTHX_ "Parse error"));
12496 return newSVpvs("x");
12503 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12505 Parse a single complete Perl statement. This may be a normal imperative
12506 statement or a declaration that has compile-time effect, and may include
12507 optional labels. It is up to the caller to ensure that the dynamic
12508 parser state (L</PL_parser> et al) is correctly set to reflect the source
12509 of the code to be parsed and the lexical context for the statement.
12511 The op tree representing the statement is returned. This may be a
12512 null pointer if the statement is null, for example if it was actually
12513 a subroutine definition (which has compile-time side effects). If not
12514 null, it will be the result of a L</newSTATEOP> call, normally including
12515 a C<nextstate> or equivalent op.
12517 If an error occurs in parsing or compilation, in most cases a valid op
12518 tree (most likely null) is returned anyway. The error is reflected in
12519 the parser state, normally resulting in a single exception at the top
12520 level of parsing which covers all the compilation errors that occurred.
12521 Some compilation errors, however, will throw an exception immediately.
12523 The C<flags> parameter is reserved for future use, and must always
12530 Perl_parse_fullstmt(pTHX_ U32 flags)
12533 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12534 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12538 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12540 Parse a sequence of zero or more Perl statements. These may be normal
12541 imperative statements, including optional labels, or declarations
12542 that have compile-time effect, or any mixture thereof. The statement
12543 sequence ends when a closing brace or end-of-file is encountered in a
12544 place where a new statement could have validly started. It is up to
12545 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12546 is correctly set to reflect the source of the code to be parsed and the
12547 lexical context for the statements.
12549 The op tree representing the statement sequence is returned. This may
12550 be a null pointer if the statements were all null, for example if there
12551 were no statements or if there were only subroutine definitions (which
12552 have compile-time side effects). If not null, it will be a C<lineseq>
12553 list, normally including C<nextstate> or equivalent ops.
12555 If an error occurs in parsing or compilation, in most cases a valid op
12556 tree is returned anyway. The error is reflected in the parser state,
12557 normally resulting in a single exception at the top level of parsing
12558 which covers all the compilation errors that occurred. Some compilation
12559 errors, however, will throw an exception immediately.
12561 The C<flags> parameter is reserved for future use, and must always
12568 Perl_parse_stmtseq(pTHX_ U32 flags)
12573 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12574 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12575 c = lex_peek_unichar(0);
12576 if (c != -1 && c != /*{*/'}')
12577 qerror(Perl_mess(aTHX_ "Parse error"));
12582 * ex: set ts=8 sts=4 sw=4 et: