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_parser->sub_no_recover = FALSE;
2394 PL_parser->sub_error_count = PL_error_count;
2395 PL_lex_state = LEX_INTERPPUSH;
2399 pl_yylval.opval = PL_lex_op;
2409 * Create a new scope to save the lexing state. The scope will be
2410 * ended in S_sublex_done. Returns a '(', starting the function arguments
2411 * to the uc, lc, etc. found before.
2412 * Sets PL_lex_state to LEX_INTERPCONCAT.
2419 const bool is_heredoc = PL_multi_close == '<';
2422 PL_lex_state = PL_parser->lex_super_state;
2423 SAVEI8(PL_lex_dojoin);
2424 SAVEI32(PL_lex_brackets);
2425 SAVEI32(PL_lex_allbrackets);
2426 SAVEI32(PL_lex_formbrack);
2427 SAVEI8(PL_lex_fakeeof);
2428 SAVEI32(PL_lex_casemods);
2429 SAVEI32(PL_lex_starts);
2430 SAVEI8(PL_lex_state);
2431 SAVESPTR(PL_lex_repl);
2432 SAVEVPTR(PL_lex_inpat);
2433 SAVEI16(PL_lex_inwhat);
2436 SAVECOPLINE(PL_curcop);
2437 SAVEI32(PL_multi_end);
2438 SAVEI32(PL_parser->herelines);
2439 PL_parser->herelines = 0;
2441 SAVEIV(PL_multi_close);
2442 SAVEPPTR(PL_bufptr);
2443 SAVEPPTR(PL_bufend);
2444 SAVEPPTR(PL_oldbufptr);
2445 SAVEPPTR(PL_oldoldbufptr);
2446 SAVEPPTR(PL_last_lop);
2447 SAVEPPTR(PL_last_uni);
2448 SAVEPPTR(PL_linestart);
2449 SAVESPTR(PL_linestr);
2450 SAVEGENERICPV(PL_lex_brackstack);
2451 SAVEGENERICPV(PL_lex_casestack);
2452 SAVEGENERICPV(PL_parser->lex_shared);
2453 SAVEBOOL(PL_parser->lex_re_reparsing);
2454 SAVEI32(PL_copline);
2456 /* The here-doc parser needs to be able to peek into outer lexing
2457 scopes to find the body of the here-doc. So we put PL_linestr and
2458 PL_bufptr into lex_shared, to ‘share’ those values.
2460 PL_parser->lex_shared->ls_linestr = PL_linestr;
2461 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2463 PL_linestr = PL_lex_stuff;
2464 PL_lex_repl = PL_parser->lex_sub_repl;
2465 PL_lex_stuff = NULL;
2466 PL_parser->lex_sub_repl = NULL;
2468 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2469 set for an inner quote-like operator and then an error causes scope-
2470 popping. We must not have a PL_lex_stuff value left dangling, as
2471 that breaks assumptions elsewhere. See bug #123617. */
2472 SAVEGENERICSV(PL_lex_stuff);
2473 SAVEGENERICSV(PL_parser->lex_sub_repl);
2475 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2476 = SvPVX(PL_linestr);
2477 PL_bufend += SvCUR(PL_linestr);
2478 PL_last_lop = PL_last_uni = NULL;
2479 SAVEFREESV(PL_linestr);
2480 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2482 PL_lex_dojoin = FALSE;
2483 PL_lex_brackets = PL_lex_formbrack = 0;
2484 PL_lex_allbrackets = 0;
2485 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2486 Newx(PL_lex_brackstack, 120, char);
2487 Newx(PL_lex_casestack, 12, char);
2488 PL_lex_casemods = 0;
2489 *PL_lex_casestack = '\0';
2491 PL_lex_state = LEX_INTERPCONCAT;
2493 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2494 PL_copline = NOLINE;
2496 Newxz(shared, 1, LEXSHARED);
2497 shared->ls_prev = PL_parser->lex_shared;
2498 PL_parser->lex_shared = shared;
2500 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2501 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2502 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2503 PL_lex_inpat = PL_parser->lex_sub_op;
2505 PL_lex_inpat = NULL;
2507 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2508 PL_in_eval &= ~EVAL_RE_REPARSING;
2515 * Restores lexer state after a S_sublex_push.
2521 if (!PL_lex_starts++) {
2522 SV * const sv = newSVpvs("");
2523 if (SvUTF8(PL_linestr))
2525 PL_expect = XOPERATOR;
2526 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2530 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2531 PL_lex_state = LEX_INTERPCASEMOD;
2535 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2536 assert(PL_lex_inwhat != OP_TRANSR);
2538 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2539 PL_linestr = PL_lex_repl;
2541 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2542 PL_bufend += SvCUR(PL_linestr);
2543 PL_last_lop = PL_last_uni = NULL;
2544 PL_lex_dojoin = FALSE;
2545 PL_lex_brackets = 0;
2546 PL_lex_allbrackets = 0;
2547 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2548 PL_lex_casemods = 0;
2549 *PL_lex_casestack = '\0';
2551 if (SvEVALED(PL_lex_repl)) {
2552 PL_lex_state = LEX_INTERPNORMAL;
2554 /* we don't clear PL_lex_repl here, so that we can check later
2555 whether this is an evalled subst; that means we rely on the
2556 logic to ensure sublex_done() is called again only via the
2557 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2560 PL_lex_state = LEX_INTERPCONCAT;
2563 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2564 CopLINE(PL_curcop) +=
2565 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2566 + PL_parser->herelines;
2567 PL_parser->herelines = 0;
2572 const line_t l = CopLINE(PL_curcop);
2574 if (PL_parser->sub_error_count != PL_error_count) {
2575 const char * const name = OutCopFILE(PL_curcop);
2576 if (PL_parser->sub_no_recover) {
2577 const char * msg = "";
2581 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
2584 abort_execution(msg, name);
2588 if (PL_multi_close == '<')
2589 PL_parser->herelines += l - PL_multi_end;
2590 PL_bufend = SvPVX(PL_linestr);
2591 PL_bufend += SvCUR(PL_linestr);
2592 PL_expect = XOPERATOR;
2598 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2600 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2601 * interior, hence to the "}". Finds what the name resolves to, returning
2602 * an SV* containing it; NULL if no valid one found */
2604 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2611 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2613 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2616 SvREFCNT_dec_NN(res);
2617 /* diag_listed_as: Unknown charname '%s' */
2618 yyerror("Unknown charname ''");
2622 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2623 /* include the <}> */
2624 e - backslash_ptr + 1);
2626 SvREFCNT_dec_NN(res);
2630 /* See if the charnames handler is the Perl core's, and if so, we can skip
2631 * the validation needed for a user-supplied one, as Perl's does its own
2633 table = GvHV(PL_hintgv); /* ^H */
2634 cvp = hv_fetchs(table, "charnames", FALSE);
2635 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2636 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2638 const char * const name = HvNAME(stash);
2639 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2644 /* Here, it isn't Perl's charname handler. We can't rely on a
2645 * user-supplied handler to validate the input name. For non-ut8 input,
2646 * look to see that the first character is legal. Then loop through the
2647 * rest checking that each is a continuation */
2649 /* This code makes the reasonable assumption that the only Latin1-range
2650 * characters that begin a character name alias are alphabetic, otherwise
2651 * would have to create a isCHARNAME_BEGIN macro */
2654 if (! isALPHAU(*s)) {
2659 if (! isCHARNAME_CONT(*s)) {
2662 if (*s == ' ' && *(s-1) == ' ') {
2669 /* Similarly for utf8. For invariants can check directly; for other
2670 * Latin1, can calculate their code point and check; otherwise use a
2672 if (UTF8_IS_INVARIANT(*s)) {
2673 if (! isALPHAU(*s)) {
2677 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2678 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2684 if (! PL_utf8_charname_begin) {
2685 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2686 PL_utf8_charname_begin = _core_swash_init("utf8",
2687 "_Perl_Charname_Begin",
2689 1, 0, NULL, &flags);
2691 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2698 if (UTF8_IS_INVARIANT(*s)) {
2699 if (! isCHARNAME_CONT(*s)) {
2702 if (*s == ' ' && *(s-1) == ' ') {
2707 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2708 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2715 if (! PL_utf8_charname_continue) {
2716 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2717 PL_utf8_charname_continue = _core_swash_init("utf8",
2718 "_Perl_Charname_Continue",
2720 1, 0, NULL, &flags);
2722 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2729 if (*(s-1) == ' ') {
2730 /* diag_listed_as: charnames alias definitions may not contain
2731 trailing white-space; marked by <-- HERE in %s
2735 "charnames alias definitions may not contain trailing "
2736 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2737 (int)(s - backslash_ptr + 1), backslash_ptr,
2738 (int)(e - s + 1), s + 1
2740 UTF ? SVf_UTF8 : 0);
2744 if (SvUTF8(res)) { /* Don't accept malformed input */
2745 const U8* first_bad_char_loc;
2747 const char* const str = SvPV_const(res, len);
2748 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2749 &first_bad_char_loc)))
2751 _force_out_malformed_utf8_message(first_bad_char_loc,
2752 (U8 *) PL_parser->bufend,
2754 0 /* 0 means don't die */ );
2755 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2756 immediately after '%s' */
2759 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2760 (int) (e - backslash_ptr + 1), backslash_ptr,
2761 (int) ((char *) first_bad_char_loc - str), str
2772 /* The final %.*s makes sure that should the trailing NUL be missing
2773 * that this print won't run off the end of the string */
2774 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2778 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2779 (int)(s - backslash_ptr + 1), backslash_ptr,
2780 (int)(e - s + 1), s + 1
2782 UTF ? SVf_UTF8 : 0);
2787 /* diag_listed_as: charnames alias definitions may not contain a
2788 sequence of multiple spaces; marked by <-- HERE
2792 "charnames alias definitions may not contain a sequence of "
2793 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2794 (int)(s - backslash_ptr + 1), backslash_ptr,
2795 (int)(e - s + 1), s + 1
2797 UTF ? SVf_UTF8 : 0);
2804 Extracts the next constant part of a pattern, double-quoted string,
2805 or transliteration. This is terrifying code.
2807 For example, in parsing the double-quoted string "ab\x63$d", it would
2808 stop at the '$' and return an OP_CONST containing 'abc'.
2810 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2811 processing a pattern (PL_lex_inpat is true), a transliteration
2812 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2814 Returns a pointer to the character scanned up to. If this is
2815 advanced from the start pointer supplied (i.e. if anything was
2816 successfully parsed), will leave an OP_CONST for the substring scanned
2817 in pl_yylval. Caller must intuit reason for not parsing further
2818 by looking at the next characters herself.
2822 \N{FOO} => \N{U+hex_for_character_FOO}
2823 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2826 all other \-char, including \N and \N{ apart from \N{ABC}
2829 @ and $ where it appears to be a var, but not for $ as tail anchor
2833 In transliterations:
2834 characters are VERY literal, except for - not at the start or end
2835 of the string, which indicates a range. However some backslash sequences
2836 are recognized: \r, \n, and the like
2837 \007 \o{}, \x{}, \N{}
2838 If all elements in the transliteration are below 256,
2839 scan_const expands the range to the full set of intermediate
2840 characters. If the range is in utf8, the hyphen is replaced with
2841 a certain range mark which will be handled by pmtrans() in op.c.
2843 In double-quoted strings:
2845 all those recognized in transliterations
2846 deprecated backrefs: \1 (in substitution replacements)
2847 case and quoting: \U \Q \E
2850 scan_const does *not* construct ops to handle interpolated strings.
2851 It stops processing as soon as it finds an embedded $ or @ variable
2852 and leaves it to the caller to work out what's going on.
2854 embedded arrays (whether in pattern or not) could be:
2855 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2857 $ in double-quoted strings must be the symbol of an embedded scalar.
2859 $ in pattern could be $foo or could be tail anchor. Assumption:
2860 it's a tail anchor if $ is the last thing in the string, or if it's
2861 followed by one of "()| \r\n\t"
2863 \1 (backreferences) are turned into $1 in substitutions
2865 The structure of the code is
2866 while (there's a character to process) {
2867 handle transliteration ranges
2868 skip regexp comments /(?#comment)/ and codes /(?{code})/
2869 skip #-initiated comments in //x patterns
2870 check for embedded arrays
2871 check for embedded scalars
2873 deprecate \1 in substitution replacements
2874 handle string-changing backslashes \l \U \Q \E, etc.
2875 switch (what was escaped) {
2876 handle \- in a transliteration (becomes a literal -)
2877 if a pattern and not \N{, go treat as regular character
2878 handle \132 (octal characters)
2879 handle \x15 and \x{1234} (hex characters)
2880 handle \N{name} (named characters, also \N{3,5} in a pattern)
2881 handle \cV (control characters)
2882 handle printf-style backslashes (\f, \r, \n, etc)
2885 } (end if backslash)
2886 handle regular character
2887 } (end while character to read)
2892 S_scan_const(pTHX_ char *start)
2894 char *send = PL_bufend; /* end of the constant */
2895 SV *sv = newSV(send - start); /* sv for the constant. See note below
2897 char *s = start; /* start of the constant */
2898 char *d = SvPVX(sv); /* destination for copies */
2899 bool dorange = FALSE; /* are we in a translit range? */
2900 bool didrange = FALSE; /* did we just finish a range? */
2901 bool in_charclass = FALSE; /* within /[...]/ */
2902 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2903 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2904 UTF8? But, this can show as true
2905 when the source isn't utf8, as for
2906 example when it is entirely composed
2908 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2909 number of characters found so far
2910 that will expand (into 2 bytes)
2911 should we have to convert to
2913 SV *res; /* result from charnames */
2914 STRLEN offset_to_max = 0; /* The offset in the output to where the range
2915 high-end character is temporarily placed */
2917 /* Does something require special handling in tr/// ? This avoids extra
2918 * work in a less likely case. As such, khw didn't feel it was worth
2919 * adding any branches to the more mainline code to handle this, which
2920 * means that this doesn't get set in some circumstances when things like
2921 * \x{100} get expanded out. As a result there needs to be extra testing
2922 * done in the tr code */
2923 bool has_above_latin1 = FALSE;
2925 /* Note on sizing: The scanned constant is placed into sv, which is
2926 * initialized by newSV() assuming one byte of output for every byte of
2927 * input. This routine expects newSV() to allocate an extra byte for a
2928 * trailing NUL, which this routine will append if it gets to the end of
2929 * the input. There may be more bytes of input than output (eg., \N{LATIN
2930 * CAPITAL LETTER A}), or more output than input if the constant ends up
2931 * recoded to utf8, but each time a construct is found that might increase
2932 * the needed size, SvGROW() is called. Its size parameter each time is
2933 * based on the best guess estimate at the time, namely the length used so
2934 * far, plus the length the current construct will occupy, plus room for
2935 * the trailing NUL, plus one byte for every input byte still unscanned */
2937 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2940 int backslash_N = 0; /* ? was the character from \N{} */
2941 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2942 platform-specific like \x65 */
2945 PERL_ARGS_ASSERT_SCAN_CONST;
2947 assert(PL_lex_inwhat != OP_TRANSR);
2948 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2949 /* If we are doing a trans and we know we want UTF8 set expectation */
2950 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2951 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2954 /* Protect sv from errors and fatal warnings. */
2955 ENTER_with_name("scan_const");
2959 || dorange /* Handle tr/// range at right edge of input */
2962 /* get transliterations out of the way (they're most literal) */
2963 if (PL_lex_inwhat == OP_TRANS) {
2965 /* But there isn't any special handling necessary unless there is a
2966 * range, so for most cases we just drop down and handle the value
2967 * as any other. There are two exceptions.
2969 * 1. A hyphen indicates that we are actually going to have a
2970 * range. In this case, skip the '-', set a flag, then drop
2971 * down to handle what should be the end range value.
2972 * 2. After we've handled that value, the next time through, that
2973 * flag is set and we fix up the range.
2975 * Ranges entirely within Latin1 are expanded out entirely, in
2976 * order to make the transliteration a simple table look-up.
2977 * Ranges that extend above Latin1 have to be done differently, so
2978 * there is no advantage to expanding them here, so they are
2979 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2980 * signifies a hyphen without any possible ambiguity. On EBCDIC
2981 * machines, if the range is expressed as Unicode, the Latin1
2982 * portion is expanded out even if the range extends above
2983 * Latin1. This is because each code point in it has to be
2984 * processed here individually to get its native translation */
2988 /* Here, we don't think we're in a range. If the new character
2989 * is not a hyphen; or if it is a hyphen, but it's too close to
2990 * either edge to indicate a range, or if we haven't output any
2991 * characters yet then it's a regular character. */
2992 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
2994 /* A regular character. Process like any other, but first
2995 * clear any flags */
2999 non_portable_endpoint = 0;
3002 /* The tests here for being above Latin1 and similar ones
3003 * in the following 'else' suffice to find all such
3004 * occurences in the constant, except those added by a
3005 * backslash escape sequence, like \x{100}. Mostly, those
3006 * set 'has_above_latin1' as appropriate */
3007 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3008 has_above_latin1 = TRUE;
3011 /* Drops down to generic code to process current byte */
3013 else { /* Is a '-' in the context where it means a range */
3014 if (didrange) { /* Something like y/A-C-Z// */
3015 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3021 s++; /* Skip past the hyphen */
3023 /* d now points to where the end-range character will be
3024 * placed. Save it so won't have to go finding it later,
3025 * and drop down to get that character. (Actually we
3026 * instead save the offset, to handle the case where a
3027 * realloc in the meantime could change the actual
3028 * pointer). We'll finish processing the range the next
3029 * time through the loop */
3030 offset_to_max = d - SvPVX_const(sv);
3032 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3033 has_above_latin1 = TRUE;
3036 /* Drops down to generic code to process current byte */
3038 } /* End of not a range */
3040 /* Here we have parsed a range. Now must handle it. At this
3042 * 'sv' is a SV* that contains the output string we are
3043 * constructing. The final two characters in that string
3044 * are the range start and range end, in order.
3045 * 'd' points to just beyond the range end in the 'sv' string,
3046 * where we would next place something
3047 * 'offset_to_max' is the offset in 'sv' at which the character
3048 * (the range's maximum end point) before 'd' begins.
3050 char * max_ptr = SvPVX(sv) + offset_to_max;
3053 IV range_max; /* last character in range */
3055 Size_t offset_to_min = 0;
3058 bool convert_unicode;
3059 IV real_range_max = 0;
3061 /* Get the code point values of the range ends. */
3063 /* We know the utf8 is valid, because we just constructed
3064 * it ourselves in previous loop iterations */
3065 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3066 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3067 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3069 /* This compensates for not all code setting
3070 * 'has_above_latin1', so that we don't skip stuff that
3071 * should be executed */
3072 if (range_max > 255) {
3073 has_above_latin1 = TRUE;
3077 min_ptr = max_ptr - 1;
3078 range_min = * (U8*) min_ptr;
3079 range_max = * (U8*) max_ptr;
3082 /* If the range is just a single code point, like tr/a-a/.../,
3083 * that code point is already in the output, twice. We can
3084 * just back up over the second instance and avoid all the rest
3085 * of the work. But if it is a variant character, it's been
3086 * counted twice, so decrement. (This unlikely scenario is
3087 * special cased, like the one for a range of 2 code points
3088 * below, only because the main-line code below needs a range
3089 * of 3 or more to work without special casing. Might as well
3090 * get it out of the way now.) */
3091 if (UNLIKELY(range_max == range_min)) {
3093 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3094 utf8_variant_count--;
3100 /* On EBCDIC platforms, we may have to deal with portable
3101 * ranges. These happen if at least one range endpoint is a
3102 * Unicode value (\N{...}), or if the range is a subset of
3103 * [A-Z] or [a-z], and both ends are literal characters,
3104 * like 'A', and not like \x{C1} */
3106 cBOOL(backslash_N) /* \N{} forces Unicode,
3107 hence portable range */
3108 || ( ! non_portable_endpoint
3109 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3110 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3111 if (convert_unicode) {
3113 /* Special handling is needed for these portable ranges.
3114 * They are defined to be in Unicode terms, which includes
3115 * all the Unicode code points between the end points.
3116 * Convert to Unicode to get the Unicode range. Later we
3117 * will convert each code point in the range back to
3119 range_min = NATIVE_TO_UNI(range_min);
3120 range_max = NATIVE_TO_UNI(range_max);
3124 if (range_min > range_max) {
3126 if (convert_unicode) {
3127 /* Need to convert back to native for meaningful
3128 * messages for this platform */
3129 range_min = UNI_TO_NATIVE(range_min);
3130 range_max = UNI_TO_NATIVE(range_max);
3133 /* Use the characters themselves for the error message if
3134 * ASCII printables; otherwise some visible representation
3136 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3138 "Invalid range \"%c-%c\" in transliteration operator",
3139 (char)range_min, (char)range_max);
3142 else if (convert_unicode) {
3143 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3145 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3146 UVXf "}\" in transliteration operator",
3147 range_min, range_max);
3151 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3153 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3154 " in transliteration operator",
3155 range_min, range_max);
3159 /* If the range is exactly two code points long, they are
3160 * already both in the output */
3161 if (UNLIKELY(range_min + 1 == range_max)) {
3165 /* Here the range contains at least 3 code points */
3169 /* If everything in the transliteration is below 256, we
3170 * can avoid special handling later. A translation table
3171 * for each of those bytes is created by op.c. So we
3172 * expand out all ranges to their constituent code points.
3173 * But if we've encountered something above 255, the
3174 * expanding won't help, so skip doing that. But if it's
3175 * EBCDIC, we may have to look at each character below 256
3176 * if we have to convert to/from Unicode values */
3177 if ( has_above_latin1
3179 && (range_min > 255 || ! convert_unicode)
3182 /* Move the high character one byte to the right; then
3183 * insert between it and the range begin, an illegal
3184 * byte which serves to indicate this is a range (using
3185 * a '-' would be ambiguous). */
3187 while (e-- > max_ptr) {
3190 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3194 /* Here, we're going to expand out the range. For EBCDIC
3195 * the range can extend above 255 (not so in ASCII), so
3196 * for EBCDIC, split it into the parts above and below
3199 if (range_max > 255) {
3200 real_range_max = range_max;
3206 /* Here we need to expand out the string to contain each
3207 * character in the range. Grow the output to handle this.
3208 * For non-UTF8, we need a byte for each code point in the
3209 * range, minus the three that we've already allocated for: the
3210 * hyphen, the min, and the max. For UTF-8, we need this
3211 * plus an extra byte for each code point that occupies two
3212 * bytes (is variant) when in UTF-8 (except we've already
3213 * allocated for the end points, including if they are
3214 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3215 * platforms, it's easy to calculate a precise number. To
3216 * start, we count the variants in the range, which we need
3217 * elsewhere in this function anyway. (For the case where it
3218 * isn't easy to calculate, 'extras' has been initialized to 0,
3219 * and the calculation is done in a loop further down.) */
3221 if (convert_unicode)
3224 /* This is executed unconditionally on ASCII, and for
3225 * Unicode ranges on EBCDIC. Under these conditions, all
3226 * code points above a certain value are variant; and none
3227 * under that value are. We just need to find out how much
3228 * of the range is above that value. We don't count the
3229 * end points here, as they will already have been counted
3230 * as they were parsed. */
3231 if (range_min >= UTF_CONTINUATION_MARK) {
3233 /* The whole range is made up of variants */
3234 extras = (range_max - 1) - (range_min + 1) + 1;
3236 else if (range_max >= UTF_CONTINUATION_MARK) {
3238 /* Only the higher portion of the range is variants */
3239 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3242 utf8_variant_count += extras;
3245 /* The base growth is the number of code points in the range,
3246 * not including the endpoints, which have already been sized
3247 * for (and output). We don't subtract for the hyphen, as it
3248 * has been parsed but not output, and the SvGROW below is
3249 * based only on what's been output plus what's left to parse.
3251 grow = (range_max - 1) - (range_min + 1) + 1;
3255 /* In some cases in EBCDIC, we haven't yet calculated a
3256 * precise amount needed for the UTF-8 variants. Just
3257 * assume the worst case, that everything will expand by a
3259 if (! convert_unicode) {
3265 /* Otherwise we know exactly how many variants there
3266 * are in the range. */
3271 /* Grow, but position the output to overwrite the range min end
3272 * point, because in some cases we overwrite that */
3273 SvCUR_set(sv, d - SvPVX_const(sv));
3274 offset_to_min = min_ptr - SvPVX_const(sv);
3276 /* See Note on sizing above. */
3277 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3280 + 1 /* Trailing NUL */ );
3282 /* Now, we can expand out the range. */
3284 if (convert_unicode) {
3287 /* Recall that the min and max are now in Unicode terms, so
3288 * we have to convert each character to its native
3291 for (i = range_min; i <= range_max; i++) {
3292 append_utf8_from_native_byte(
3293 LATIN1_TO_NATIVE((U8) i),
3298 for (i = range_min; i <= range_max; i++) {
3299 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3305 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3307 /* Here, no conversions are necessary, which means that the
3308 * first character in the range is already in 'd' and
3309 * valid, so we can skip overwriting it */
3313 for (i = range_min + 1; i <= range_max; i++) {
3314 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3320 assert(range_min + 1 <= range_max);
3321 for (i = range_min + 1; i < range_max; i++) {
3323 /* In this case on EBCDIC, we haven't calculated
3324 * the variants. Do it here, as we go along */
3325 if (! UVCHR_IS_INVARIANT(i)) {
3326 utf8_variant_count++;
3332 /* The range_max is done outside the loop so as to
3333 * avoid having to special case not incrementing
3334 * 'utf8_variant_count' on EBCDIC (it's already been
3335 * counted when originally parsed) */
3336 *d++ = (char) range_max;
3341 /* If the original range extended above 255, add in that
3343 if (real_range_max) {
3344 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3345 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3346 if (real_range_max > 0x100) {
3347 if (real_range_max > 0x101) {
3348 *d++ = (char) ILLEGAL_UTF8_BYTE;
3350 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3356 /* mark the range as done, and continue */
3360 non_portable_endpoint = 0;
3364 } /* End of is a range */
3365 } /* End of transliteration. Joins main code after these else's */
3366 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3369 while (s1 >= start && *s1-- == '\\')
3372 in_charclass = TRUE;
3374 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3377 while (s1 >= start && *s1-- == '\\')
3380 in_charclass = FALSE;
3382 /* skip for regexp comments /(?#comment)/, except for the last
3383 * char, which will be done separately. Stop on (?{..}) and
3385 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3387 while (s+1 < send && *s != ')')
3390 else if (!PL_lex_casemods
3391 && ( s[2] == '{' /* This should match regcomp.c */
3392 || (s[2] == '?' && s[3] == '{')))
3397 /* likewise skip #-initiated comments in //x patterns */
3401 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3403 while (s < send && *s != '\n')
3406 /* no further processing of single-quoted regex */
3407 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3408 goto default_action;
3410 /* check for embedded arrays
3411 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3413 else if (*s == '@' && s[1]) {
3415 ? isIDFIRST_utf8_safe(s+1, send)
3416 : isWORDCHAR_A(s[1]))
3420 if (strchr(":'{$", s[1]))
3422 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3423 break; /* in regexp, neither @+ nor @- are interpolated */
3425 /* check for embedded scalars. only stop if we're sure it's a
3427 else if (*s == '$') {
3428 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3430 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3432 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3433 "Possible unintended interpolation of $\\ in regex");
3435 break; /* in regexp, $ might be tail anchor */
3439 /* End of else if chain - OP_TRANS rejoin rest */
3441 if (UNLIKELY(s >= send)) {
3447 if (*s == '\\' && s+1 < send) {
3448 char* e; /* Can be used for ending '}', etc. */
3452 /* warn on \1 - \9 in substitution replacements, but note that \11
3453 * is an octal; and \19 is \1 followed by '9' */
3454 if (PL_lex_inwhat == OP_SUBST
3460 /* diag_listed_as: \%d better written as $%d */
3461 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3466 /* string-change backslash escapes */
3467 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3471 /* In a pattern, process \N, but skip any other backslash escapes.
3472 * This is because we don't want to translate an escape sequence
3473 * into a meta symbol and have the regex compiler use the meta
3474 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3475 * in spite of this, we do have to process \N here while the proper
3476 * charnames handler is in scope. See bugs #56444 and #62056.
3478 * There is a complication because \N in a pattern may also stand
3479 * for 'match a non-nl', and not mean a charname, in which case its
3480 * processing should be deferred to the regex compiler. To be a
3481 * charname it must be followed immediately by a '{', and not look
3482 * like \N followed by a curly quantifier, i.e., not something like
3483 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3485 else if (PL_lex_inpat
3488 || regcurly(s + 1)))
3491 goto default_action;
3497 if ((isALPHANUMERIC(*s)))
3498 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3499 "Unrecognized escape \\%c passed through",
3501 /* default action is to copy the quoted character */
3502 goto default_action;
3505 /* eg. \132 indicates the octal constant 0132 */
3506 case '0': case '1': case '2': case '3':
3507 case '4': case '5': case '6': case '7':
3509 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3511 uv = grok_oct(s, &len, &flags, NULL);
3513 if (len < 3 && s < send && isDIGIT(*s)
3514 && ckWARN(WARN_MISC))
3516 Perl_warner(aTHX_ packWARN(WARN_MISC),
3517 "%s", form_short_octal_warning(s, len));
3520 goto NUM_ESCAPE_INSERT;
3522 /* eg. \o{24} indicates the octal constant \024 */
3527 bool valid = grok_bslash_o(&s, PL_bufend,
3529 TRUE, /* Output warning */
3530 FALSE, /* Not strict */
3531 TRUE, /* Output warnings for
3536 uv = 0; /* drop through to ensure range ends are set */
3538 goto NUM_ESCAPE_INSERT;
3541 /* eg. \x24 indicates the hex constant 0x24 */
3546 bool valid = grok_bslash_x(&s, PL_bufend,
3548 TRUE, /* Output warning */
3549 FALSE, /* Not strict */
3550 TRUE, /* Output warnings for
3555 uv = 0; /* drop through to ensure range ends are set */
3560 /* Insert oct or hex escaped character. */
3562 /* Here uv is the ordinal of the next character being added */
3563 if (UVCHR_IS_INVARIANT(uv)) {
3567 if (!has_utf8 && uv > 255) {
3569 /* Here, 'uv' won't fit unless we convert to UTF-8.
3570 * If we've only seen invariants so far, all we have to
3571 * do is turn on the flag */
3572 if (utf8_variant_count == 0) {
3576 SvCUR_set(sv, d - SvPVX_const(sv));
3580 sv_utf8_upgrade_flags_grow(
3582 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3584 /* Since we're having to grow here,
3585 * make sure we have enough room for
3586 * this escape and a NUL, so the
3587 * code immediately below won't have
3588 * to actually grow again */
3590 + (STRLEN)(send - s) + 1);
3591 d = SvPVX(sv) + SvCUR(sv);
3594 has_above_latin1 = TRUE;
3600 utf8_variant_count++;
3603 /* Usually, there will already be enough room in 'sv'
3604 * since such escapes are likely longer than any UTF-8
3605 * sequence they can end up as. This isn't the case on
3606 * EBCDIC where \x{40000000} contains 12 bytes, and the
3607 * UTF-8 for it contains 14. And, we have to allow for
3608 * a trailing NUL. It probably can't happen on ASCII
3609 * platforms, but be safe. See Note on sizing above. */
3610 const STRLEN needed = d - SvPVX(sv)
3614 if (UNLIKELY(needed > SvLEN(sv))) {
3615 SvCUR_set(sv, d - SvPVX_const(sv));
3616 d = SvCUR(sv) + SvGROW(sv, needed);
3619 d = (char*)uvchr_to_utf8((U8*)d, uv);
3620 if (PL_lex_inwhat == OP_TRANS
3621 && PL_parser->lex_sub_op)
3623 PL_parser->lex_sub_op->op_private |=
3624 (PL_lex_repl ? OPpTRANS_FROM_UTF
3630 non_portable_endpoint++;
3635 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3636 * named character, like \N{LATIN SMALL LETTER A}, or a named
3637 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3638 * GRAVE} (except y/// can't handle the latter, croaking). For
3639 * convenience all three forms are referred to as "named
3640 * characters" below.
3642 * For patterns, \N also can mean to match a non-newline. Code
3643 * before this 'switch' statement should already have handled
3644 * this situation, and hence this code only has to deal with
3645 * the named character cases.
3647 * For non-patterns, the named characters are converted to
3648 * their string equivalents. In patterns, named characters are
3649 * not converted to their ultimate forms for the same reasons
3650 * that other escapes aren't (mainly that the ultimate
3651 * character could be considered a meta-symbol by the regex
3652 * compiler). Instead, they are converted to the \N{U+...}
3653 * form to get the value from the charnames that is in effect
3654 * right now, while preserving the fact that it was a named
3655 * character, so that the regex compiler knows this.
3657 * The structure of this section of code (besides checking for
3658 * errors and upgrading to utf8) is:
3659 * If the named character is of the form \N{U+...}, pass it
3660 * through if a pattern; otherwise convert the code point
3662 * Otherwise must be some \N{NAME}: convert to
3663 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3665 * Transliteration is an exception. The conversion to utf8 is
3666 * only done if the code point requires it to be representable.
3668 * Here, 's' points to the 'N'; the test below is guaranteed to
3669 * succeed if we are being called on a pattern, as we already
3670 * know from a test above that the next character is a '{'. A
3671 * non-pattern \N must mean 'named character', which requires
3675 yyerror("Missing braces on \\N{}");
3681 /* If there is no matching '}', it is an error. */
3682 if (! (e = (char *) memchr(s, '}', send - s))) {
3683 if (! PL_lex_inpat) {
3684 yyerror("Missing right brace on \\N{}");
3686 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3688 yyquit(); /* Have exhausted the input. */
3691 /* Here it looks like a named character */
3693 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3694 s += 2; /* Skip to next char after the 'U+' */
3697 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3698 /* Check the syntax. */
3701 if (!isXDIGIT(*s)) {
3704 "Invalid hexadecimal number in \\N{U+...}"
3713 else if ((*s == '.' || *s == '_')
3719 /* Pass everything through unchanged.
3720 * +1 is for the '}' */
3721 Copy(orig_s, d, e - orig_s + 1, char);
3722 d += e - orig_s + 1;
3724 else { /* Not a pattern: convert the hex to string */
3725 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3726 | PERL_SCAN_SILENT_ILLDIGIT
3727 | PERL_SCAN_DISALLOW_PREFIX;
3729 uv = grok_hex(s, &len, &flags, NULL);
3730 if (len == 0 || (len != (STRLEN)(e - s)))
3733 /* For non-tr///, if the destination is not in utf8,
3734 * unconditionally recode it to be so. This is
3735 * because \N{} implies Unicode semantics, and scalars
3736 * have to be in utf8 to guarantee those semantics.
3737 * tr/// doesn't care about Unicode rules, so no need
3738 * there to upgrade to UTF-8 for small enough code
3740 if (! has_utf8 && ( uv > 0xFF
3741 || PL_lex_inwhat != OP_TRANS))
3743 /* See Note on sizing above. */
3744 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3746 SvCUR_set(sv, d - SvPVX_const(sv));
3750 if (utf8_variant_count == 0) {
3752 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3755 sv_utf8_upgrade_flags_grow(
3757 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3759 d = SvPVX(sv) + SvCUR(sv);
3763 has_above_latin1 = TRUE;
3766 /* Add the (Unicode) code point to the output. */
3767 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3768 *d++ = (char) LATIN1_TO_NATIVE(uv);
3771 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3775 else /* Here is \N{NAME} but not \N{U+...}. */
3776 if ((res = get_and_check_backslash_N_name(s, e)))
3779 const char *str = SvPV_const(res, len);
3782 if (! len) { /* The name resolved to an empty string */
3783 Copy("\\N{}", d, 4, char);
3787 /* In order to not lose information for the regex
3788 * compiler, pass the result in the specially made
3789 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3790 * the code points in hex of each character
3791 * returned by charnames */
3793 const char *str_end = str + len;
3794 const STRLEN off = d - SvPVX_const(sv);
3796 if (! SvUTF8(res)) {
3797 /* For the non-UTF-8 case, we can determine the
3798 * exact length needed without having to parse
3799 * through the string. Each character takes up
3800 * 2 hex digits plus either a trailing dot or
3802 const char initial_text[] = "\\N{U+";
3803 const STRLEN initial_len = sizeof(initial_text)
3805 d = off + SvGROW(sv, off
3808 /* +1 for trailing NUL */
3811 + (STRLEN)(send - e));
3812 Copy(initial_text, d, initial_len, char);
3814 while (str < str_end) {
3817 my_snprintf(hex_string,
3821 /* The regex compiler is
3822 * expecting Unicode, not
3824 NATIVE_TO_LATIN1(*str));
3825 PERL_MY_SNPRINTF_POST_GUARD(len,
3826 sizeof(hex_string));
3827 Copy(hex_string, d, 3, char);
3831 d--; /* Below, we will overwrite the final
3832 dot with a right brace */
3835 STRLEN char_length; /* cur char's byte length */
3837 /* and the number of bytes after this is
3838 * translated into hex digits */
3839 STRLEN output_length;
3841 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3842 * for max('U+', '.'); and 1 for NUL */
3843 char hex_string[2 * UTF8_MAXBYTES + 5];
3845 /* Get the first character of the result. */
3846 U32 uv = utf8n_to_uvchr((U8 *) str,
3850 /* Convert first code point to Unicode hex,
3851 * including the boiler plate before it. */
3853 my_snprintf(hex_string, sizeof(hex_string),
3855 (unsigned int) NATIVE_TO_UNI(uv));
3857 /* Make sure there is enough space to hold it */
3858 d = off + SvGROW(sv, off
3860 + (STRLEN)(send - e)
3861 + 2); /* '}' + NUL */
3863 Copy(hex_string, d, output_length, char);
3866 /* For each subsequent character, append dot and
3867 * its Unicode code point in hex */
3868 while ((str += char_length) < str_end) {
3869 const STRLEN off = d - SvPVX_const(sv);
3870 U32 uv = utf8n_to_uvchr((U8 *) str,
3875 my_snprintf(hex_string,
3878 (unsigned int) NATIVE_TO_UNI(uv));
3880 d = off + SvGROW(sv, off
3882 + (STRLEN)(send - e)
3883 + 2); /* '}' + NUL */
3884 Copy(hex_string, d, output_length, char);
3889 *d++ = '}'; /* Done. Add the trailing brace */
3892 else { /* Here, not in a pattern. Convert the name to a
3895 if (PL_lex_inwhat == OP_TRANS) {
3896 str = SvPV_const(res, len);
3897 if (len > ((SvUTF8(res))
3901 yyerror(Perl_form(aTHX_
3902 "%.*s must not be a named sequence"
3903 " in transliteration operator",
3904 /* +1 to include the "}" */
3905 (int) (e + 1 - start), start));
3907 goto end_backslash_N;
3910 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3911 has_above_latin1 = TRUE;
3915 else if (! SvUTF8(res)) {
3916 /* Make sure \N{} return is UTF-8. This is because
3917 * \N{} implies Unicode semantics, and scalars have
3918 * to be in utf8 to guarantee those semantics; but
3919 * not needed in tr/// */
3920 sv_utf8_upgrade_flags(res, 0);
3921 str = SvPV_const(res, len);
3924 /* Upgrade destination to be utf8 if this new
3926 if (! has_utf8 && SvUTF8(res)) {
3927 /* See Note on sizing above. */
3928 const STRLEN extra = len + (send - s) + 1;
3930 SvCUR_set(sv, d - SvPVX_const(sv));
3934 if (utf8_variant_count == 0) {
3936 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3939 sv_utf8_upgrade_flags_grow(sv,
3940 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3942 d = SvPVX(sv) + SvCUR(sv);
3945 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3947 /* See Note on sizing above. (NOTE: SvCUR() is not
3948 * set correctly here). */
3949 const STRLEN extra = len + (send - e) + 1;
3950 const STRLEN off = d - SvPVX_const(sv);
3951 d = off + SvGROW(sv, off + extra);
3953 Copy(str, d, len, char);
3959 } /* End \N{NAME} */
3963 backslash_N++; /* \N{} is defined to be Unicode */
3965 s = e + 1; /* Point to just after the '}' */
3968 /* \c is a control character */
3972 *d++ = grok_bslash_c(*s, 1);
3975 yyerror("Missing control char name in \\c");
3976 yyquit(); /* Are at end of input, no sense continuing */
3979 non_portable_endpoint++;
3983 /* printf-style backslashes, formfeeds, newlines, etc */
4009 } /* end if (backslash) */
4012 /* Just copy the input to the output, though we may have to convert
4015 * If the input has the same representation in UTF-8 as not, it will be
4016 * a single byte, and we don't care about UTF8ness; just copy the byte */
4017 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4020 else if (! this_utf8 && ! has_utf8) {
4021 /* If neither source nor output is UTF-8, is also a single byte,
4022 * just copy it; but this byte counts should we later have to
4023 * convert to UTF-8 */
4025 utf8_variant_count++;
4027 else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
4028 const STRLEN len = UTF8SKIP(s);
4030 /* We expect the source to have already been checked for
4032 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4034 Copy(s, d, len, U8);
4038 else { /* UTF8ness matters and doesn't match, need to convert */
4040 const UV nextuv = (this_utf8)
4041 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
4043 STRLEN need = UVCHR_SKIP(nextuv);
4046 SvCUR_set(sv, d - SvPVX_const(sv));
4050 /* See Note on sizing above. */
4051 need += (STRLEN)(send - s) + 1;
4053 if (utf8_variant_count == 0) {
4055 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4058 sv_utf8_upgrade_flags_grow(sv,
4059 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4061 d = SvPVX(sv) + SvCUR(sv);
4064 } else if (need > len) {
4065 /* encoded value larger than old, may need extra space (NOTE:
4066 * SvCUR() is not set correctly here). See Note on sizing
4068 const STRLEN extra = need + (send - s) + 1;
4069 const STRLEN off = d - SvPVX_const(sv);
4070 d = off + SvGROW(sv, off + extra);
4074 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
4076 } /* while loop to process each character */
4078 /* terminate the string and set up the sv */
4080 SvCUR_set(sv, d - SvPVX_const(sv));
4081 if (SvCUR(sv) >= SvLEN(sv))
4082 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
4083 " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
4088 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4089 PL_parser->lex_sub_op->op_private |=
4090 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4094 /* shrink the sv if we allocated more than we used */
4095 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4096 SvPV_shrink_to_cur(sv);
4099 /* return the substring (via pl_yylval) only if we parsed anything */
4102 for (; s2 < s; s2++) {
4104 COPLINE_INC_WITH_HERELINES;
4106 SvREFCNT_inc_simple_void_NN(sv);
4107 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4108 && ! PL_parser->lex_re_reparsing)
4110 const char *const key = PL_lex_inpat ? "qr" : "q";
4111 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4115 if (PL_lex_inwhat == OP_TRANS) {
4118 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4121 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4129 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4132 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4134 LEAVE_with_name("scan_const");
4139 * Returns TRUE if there's more to the expression (e.g., a subscript),
4142 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4144 * ->[ and ->{ return TRUE
4145 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4146 * { and [ outside a pattern are always subscripts, so return TRUE
4147 * if we're outside a pattern and it's not { or [, then return FALSE
4148 * if we're in a pattern and the first char is a {
4149 * {4,5} (any digits around the comma) returns FALSE
4150 * if we're in a pattern and the first char is a [
4152 * [SOMETHING] has a funky algorithm to decide whether it's a
4153 * character class or not. It has to deal with things like
4154 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4155 * anything else returns TRUE
4158 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4161 S_intuit_more(pTHX_ char *s, char *e)
4163 PERL_ARGS_ASSERT_INTUIT_MORE;
4165 if (PL_lex_brackets)
4167 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4169 if (*s == '-' && s[1] == '>'
4170 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4171 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4172 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4174 if (*s != '{' && *s != '[')
4176 PL_parser->sub_no_recover = TRUE;
4180 /* In a pattern, so maybe we have {n,m}. */
4188 /* On the other hand, maybe we have a character class */
4191 if (*s == ']' || *s == '^')
4194 /* this is terrifying, and it works */
4197 const char * const send = (char *) memchr(s, ']', e - s);
4198 unsigned char un_char, last_un_char;
4199 char tmpbuf[sizeof PL_tokenbuf * 4];
4201 if (!send) /* has to be an expression */
4203 weight = 2; /* let's weigh the evidence */
4207 else if (isDIGIT(*s)) {
4209 if (isDIGIT(s[1]) && s[2] == ']')
4215 Zero(seen,256,char);
4217 for (; s < send; s++) {
4218 last_un_char = un_char;
4219 un_char = (unsigned char)*s;
4224 weight -= seen[un_char] * 10;
4225 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4227 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4228 len = (int)strlen(tmpbuf);
4229 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4230 UTF ? SVf_UTF8 : 0, SVt_PV))
4237 && strchr("[#!%*<>()-=",s[1]))
4239 if (/*{*/ strchr("])} =",s[2]))
4248 if (strchr("wds]",s[1]))
4250 else if (seen[(U8)'\''] || seen[(U8)'"'])
4252 else if (strchr("rnftbxcav",s[1]))
4254 else if (isDIGIT(s[1])) {
4256 while (s[1] && isDIGIT(s[1]))
4266 if (strchr("aA01! ",last_un_char))
4268 if (strchr("zZ79~",s[1]))
4270 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4271 weight -= 5; /* cope with negative subscript */
4274 if (!isWORDCHAR(last_un_char)
4275 && !(last_un_char == '$' || last_un_char == '@'
4276 || last_un_char == '&')
4277 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4281 if (keyword(d, s - d, 0))
4284 if (un_char == last_un_char + 1)
4286 weight -= seen[un_char];
4291 if (weight >= 0) /* probably a character class */
4301 * Does all the checking to disambiguate
4303 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4304 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4306 * First argument is the stuff after the first token, e.g. "bar".
4308 * Not a method if foo is a filehandle.
4309 * Not a method if foo is a subroutine prototyped to take a filehandle.
4310 * Not a method if it's really "Foo $bar"
4311 * Method if it's "foo $bar"
4312 * Not a method if it's really "print foo $bar"
4313 * Method if it's really "foo package::" (interpreted as package->foo)
4314 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4315 * Not a method if bar is a filehandle or package, but is quoted with
4320 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4322 char *s = start + (*start == '$');
4323 char tmpbuf[sizeof PL_tokenbuf];
4326 /* Mustn't actually add anything to a symbol table.
4327 But also don't want to "initialise" any placeholder
4328 constants that might already be there into full
4329 blown PVGVs with attached PVCV. */
4331 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4333 PERL_ARGS_ASSERT_INTUIT_METHOD;
4335 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4337 if (cv && SvPOK(cv)) {
4338 const char *proto = CvPROTO(cv);
4340 while (*proto && (isSPACE(*proto) || *proto == ';'))
4347 if (*start == '$') {
4348 SSize_t start_off = start - SvPVX(PL_linestr);
4349 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4350 || isUPPER(*PL_tokenbuf))
4352 /* this could be $# */
4355 PL_bufptr = SvPVX(PL_linestr) + start_off;
4357 return *s == '(' ? FUNCMETH : METHOD;
4360 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4361 /* start is the beginning of the possible filehandle/object,
4362 * and s is the end of it
4363 * tmpbuf is a copy of it (but with single quotes as double colons)
4366 if (!keyword(tmpbuf, len, 0)) {
4367 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4372 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4373 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4375 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4376 && (!isGV(indirgv) || GvCVu(indirgv)))
4378 /* filehandle or package name makes it a method */
4379 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4381 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4382 return 0; /* no assumptions -- "=>" quotes bareword */
4384 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4385 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4386 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4388 force_next(BAREWORD);
4390 return *s == '(' ? FUNCMETH : METHOD;
4396 /* Encoded script support. filter_add() effectively inserts a
4397 * 'pre-processing' function into the current source input stream.
4398 * Note that the filter function only applies to the current source file
4399 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4401 * The datasv parameter (which may be NULL) can be used to pass
4402 * private data to this instance of the filter. The filter function
4403 * can recover the SV using the FILTER_DATA macro and use it to
4404 * store private buffers and state information.
4406 * The supplied datasv parameter is upgraded to a PVIO type
4407 * and the IoDIRP/IoANY field is used to store the function pointer,
4408 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4409 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4410 * private use must be set using malloc'd pointers.
4414 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4422 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4423 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4425 if (!PL_rsfp_filters)
4426 PL_rsfp_filters = newAV();
4429 SvUPGRADE(datasv, SVt_PVIO);
4430 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4431 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4432 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4433 FPTR2DPTR(void *, IoANY(datasv)),
4434 SvPV_nolen(datasv)));
4435 av_unshift(PL_rsfp_filters, 1);
4436 av_store(PL_rsfp_filters, 0, datasv) ;
4438 !PL_parser->filtered
4439 && PL_parser->lex_flags & LEX_EVALBYTES
4440 && PL_bufptr < PL_bufend
4442 const char *s = PL_bufptr;
4443 while (s < PL_bufend) {
4445 SV *linestr = PL_parser->linestr;
4446 char *buf = SvPVX(linestr);
4447 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4448 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4449 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4450 STRLEN const linestart_pos = PL_parser->linestart - buf;
4451 STRLEN const last_uni_pos =
4452 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4453 STRLEN const last_lop_pos =
4454 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4455 av_push(PL_rsfp_filters, linestr);
4456 PL_parser->linestr =
4457 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4458 buf = SvPVX(PL_parser->linestr);
4459 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4460 PL_parser->bufptr = buf + bufptr_pos;
4461 PL_parser->oldbufptr = buf + oldbufptr_pos;
4462 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4463 PL_parser->linestart = buf + linestart_pos;
4464 if (PL_parser->last_uni)
4465 PL_parser->last_uni = buf + last_uni_pos;
4466 if (PL_parser->last_lop)
4467 PL_parser->last_lop = buf + last_lop_pos;
4468 SvLEN_set(linestr, SvCUR(linestr));
4469 SvCUR_set(linestr, s - SvPVX(linestr));
4470 PL_parser->filtered = 1;
4480 /* Delete most recently added instance of this filter function. */
4482 Perl_filter_del(pTHX_ filter_t funcp)
4486 PERL_ARGS_ASSERT_FILTER_DEL;
4489 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4490 FPTR2DPTR(void*, funcp)));
4492 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4494 /* if filter is on top of stack (usual case) just pop it off */
4495 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4496 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4497 sv_free(av_pop(PL_rsfp_filters));
4501 /* we need to search for the correct entry and clear it */
4502 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4506 /* Invoke the idxth filter function for the current rsfp. */
4507 /* maxlen 0 = read one text line */
4509 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4514 /* This API is bad. It should have been using unsigned int for maxlen.
4515 Not sure if we want to change the API, but if not we should sanity
4516 check the value here. */
4517 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4519 PERL_ARGS_ASSERT_FILTER_READ;
4521 if (!PL_parser || !PL_rsfp_filters)
4523 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4524 /* Provide a default input filter to make life easy. */
4525 /* Note that we append to the line. This is handy. */
4526 DEBUG_P(PerlIO_printf(Perl_debug_log,
4527 "filter_read %d: from rsfp\n", idx));
4528 if (correct_length) {
4531 const int old_len = SvCUR(buf_sv);
4533 /* ensure buf_sv is large enough */
4534 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4535 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4536 correct_length)) <= 0) {
4537 if (PerlIO_error(PL_rsfp))
4538 return -1; /* error */
4540 return 0 ; /* end of file */
4542 SvCUR_set(buf_sv, old_len + len) ;
4543 SvPVX(buf_sv)[old_len + len] = '\0';
4546 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4547 if (PerlIO_error(PL_rsfp))
4548 return -1; /* error */
4550 return 0 ; /* end of file */
4553 return SvCUR(buf_sv);
4555 /* Skip this filter slot if filter has been deleted */
4556 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4557 DEBUG_P(PerlIO_printf(Perl_debug_log,
4558 "filter_read %d: skipped (filter deleted)\n",
4560 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4562 if (SvTYPE(datasv) != SVt_PVIO) {
4563 if (correct_length) {
4565 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4566 if (!remainder) return 0; /* eof */
4567 if (correct_length > remainder) correct_length = remainder;
4568 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4569 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4572 const char *s = SvEND(datasv);
4573 const char *send = SvPVX(datasv) + SvLEN(datasv);
4581 if (s == send) return 0; /* eof */
4582 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4583 SvCUR_set(datasv, s-SvPVX(datasv));
4585 return SvCUR(buf_sv);
4587 /* Get function pointer hidden within datasv */
4588 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4589 DEBUG_P(PerlIO_printf(Perl_debug_log,
4590 "filter_read %d: via function %p (%s)\n",
4591 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4592 /* Call function. The function is expected to */
4593 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4594 /* Return: <0:error, =0:eof, >0:not eof */
4596 save_scalar(PL_errgv);
4597 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4603 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4605 PERL_ARGS_ASSERT_FILTER_GETS;
4607 #ifdef PERL_CR_FILTER
4608 if (!PL_rsfp_filters) {
4609 filter_add(S_cr_textfilter,NULL);
4612 if (PL_rsfp_filters) {
4614 SvCUR_set(sv, 0); /* start with empty line */
4615 if (FILTER_READ(0, sv, 0) > 0)
4616 return ( SvPVX(sv) ) ;
4621 return (sv_gets(sv, PL_rsfp, append));
4625 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4629 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4631 if (memEQs(pkgname, len, "__PACKAGE__"))
4635 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4636 && (gv = gv_fetchpvn_flags(pkgname,
4638 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4640 return GvHV(gv); /* Foo:: */
4643 /* use constant CLASS => 'MyClass' */
4644 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4645 if (gv && GvCV(gv)) {
4646 SV * const sv = cv_const_sv(GvCV(gv));
4648 return gv_stashsv(sv, 0);
4651 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4656 S_tokenize_use(pTHX_ int is_use, char *s) {
4657 PERL_ARGS_ASSERT_TOKENIZE_USE;
4659 if (PL_expect != XSTATE)
4660 /* diag_listed_as: "use" not allowed in expression */
4661 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4662 is_use ? "use" : "no"));
4665 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4666 s = force_version(s, TRUE);
4667 if (*s == ';' || *s == '}'
4668 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4669 NEXTVAL_NEXTTOKE.opval = NULL;
4670 force_next(BAREWORD);
4672 else if (*s == 'v') {
4673 s = force_word(s,BAREWORD,FALSE,TRUE);
4674 s = force_version(s, FALSE);
4678 s = force_word(s,BAREWORD,FALSE,TRUE);
4679 s = force_version(s, FALSE);
4681 pl_yylval.ival = is_use;
4685 static const char* const exp_name[] =
4686 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4687 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4688 "SIGVAR", "TERMORDORDOR"
4692 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4694 S_word_takes_any_delimiter(char *p, STRLEN len)
4696 return (len == 1 && strchr("msyq", p[0]))
4698 && ((p[0] == 't' && p[1] == 'r')
4699 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4703 S_check_scalar_slice(pTHX_ char *s)
4706 while (SPACE_OR_TAB(*s)) s++;
4707 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4713 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4714 || (*s && strchr(" \t$#+-'\"", *s)))
4716 s += UTF ? UTF8SKIP(s) : 1;
4718 if (*s == '}' || *s == ']')
4719 pl_yylval.ival = OPpSLICEWARNING;
4722 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4724 S_lex_token_boundary(pTHX)
4726 PL_oldoldbufptr = PL_oldbufptr;
4727 PL_oldbufptr = PL_bufptr;
4730 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4732 S_vcs_conflict_marker(pTHX_ char *s)
4734 lex_token_boundary();
4736 yyerror("Version control conflict marker");
4737 while (s < PL_bufend && *s != '\n')
4745 Works out what to call the token just pulled out of the input
4746 stream. The yacc parser takes care of taking the ops we return and
4747 stitching them into a tree.
4750 The type of the next token
4753 Check if we have already built the token; if so, use it.
4754 Switch based on the current state:
4755 - if we have a case modifier in a string, deal with that
4756 - handle other cases of interpolation inside a string
4757 - scan the next line if we are inside a format
4758 In the normal state, switch on the next character:
4760 if alphabetic, go to key lookup
4761 unrecognized character - croak
4762 - 0/4/26: handle end-of-line or EOF
4763 - cases for whitespace
4764 - \n and #: handle comments and line numbers
4765 - various operators, brackets and sigils
4768 - 'v': vstrings (or go to key lookup)
4769 - 'x' repetition operator (or go to key lookup)
4770 - other ASCII alphanumerics (key lookup begins here):
4773 scan built-in keyword (but do nothing with it yet)
4774 check for statement label
4775 check for lexical subs
4776 goto just_a_word if there is one
4777 see whether built-in keyword is overridden
4778 switch on keyword number:
4779 - default: just_a_word:
4780 not a built-in keyword; handle bareword lookup
4781 disambiguate between method and sub call
4782 fall back to bareword
4783 - cases for built-in keywords
4791 char *s = PL_bufptr;
4795 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4799 /* orig_keyword, gvp, and gv are initialized here because
4800 * jump to the label just_a_word_zero can bypass their
4801 * initialization later. */
4802 I32 orig_keyword = 0;
4806 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4807 const U8* first_bad_char_loc;
4808 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4809 PL_bufend - PL_bufptr,
4810 &first_bad_char_loc)))
4812 _force_out_malformed_utf8_message(first_bad_char_loc,
4815 1 /* 1 means die */ );
4816 NOT_REACHED; /* NOTREACHED */
4818 PL_parser->recheck_utf8_validity = FALSE;
4821 SV* tmp = newSVpvs("");
4822 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4823 (IV)CopLINE(PL_curcop),
4824 lex_state_names[PL_lex_state],
4825 exp_name[PL_expect],
4826 pv_display(tmp, s, strlen(s), 0, 60));
4830 /* when we've already built the next token, just pull it out of the queue */
4833 pl_yylval = PL_nextval[PL_nexttoke];
4836 next_type = PL_nexttype[PL_nexttoke];
4837 if (next_type & (7<<24)) {
4838 if (next_type & (1<<24)) {
4839 if (PL_lex_brackets > 100)
4840 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4841 PL_lex_brackstack[PL_lex_brackets++] =
4842 (char) ((next_type >> 16) & 0xff);
4844 if (next_type & (2<<24))
4845 PL_lex_allbrackets++;
4846 if (next_type & (4<<24))
4847 PL_lex_allbrackets--;
4848 next_type &= 0xffff;
4850 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4854 switch (PL_lex_state) {
4856 case LEX_INTERPNORMAL:
4859 /* interpolated case modifiers like \L \U, including \Q and \E.
4860 when we get here, PL_bufptr is at the \
4862 case LEX_INTERPCASEMOD:
4864 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4866 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4867 PL_bufptr, PL_bufend, *PL_bufptr);
4869 /* handle \E or end of string */
4870 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4872 if (PL_lex_casemods) {
4873 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4874 PL_lex_casestack[PL_lex_casemods] = '\0';
4876 if (PL_bufptr != PL_bufend
4877 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4878 || oldmod == 'F')) {
4880 PL_lex_state = LEX_INTERPCONCAT;
4882 PL_lex_allbrackets--;
4885 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4886 /* Got an unpaired \E */
4887 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4888 "Useless use of \\E");
4890 if (PL_bufptr != PL_bufend)
4892 PL_lex_state = LEX_INTERPCONCAT;
4896 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4897 "### Saw case modifier\n"); });
4899 if (s[1] == '\\' && s[2] == 'E') {
4901 PL_lex_state = LEX_INTERPCONCAT;
4906 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
4907 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
4909 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4911 if ((*s == 'L' || *s == 'U' || *s == 'F')
4912 && (strpbrk(PL_lex_casestack, "LUF")))
4914 PL_lex_casestack[--PL_lex_casemods] = '\0';
4915 PL_lex_allbrackets--;
4918 if (PL_lex_casemods > 10)
4919 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4920 PL_lex_casestack[PL_lex_casemods++] = *s;
4921 PL_lex_casestack[PL_lex_casemods] = '\0';
4922 PL_lex_state = LEX_INTERPCONCAT;
4923 NEXTVAL_NEXTTOKE.ival = 0;
4924 force_next((2<<24)|'(');
4926 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4928 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4930 NEXTVAL_NEXTTOKE.ival = OP_LC;
4932 NEXTVAL_NEXTTOKE.ival = OP_UC;
4934 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4936 NEXTVAL_NEXTTOKE.ival = OP_FC;
4938 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4942 if (PL_lex_starts) {
4945 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4946 if (PL_lex_casemods == 1 && PL_lex_inpat)
4949 AopNOASSIGN(OP_CONCAT);
4955 case LEX_INTERPPUSH:
4956 return REPORT(sublex_push());
4958 case LEX_INTERPSTART:
4959 if (PL_bufptr == PL_bufend)
4960 return REPORT(sublex_done());
4961 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4962 "### Interpolated variable\n"); });
4964 /* for /@a/, we leave the joining for the regex engine to do
4965 * (unless we're within \Q etc) */
4966 PL_lex_dojoin = (*PL_bufptr == '@'
4967 && (!PL_lex_inpat || PL_lex_casemods));
4968 PL_lex_state = LEX_INTERPNORMAL;
4969 if (PL_lex_dojoin) {
4970 NEXTVAL_NEXTTOKE.ival = 0;
4972 force_ident("\"", '$');
4973 NEXTVAL_NEXTTOKE.ival = 0;
4975 NEXTVAL_NEXTTOKE.ival = 0;
4976 force_next((2<<24)|'(');
4977 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4980 /* Convert (?{...}) and friends to 'do {...}' */
4981 if (PL_lex_inpat && *PL_bufptr == '(') {
4982 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4984 if (*PL_bufptr != '{')
4986 PL_expect = XTERMBLOCK;
4990 if (PL_lex_starts++) {
4992 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4993 if (!PL_lex_casemods && PL_lex_inpat)
4996 AopNOASSIGN(OP_CONCAT);
5000 case LEX_INTERPENDMAYBE:
5001 if (intuit_more(PL_bufptr, PL_bufend)) {
5002 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5008 if (PL_lex_dojoin) {
5009 const U8 dojoin_was = PL_lex_dojoin;
5010 PL_lex_dojoin = FALSE;
5011 PL_lex_state = LEX_INTERPCONCAT;
5012 PL_lex_allbrackets--;
5013 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
5015 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5016 && SvEVALED(PL_lex_repl))
5018 if (PL_bufptr != PL_bufend)
5019 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5022 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5023 re_eval_str. If the here-doc body’s length equals the previous
5024 value of re_eval_start, re_eval_start will now be null. So
5025 check re_eval_str as well. */
5026 if (PL_parser->lex_shared->re_eval_start
5027 || PL_parser->lex_shared->re_eval_str) {
5029 if (*PL_bufptr != ')')
5030 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5032 /* having compiled a (?{..}) expression, return the original
5033 * text too, as a const */
5034 if (PL_parser->lex_shared->re_eval_str) {
5035 sv = PL_parser->lex_shared->re_eval_str;
5036 PL_parser->lex_shared->re_eval_str = NULL;
5038 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5039 SvPV_shrink_to_cur(sv);
5041 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5042 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5043 NEXTVAL_NEXTTOKE.opval =
5044 newSVOP(OP_CONST, 0,
5047 PL_parser->lex_shared->re_eval_start = NULL;
5053 case LEX_INTERPCONCAT:
5055 if (PL_lex_brackets)
5056 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5057 (long) PL_lex_brackets);
5059 if (PL_bufptr == PL_bufend)
5060 return REPORT(sublex_done());
5062 /* m'foo' still needs to be parsed for possible (?{...}) */
5063 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5064 SV *sv = newSVsv(PL_linestr);
5066 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5070 int save_error_count = PL_error_count;
5072 s = scan_const(PL_bufptr);
5074 /* Set flag if this was a pattern and there were errors. op.c will
5075 * refuse to compile a pattern with this flag set. Otherwise, we
5076 * could get segfaults, etc. */
5077 if (PL_lex_inpat && PL_error_count > save_error_count) {
5078 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5081 PL_lex_state = LEX_INTERPCASEMOD;
5083 PL_lex_state = LEX_INTERPSTART;
5086 if (s != PL_bufptr) {
5087 NEXTVAL_NEXTTOKE = pl_yylval;
5090 if (PL_lex_starts++) {
5091 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5092 if (!PL_lex_casemods && PL_lex_inpat)
5095 AopNOASSIGN(OP_CONCAT);
5105 assert(PL_lex_formbrack);
5106 s = scan_formline(PL_bufptr);
5107 if (!PL_lex_formbrack)
5116 /* We really do *not* want PL_linestr ever becoming a COW. */
5117 assert (!SvIsCOW(PL_linestr));
5119 PL_oldoldbufptr = PL_oldbufptr;
5121 PL_parser->saw_infix_sigil = 0;
5123 if (PL_in_my == KEY_sigvar) {
5124 /* we expect the sigil and optional var name part of a
5125 * signature element here. Since a '$' is not necessarily
5126 * followed by a var name, handle it specially here; the general
5127 * yylex code would otherwise try to interpret whatever follows
5128 * as a var; e.g. ($, ...) would be seen as the var '$,'
5135 PL_bufptr = s; /* for error reporting */
5140 /* spot stuff that looks like an prototype */
5141 if (strchr("$:@%&*;\\[]", *s)) {
5142 yyerror("Illegal character following sigil in a subroutine signature");
5145 /* '$#' is banned, while '$ # comment' isn't */
5147 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5151 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5152 char *dest = PL_tokenbuf + 1;
5153 /* read var name, including sigil, into PL_tokenbuf */
5154 PL_tokenbuf[0] = sigil;
5155 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5156 0, cBOOL(UTF), FALSE, FALSE);
5158 assert(PL_tokenbuf[1]); /* we have a variable name */
5166 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
5167 * as the ASSIGNOP, and exclude other tokens that start with =
5169 if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
5170 /* save now to report with the same context as we did when
5171 * all ASSIGNOPS were accepted */
5175 NEXTVAL_NEXTTOKE.ival = 0;
5176 force_next(ASSIGNOP);
5179 else if (*s == ',' || *s == ')') {
5180 PL_expect = XOPERATOR;
5183 /* make sure the context shows the unexpected character and
5184 * hopefully a bit more */
5186 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5188 PL_bufptr = s; /* for error reporting */
5189 yyerror("Illegal operator following parameter in a subroutine signature");
5193 NEXTVAL_NEXTTOKE.ival = sigil;
5194 force_next('p'); /* force a signature pending identifier */
5201 case ',': /* handle ($a,,$b) */
5206 yyerror("A signature parameter must start with '$', '@' or '%'");
5207 /* very crude error recovery: skip to likely next signature
5209 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5220 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5224 else if (isALNUMC(*s)) {
5228 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5231 STRLEN skiplen = UTF8SKIP(s);
5232 STRLEN stravail = PL_bufend - s;
5233 c = sv_uni_display(dsv, newSVpvn_flags(s,
5234 skiplen > stravail ? stravail : skiplen,
5235 SVs_TEMP | SVf_UTF8),
5236 10, UNI_DISPLAY_ISPRINT);
5239 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5242 if (s >= PL_linestart) {
5246 /* somehow (probably due to a parse failure), PL_linestart has advanced
5247 * pass PL_bufptr, get a reasonable beginning of line
5250 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
5253 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
5254 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5255 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
5258 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5259 UTF8fARG(UTF, (s - d), d),
5264 goto fake_eof; /* emulate EOF on ^D or ^Z */
5266 if ((!PL_rsfp || PL_lex_inwhat)
5267 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5271 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5273 yyerror((const char *)
5275 ? "Format not terminated"
5276 : "Missing right curly or square bracket"));
5278 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5279 "### Tokener got EOF\n");
5283 if (s++ < PL_bufend)
5284 goto retry; /* ignore stray nulls */
5287 if (!PL_in_eval && !PL_preambled) {
5288 PL_preambled = TRUE;
5290 /* Generate a string of Perl code to load the debugger.
5291 * If PERL5DB is set, it will return the contents of that,
5292 * otherwise a compile-time require of perl5db.pl. */
5294 const char * const pdb = PerlEnv_getenv("PERL5DB");
5297 sv_setpv(PL_linestr, pdb);
5298 sv_catpvs(PL_linestr,";");
5300 SETERRNO(0,SS_NORMAL);
5301 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5303 PL_parser->preambling = CopLINE(PL_curcop);
5305 SvPVCLEAR(PL_linestr);
5306 if (PL_preambleav) {
5307 SV **svp = AvARRAY(PL_preambleav);
5308 SV **const end = svp + AvFILLp(PL_preambleav);
5310 sv_catsv(PL_linestr, *svp);
5312 sv_catpvs(PL_linestr, ";");
5314 sv_free(MUTABLE_SV(PL_preambleav));
5315 PL_preambleav = NULL;
5318 sv_catpvs(PL_linestr,
5319 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5320 if (PL_minus_n || PL_minus_p) {
5321 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5323 sv_catpvs(PL_linestr,"chomp;");
5326 if ( ( *PL_splitstr == '/'
5327 || *PL_splitstr == '\''
5328 || *PL_splitstr == '"')
5329 && strchr(PL_splitstr + 1, *PL_splitstr))
5331 /* strchr is ok, because -F pattern can't contain
5333 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5336 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5337 bytes can be used as quoting characters. :-) */
5338 const char *splits = PL_splitstr;
5339 sv_catpvs(PL_linestr, "our @F=split(q\0");
5342 if (*splits == '\\')
5343 sv_catpvn(PL_linestr, splits, 1);
5344 sv_catpvn(PL_linestr, splits, 1);
5345 } while (*splits++);
5346 /* This loop will embed the trailing NUL of
5347 PL_linestr as the last thing it does before
5349 sv_catpvs(PL_linestr, ");");
5353 sv_catpvs(PL_linestr,"our @F=split(' ');");
5356 sv_catpvs(PL_linestr, "\n");
5357 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5358 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5359 PL_last_lop = PL_last_uni = NULL;
5360 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5361 update_debugger_info(PL_linestr, NULL, 0);
5366 bof = cBOOL(PL_rsfp);
5369 fake_eof = LEX_FAKE_EOF;
5371 PL_bufptr = PL_bufend;
5372 COPLINE_INC_WITH_HERELINES;
5373 if (!lex_next_chunk(fake_eof)) {
5374 CopLINE_dec(PL_curcop);
5376 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5378 CopLINE_dec(PL_curcop);
5380 /* If it looks like the start of a BOM or raw UTF-16,
5381 * check if it in fact is. */
5384 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5388 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5389 bof = (offset == (Off_t)SvCUR(PL_linestr));
5390 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5391 /* offset may include swallowed CR */
5393 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5396 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5397 s = swallow_bom((U8*)s);
5400 if (PL_parser->in_pod) {
5401 /* Incest with pod. */
5402 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
5405 SvPVCLEAR(PL_linestr);
5406 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5407 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5408 PL_last_lop = PL_last_uni = NULL;
5409 PL_parser->in_pod = 0;
5412 if (PL_rsfp || PL_parser->filtered)
5413 incline(s, PL_bufend);
5414 } while (PL_parser->in_pod);
5415 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5416 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5417 PL_last_lop = PL_last_uni = NULL;
5418 if (CopLINE(PL_curcop) == 1) {
5419 while (s < PL_bufend && isSPACE(*s))
5421 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5425 if (*s == '#' && *(s+1) == '!')
5427 #ifdef ALTERNATE_SHEBANG
5429 static char const as[] = ALTERNATE_SHEBANG;
5430 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5431 d = s + (sizeof(as) - 1);
5433 #endif /* ALTERNATE_SHEBANG */
5442 while (*d && !isSPACE(*d))
5446 #ifdef ARG_ZERO_IS_SCRIPT
5447 if (ipathend > ipath) {
5449 * HP-UX (at least) sets argv[0] to the script name,
5450 * which makes $^X incorrect. And Digital UNIX and Linux,
5451 * at least, set argv[0] to the basename of the Perl
5452 * interpreter. So, having found "#!", we'll set it right.
5454 SV* copfilesv = CopFILESV(PL_curcop);
5457 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5459 assert(SvPOK(x) || SvGMAGICAL(x));
5460 if (sv_eq(x, copfilesv)) {
5461 sv_setpvn(x, ipath, ipathend - ipath);
5467 const char *bstart = SvPV_const(copfilesv, blen);
5468 const char * const lstart = SvPV_const(x, llen);
5470 bstart += blen - llen;
5471 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5472 sv_setpvn(x, ipath, ipathend - ipath);
5479 /* Anything to do if no copfilesv? */
5481 TAINT_NOT; /* $^X is always tainted, but that's OK */
5483 #endif /* ARG_ZERO_IS_SCRIPT */
5488 d = instr(s,"perl -");
5490 d = instr(s,"perl");
5492 /* avoid getting into infinite loops when shebang
5493 * line contains "Perl" rather than "perl" */
5495 for (d = ipathend-4; d >= ipath; --d) {
5496 if (isALPHA_FOLD_EQ(*d, 'p')
5497 && !ibcmp(d, "perl", 4))
5507 #ifdef ALTERNATE_SHEBANG
5509 * If the ALTERNATE_SHEBANG on this system starts with a
5510 * character that can be part of a Perl expression, then if
5511 * we see it but not "perl", we're probably looking at the
5512 * start of Perl code, not a request to hand off to some
5513 * other interpreter. Similarly, if "perl" is there, but
5514 * not in the first 'word' of the line, we assume the line
5515 * contains the start of the Perl program.
5517 if (d && *s != '#') {
5518 const char *c = ipath;
5519 while (*c && !strchr("; \t\r\n\f\v#", *c))
5522 d = NULL; /* "perl" not in first word; ignore */
5524 *s = '#'; /* Don't try to parse shebang line */
5526 #endif /* ALTERNATE_SHEBANG */
5531 && !instr(s,"indir")
5532 && instr(PL_origargv[0],"perl"))
5539 while (s < PL_bufend && isSPACE(*s))
5541 if (s < PL_bufend) {
5542 Newx(newargv,PL_origargc+3,char*);
5544 while (s < PL_bufend && !isSPACE(*s))
5547 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5550 newargv = PL_origargv;
5553 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5555 Perl_croak(aTHX_ "Can't exec %s", ipath);
5558 while (*d && !isSPACE(*d))
5560 while (SPACE_OR_TAB(*d))
5564 const bool switches_done = PL_doswitches;
5565 const U32 oldpdb = PL_perldb;
5566 const bool oldn = PL_minus_n;
5567 const bool oldp = PL_minus_p;
5571 bool baduni = FALSE;
5573 const char *d2 = d1 + 1;
5574 if (parse_unicode_opts((const char **)&d2)
5578 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5579 const char * const m = d1;
5580 while (*d1 && !isSPACE(*d1))
5582 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5585 d1 = moreswitches(d1);
5587 if (PL_doswitches && !switches_done) {
5588 int argc = PL_origargc;
5589 char **argv = PL_origargv;
5592 } while (argc && argv[0][0] == '-' && argv[0][1]);
5593 init_argv_symbols(argc,argv);
5595 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5596 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5597 /* if we have already added "LINE: while (<>) {",
5598 we must not do it again */
5600 SvPVCLEAR(PL_linestr);
5601 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5602 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5603 PL_last_lop = PL_last_uni = NULL;
5604 PL_preambled = FALSE;
5605 if (PERLDB_LINE_OR_SAVESRC)
5606 (void)gv_fetchfile(PL_origfilename);
5613 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5614 PL_lex_state = LEX_FORMLINE;
5615 force_next(FORMRBRACK);
5620 #ifdef PERL_STRICT_CR
5621 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5623 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5625 case ' ': case '\t': case '\f': case '\v':
5630 if (PL_lex_state != LEX_NORMAL
5631 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5633 const bool in_comment = *s == '#';
5634 if (*s == '#' && s == PL_linestart && PL_in_eval
5635 && !PL_rsfp && !PL_parser->filtered) {
5636 /* handle eval qq[#line 1 "foo"\n ...] */
5637 CopLINE_dec(PL_curcop);
5638 incline(s, PL_bufend);
5641 while (d < PL_bufend && *d != '\n')
5646 if (in_comment && d == PL_bufend
5647 && PL_lex_state == LEX_INTERPNORMAL
5648 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5649 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5651 incline(s, PL_bufend);
5652 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5653 PL_lex_state = LEX_FORMLINE;
5654 force_next(FORMRBRACK);
5659 while (s < PL_bufend && *s != '\n')
5665 incline(s, PL_bufend);
5670 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5678 while (s < PL_bufend && SPACE_OR_TAB(*s))
5681 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5682 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5683 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5684 OPERATOR('-'); /* unary minus */
5687 case 'r': ftst = OP_FTEREAD; break;
5688 case 'w': ftst = OP_FTEWRITE; break;
5689 case 'x': ftst = OP_FTEEXEC; break;
5690 case 'o': ftst = OP_FTEOWNED; break;
5691 case 'R': ftst = OP_FTRREAD; break;
5692 case 'W': ftst = OP_FTRWRITE; break;
5693 case 'X': ftst = OP_FTREXEC; break;
5694 case 'O': ftst = OP_FTROWNED; break;
5695 case 'e': ftst = OP_FTIS; break;
5696 case 'z': ftst = OP_FTZERO; break;
5697 case 's': ftst = OP_FTSIZE; break;
5698 case 'f': ftst = OP_FTFILE; break;
5699 case 'd': ftst = OP_FTDIR; break;
5700 case 'l': ftst = OP_FTLINK; break;
5701 case 'p': ftst = OP_FTPIPE; break;
5702 case 'S': ftst = OP_FTSOCK; break;
5703 case 'u': ftst = OP_FTSUID; break;
5704 case 'g': ftst = OP_FTSGID; break;
5705 case 'k': ftst = OP_FTSVTX; break;
5706 case 'b': ftst = OP_FTBLK; break;
5707 case 'c': ftst = OP_FTCHR; break;
5708 case 't': ftst = OP_FTTTY; break;
5709 case 'T': ftst = OP_FTTEXT; break;
5710 case 'B': ftst = OP_FTBINARY; break;
5711 case 'M': case 'A': case 'C':
5712 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5714 case 'M': ftst = OP_FTMTIME; break;
5715 case 'A': ftst = OP_FTATIME; break;
5716 case 'C': ftst = OP_FTCTIME; break;
5724 PL_last_uni = PL_oldbufptr;
5725 PL_last_lop_op = (OPCODE)ftst;
5726 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5727 "### Saw file test %c\n", (int)tmp);
5732 /* Assume it was a minus followed by a one-letter named
5733 * subroutine call (or a -bareword), then. */
5734 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5735 "### '-%c' looked like a file test but was not\n",
5742 const char tmp = *s++;
5745 if (PL_expect == XOPERATOR)
5750 else if (*s == '>') {
5753 if (((*s == '$' || *s == '&') && s[1] == '*')
5754 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5755 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5756 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5759 PL_expect = XPOSTDEREF;
5762 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5763 s = force_word(s,METHOD,FALSE,TRUE);
5771 if (PL_expect == XOPERATOR) {
5773 && !PL_lex_allbrackets
5774 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5782 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5784 OPERATOR('-'); /* unary minus */
5790 const char tmp = *s++;
5793 if (PL_expect == XOPERATOR)
5798 if (PL_expect == XOPERATOR) {
5800 && !PL_lex_allbrackets
5801 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5809 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5816 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5817 if (PL_expect != XOPERATOR) {
5818 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5819 PL_expect = XOPERATOR;
5820 force_ident(PL_tokenbuf, '*');
5828 if (*s == '=' && !PL_lex_allbrackets
5829 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5837 && !PL_lex_allbrackets
5838 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5843 PL_parser->saw_infix_sigil = 1;
5848 if (PL_expect == XOPERATOR) {
5850 && !PL_lex_allbrackets
5851 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5856 PL_parser->saw_infix_sigil = 1;
5859 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5860 PL_tokenbuf[0] = '%';
5861 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5863 if (!PL_tokenbuf[1]) {
5866 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5867 && intuit_more(s, PL_bufend)) {
5869 PL_tokenbuf[0] = '@';
5871 PL_expect = XOPERATOR;
5872 force_ident_maybe_lex('%');
5877 bof = FEATURE_BITWISE_IS_ENABLED;
5878 if (bof && s[1] == '.')
5880 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5881 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5887 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5889 if (PL_lex_brackets > 100)
5890 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5891 PL_lex_brackstack[PL_lex_brackets++] = 0;
5892 PL_lex_allbrackets++;
5894 const char tmp = *s++;
5899 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5901 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5904 Perl_ck_warner_d(aTHX_
5905 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5906 "Smartmatch is experimental");
5910 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5912 BCop(OP_SCOMPLEMENT);
5914 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5916 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5923 goto just_a_word_zero_gv;
5929 switch (PL_expect) {
5931 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5933 PL_bufptr = s; /* update in case we back off */
5936 "Use of := for an empty attribute list is not allowed");
5943 PL_expect = XTERMBLOCK;
5947 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5950 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5951 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5952 if (tmp < 0) tmp = -tmp;
5967 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5969 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5974 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5976 COPLINE_SET_FROM_MULTI_END;
5979 sv_catsv(sv, PL_lex_stuff);
5980 attrs = op_append_elem(OP_LIST, attrs,
5981 newSVOP(OP_CONST, 0, sv));
5982 SvREFCNT_dec_NN(PL_lex_stuff);
5983 PL_lex_stuff = NULL;
5986 /* NOTE: any CV attrs applied here need to be part of
5987 the CVf_BUILTIN_ATTRS define in cv.h! */
5988 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
5990 CvLVALUE_on(PL_compcv);
5992 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
5994 CvMETHOD_on(PL_compcv);
5996 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
5999 Perl_ck_warner_d(aTHX_
6000 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
6001 ":const is experimental"
6003 CvANONCONST_on(PL_compcv);
6004 if (!CvANON(PL_compcv))
6005 yyerror(":const is not permitted on named "
6008 /* After we've set the flags, it could be argued that
6009 we don't need to do the attributes.pm-based setting
6010 process, and shouldn't bother appending recognized
6011 flags. To experiment with that, uncomment the
6012 following "else". (Note that's already been
6013 uncommented. That keeps the above-applied built-in
6014 attributes from being intercepted (and possibly
6015 rejected) by a package's attribute routines, but is
6016 justified by the performance win for the common case
6017 of applying only built-in attributes.) */
6019 attrs = op_append_elem(OP_LIST, attrs,
6020 newSVOP(OP_CONST, 0,
6024 if (*s == ':' && s[1] != ':')
6027 break; /* require real whitespace or :'s */
6028 /* XXX losing whitespace on sequential attributes here */
6033 && !(PL_expect == XOPERATOR
6034 ? (*s == '=' || *s == ')')
6035 : (*s == '{' || *s == '(')))
6037 const char q = ((*s == '\'') ? '"' : '\'');
6038 /* If here for an expression, and parsed no attrs, back
6040 if (PL_expect == XOPERATOR && !attrs) {
6044 /* MUST advance bufptr here to avoid bogus "at end of line"
6045 context messages from yyerror().
6048 yyerror( (const char *)
6050 ? Perl_form(aTHX_ "Invalid separator character "
6051 "%c%c%c in attribute list", q, *s, q)
6052 : "Unterminated attribute list" ) );
6060 NEXTVAL_NEXTTOKE.opval = attrs;
6066 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6070 PL_lex_allbrackets--;
6074 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6075 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6079 PL_lex_allbrackets++;
6082 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6089 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6092 PL_lex_allbrackets--;
6098 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6101 if (PL_lex_brackets <= 0)
6102 /* diag_listed_as: Unmatched right %s bracket */
6103 yyerror("Unmatched right square bracket");
6106 PL_lex_allbrackets--;
6107 if (PL_lex_state == LEX_INTERPNORMAL) {
6108 if (PL_lex_brackets == 0) {
6109 if (*s == '-' && s[1] == '>')
6110 PL_lex_state = LEX_INTERPENDMAYBE;
6111 else if (*s != '[' && *s != '{')
6112 PL_lex_state = LEX_INTERPEND;
6119 if (PL_lex_brackets > 100) {
6120 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6122 switch (PL_expect) {
6125 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6126 PL_lex_allbrackets++;
6127 OPERATOR(HASHBRACK);
6129 while (s < PL_bufend && SPACE_OR_TAB(*s))
6132 PL_tokenbuf[0] = '\0';
6133 if (d < PL_bufend && *d == '-') {
6134 PL_tokenbuf[0] = '-';
6136 while (d < PL_bufend && SPACE_OR_TAB(*d))
6139 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6140 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6142 while (d < PL_bufend && SPACE_OR_TAB(*d))
6145 const char minus = (PL_tokenbuf[0] == '-');
6146 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6154 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6155 PL_lex_allbrackets++;
6160 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6161 PL_lex_allbrackets++;
6165 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6166 PL_lex_allbrackets++;
6171 if (PL_oldoldbufptr == PL_last_lop)
6172 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6174 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6175 PL_lex_allbrackets++;
6178 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6180 /* This hack is to get the ${} in the message. */
6182 yyerror("syntax error");
6185 OPERATOR(HASHBRACK);
6187 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6188 /* ${...} or @{...} etc., but not print {...}
6189 * Skip the disambiguation and treat this as a block.
6191 goto block_expectation;
6193 /* This hack serves to disambiguate a pair of curlies
6194 * as being a block or an anon hash. Normally, expectation
6195 * determines that, but in cases where we're not in a
6196 * position to expect anything in particular (like inside
6197 * eval"") we have to resolve the ambiguity. This code
6198 * covers the case where the first term in the curlies is a
6199 * quoted string. Most other cases need to be explicitly
6200 * disambiguated by prepending a "+" before the opening
6201 * curly in order to force resolution as an anon hash.
6203 * XXX should probably propagate the outer expectation
6204 * into eval"" to rely less on this hack, but that could
6205 * potentially break current behavior of eval"".
6209 if (*s == '\'' || *s == '"' || *s == '`') {
6210 /* common case: get past first string, handling escapes */
6211 for (t++; t < PL_bufend && *t != *s;)
6216 else if (*s == 'q') {
6219 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6220 && !isWORDCHAR(*t))))
6222 /* skip q//-like construct */
6224 char open, close, term;
6227 while (t < PL_bufend && isSPACE(*t))
6229 /* check for q => */
6230 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6231 OPERATOR(HASHBRACK);
6235 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6239 for (t++; t < PL_bufend; t++) {
6240 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6242 else if (*t == open)
6246 for (t++; t < PL_bufend; t++) {
6247 if (*t == '\\' && t+1 < PL_bufend)
6249 else if (*t == close && --brackets <= 0)
6251 else if (*t == open)
6258 /* skip plain q word */
6259 while ( t < PL_bufend
6260 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6262 t += UTF ? UTF8SKIP(t) : 1;
6265 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6266 t += UTF ? UTF8SKIP(t) : 1;
6267 while ( t < PL_bufend
6268 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6270 t += UTF ? UTF8SKIP(t) : 1;
6273 while (t < PL_bufend && isSPACE(*t))
6275 /* if comma follows first term, call it an anon hash */
6276 /* XXX it could be a comma expression with loop modifiers */
6277 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6278 || (*t == '=' && t[1] == '>')))
6279 OPERATOR(HASHBRACK);
6280 if (PL_expect == XREF)
6283 /* If there is an opening brace or 'sub:', treat it
6284 as a term to make ${{...}}{k} and &{sub:attr...}
6285 dwim. Otherwise, treat it as a statement, so
6286 map {no strict; ...} works.
6293 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6306 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6312 pl_yylval.ival = CopLINE(PL_curcop);
6313 PL_copline = NOLINE; /* invalidate current command line number */
6314 TOKEN(formbrack ? '=' : '{');
6316 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6319 assert(s != PL_bufend);
6321 if (PL_lex_brackets <= 0)
6322 /* diag_listed_as: Unmatched right %s bracket */
6323 yyerror("Unmatched right curly bracket");
6325 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6326 PL_lex_allbrackets--;
6327 if (PL_lex_state == LEX_INTERPNORMAL) {
6328 if (PL_lex_brackets == 0) {
6329 if (PL_expect & XFAKEBRACK) {
6330 PL_expect &= XENUMMASK;
6331 PL_lex_state = LEX_INTERPEND;
6333 return yylex(); /* ignore fake brackets */
6335 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6336 && SvEVALED(PL_lex_repl))
6337 PL_lex_state = LEX_INTERPEND;
6338 else if (*s == '-' && s[1] == '>')
6339 PL_lex_state = LEX_INTERPENDMAYBE;
6340 else if (*s != '[' && *s != '{')
6341 PL_lex_state = LEX_INTERPEND;
6344 if (PL_expect & XFAKEBRACK) {
6345 PL_expect &= XENUMMASK;
6347 return yylex(); /* ignore fake brackets */
6349 force_next(formbrack ? '.' : '}');
6350 if (formbrack) LEAVE_with_name("lex_format");
6351 if (formbrack == 2) { /* means . where arguments were expected */
6357 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6360 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6361 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6368 if (PL_expect == XOPERATOR) {
6369 if ( PL_bufptr == PL_linestart
6370 && ckWARN(WARN_SEMICOLON)
6371 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6373 CopLINE_dec(PL_curcop);
6374 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6375 CopLINE_inc(PL_curcop);
6378 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6380 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6381 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6387 PL_parser->saw_infix_sigil = 1;
6388 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6394 PL_tokenbuf[0] = '&';
6395 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6396 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6397 if (PL_tokenbuf[1]) {
6398 force_ident_maybe_lex('&');
6407 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6408 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6416 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6418 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6419 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6423 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6427 const char tmp = *s++;
6429 if ( (s == PL_linestart+2 || s[-3] == '\n')
6430 && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
6432 s = vcs_conflict_marker(s + 5);
6435 if (!PL_lex_allbrackets
6436 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6444 if (!PL_lex_allbrackets
6445 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6454 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6455 && strchr("+-*/%.^&|<",tmp))
6456 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6457 "Reversed %c= operator",(int)tmp);
6459 if (PL_expect == XSTATE
6461 && (s == PL_linestart+1 || s[-2] == '\n') )
6463 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6464 || PL_lex_state != LEX_NORMAL)
6469 incline(s, PL_bufend);
6470 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
6472 s = (char *) memchr(s,'\n', d - s);
6477 incline(s, PL_bufend);
6485 PL_parser->in_pod = 1;
6489 if (PL_expect == XBLOCK) {
6491 #ifdef PERL_STRICT_CR
6492 while (SPACE_OR_TAB(*t))
6494 while (SPACE_OR_TAB(*t) || *t == '\r')
6497 if (*t == '\n' || *t == '#') {
6499 ENTER_with_name("lex_format");
6500 SAVEI8(PL_parser->form_lex_state);
6501 SAVEI32(PL_lex_formbrack);
6502 PL_parser->form_lex_state = PL_lex_state;
6503 PL_lex_formbrack = PL_lex_brackets + 1;
6507 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6516 const char tmp = *s++;
6518 /* was this !=~ where !~ was meant?
6519 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6521 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6522 const char *t = s+1;
6524 while (t < PL_bufend && isSPACE(*t))
6527 if (*t == '/' || *t == '?'
6528 || ((*t == 'm' || *t == 's' || *t == 'y')
6529 && !isWORDCHAR(t[1]))
6530 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6531 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6532 "!=~ should be !~");
6534 if (!PL_lex_allbrackets
6535 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6548 if (PL_expect != XOPERATOR) {
6549 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6551 if (s[1] == '<' && s[2] != '>') {
6552 if ( (s == PL_linestart || s[-1] == '\n')
6553 && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
6555 s = vcs_conflict_marker(s + 7);
6558 s = scan_heredoc(s);
6561 s = scan_inputsymbol(s);
6562 PL_expect = XOPERATOR;
6563 TOKEN(sublex_start());
6569 if ( (s == PL_linestart+2 || s[-3] == '\n')
6570 && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
6572 s = vcs_conflict_marker(s + 5);
6575 if (*s == '=' && !PL_lex_allbrackets
6576 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6581 SHop(OP_LEFT_SHIFT);
6586 if (!PL_lex_allbrackets
6587 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6595 if (!PL_lex_allbrackets
6596 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6605 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6613 const char tmp = *s++;
6615 if ( (s == PL_linestart+2 || s[-3] == '\n')
6616 && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
6618 s = vcs_conflict_marker(s + 5);
6621 if (*s == '=' && !PL_lex_allbrackets
6622 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6627 SHop(OP_RIGHT_SHIFT);
6629 else if (tmp == '=') {
6630 if (!PL_lex_allbrackets
6631 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6640 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6649 if (PL_expect == XPOSTDEREF) {
6652 POSTDEREF(DOLSHARP);
6658 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6659 || strchr("{$:+-@", s[2])))
6661 PL_tokenbuf[0] = '@';
6662 s = scan_ident(s + 1, PL_tokenbuf + 1,
6663 sizeof PL_tokenbuf - 1, FALSE);
6664 if (PL_expect == XOPERATOR) {
6666 if (PL_bufptr > s) {
6668 PL_bufptr = PL_oldbufptr;
6670 no_op("Array length", d);
6672 if (!PL_tokenbuf[1])
6674 PL_expect = XOPERATOR;
6675 force_ident_maybe_lex('#');
6679 PL_tokenbuf[0] = '$';
6680 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6681 if (PL_expect == XOPERATOR) {
6683 if (PL_bufptr > s) {
6685 PL_bufptr = PL_oldbufptr;
6689 if (!PL_tokenbuf[1]) {
6691 yyerror("Final $ should be \\$ or $name");
6697 const char tmp = *s;
6698 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6701 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6702 && intuit_more(s, PL_bufend)) {
6704 PL_tokenbuf[0] = '@';
6705 if (ckWARN(WARN_SYNTAX)) {
6709 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6712 t += UTF ? UTF8SKIP(t) : 1;
6715 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6716 while (t < PL_bufend && *t != ']')
6718 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6719 "Multidimensional syntax %" UTF8f " not supported",
6720 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6724 else if (*s == '{') {
6726 PL_tokenbuf[0] = '%';
6727 if ( strEQ(PL_tokenbuf+1, "SIG")
6728 && ckWARN(WARN_SYNTAX)
6729 && (t = (char *) memchr(s, '}', PL_bufend - s))
6730 && (t = (char *) memchr(t, '=', PL_bufend - t)))
6732 char tmpbuf[sizeof PL_tokenbuf];
6735 } while (isSPACE(*t));
6736 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6738 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6743 && get_cvn_flags(tmpbuf, len, UTF
6747 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6748 "You need to quote \"%" UTF8f "\"",
6749 UTF8fARG(UTF, len, tmpbuf));
6756 PL_expect = XOPERATOR;
6757 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6758 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6759 if (!islop || PL_last_lop_op == OP_GREPSTART)
6760 PL_expect = XOPERATOR;
6761 else if (strchr("$@\"'`q", *s))
6762 PL_expect = XTERM; /* e.g. print $fh "foo" */
6763 else if ( strchr("&*<%", *s)
6764 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6766 PL_expect = XTERM; /* e.g. print $fh &sub */
6768 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6769 char tmpbuf[sizeof PL_tokenbuf];
6771 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6772 if ((t2 = keyword(tmpbuf, len, 0))) {
6773 /* binary operators exclude handle interpretations */
6785 PL_expect = XTERM; /* e.g. print $fh length() */
6790 PL_expect = XTERM; /* e.g. print $fh subr() */
6793 else if (isDIGIT(*s))
6794 PL_expect = XTERM; /* e.g. print $fh 3 */
6795 else if (*s == '.' && isDIGIT(s[1]))
6796 PL_expect = XTERM; /* e.g. print $fh .3 */
6797 else if ((*s == '?' || *s == '-' || *s == '+')
6798 && !isSPACE(s[1]) && s[1] != '=')
6799 PL_expect = XTERM; /* e.g. print $fh -1 */
6800 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6802 PL_expect = XTERM; /* e.g. print $fh /.../
6803 XXX except DORDOR operator
6805 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6807 PL_expect = XTERM; /* print $fh <<"EOF" */
6810 force_ident_maybe_lex('$');
6814 if (PL_expect == XPOSTDEREF)
6816 PL_tokenbuf[0] = '@';
6817 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6818 if (PL_expect == XOPERATOR) {
6820 if (PL_bufptr > s) {
6822 PL_bufptr = PL_oldbufptr;
6827 if (!PL_tokenbuf[1]) {
6830 if (PL_lex_state == LEX_NORMAL)
6832 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6833 && intuit_more(s, PL_bufend))
6836 PL_tokenbuf[0] = '%';
6838 /* Warn about @ where they meant $. */
6839 if (*s == '[' || *s == '{') {
6840 if (ckWARN(WARN_SYNTAX)) {
6841 S_check_scalar_slice(aTHX_ s);
6845 PL_expect = XOPERATOR;
6846 force_ident_maybe_lex('@');
6849 case '/': /* may be division, defined-or, or pattern */
6850 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6851 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6852 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6857 else if (PL_expect == XOPERATOR) {
6859 if (*s == '=' && !PL_lex_allbrackets
6860 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6868 /* Disable warning on "study /blah/" */
6869 if ( PL_oldoldbufptr == PL_last_uni
6870 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6871 || memNE(PL_last_uni, "study", 5)
6872 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6875 s = scan_pat(s,OP_MATCH);
6876 TERM(sublex_start());
6879 case '?': /* conditional */
6881 if (!PL_lex_allbrackets
6882 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6887 PL_lex_allbrackets++;
6891 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6892 #ifdef PERL_STRICT_CR
6895 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6897 && (s == PL_linestart || s[-1] == '\n') )
6900 formbrack = 2; /* dot seen where arguments expected */
6903 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6907 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6910 if (!PL_lex_allbrackets
6911 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6919 pl_yylval.ival = OPf_SPECIAL;
6925 if (*s == '=' && !PL_lex_allbrackets
6926 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6934 case '0': case '1': case '2': case '3': case '4':
6935 case '5': case '6': case '7': case '8': case '9':
6936 s = scan_num(s, &pl_yylval);
6937 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6938 if (PL_expect == XOPERATOR)
6943 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6945 missingterm(NULL, 0);
6946 COPLINE_SET_FROM_MULTI_END;
6947 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6948 if (PL_expect == XOPERATOR) {
6951 pl_yylval.ival = OP_CONST;
6952 TERM(sublex_start());
6955 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6958 printbuf("### Saw string before %s\n", s);
6960 PerlIO_printf(Perl_debug_log,
6961 "### Saw unterminated string\n");
6963 if (PL_expect == XOPERATOR) {
6967 missingterm(NULL, 0);
6968 pl_yylval.ival = OP_CONST;
6969 /* FIXME. I think that this can be const if char *d is replaced by
6970 more localised variables. */
6971 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6972 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6973 pl_yylval.ival = OP_STRINGIFY;
6977 if (pl_yylval.ival == OP_CONST)
6978 COPLINE_SET_FROM_MULTI_END;
6979 TERM(sublex_start());
6982 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6985 printbuf("### Saw backtick string before %s\n", s);
6987 PerlIO_printf(Perl_debug_log,
6988 "### Saw unterminated backtick string\n");
6990 if (PL_expect == XOPERATOR)
6991 no_op("Backticks",s);
6993 missingterm(NULL, 0);
6994 pl_yylval.ival = OP_BACKTICK;
6995 TERM(sublex_start());
6999 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
7001 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
7003 if (PL_expect == XOPERATOR)
7004 no_op("Backslash",s);
7008 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
7009 char *start = s + 2;
7010 while (isDIGIT(*start) || *start == '_')
7012 if (*start == '.' && isDIGIT(start[1])) {
7013 s = scan_num(s, &pl_yylval);
7016 else if ((*start == ':' && start[1] == ':')
7017 || (PL_expect == XSTATE && *start == ':'))
7019 else if (PL_expect == XSTATE) {
7021 while (d < PL_bufend && isSPACE(*d)) d++;
7022 if (*d == ':') goto keylookup;
7024 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
7025 if (!isALPHA(*start) && (PL_expect == XTERM
7026 || PL_expect == XREF || PL_expect == XSTATE
7027 || PL_expect == XTERMORDORDOR)) {
7028 GV *const gv = gv_fetchpvn_flags(s, start - s,
7029 UTF ? SVf_UTF8 : 0, SVt_PVCV);
7031 s = scan_num(s, &pl_yylval);
7038 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7091 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7093 /* Some keywords can be followed by any delimiter, including ':' */
7094 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7096 /* x::* is just a word, unless x is "CORE" */
7097 if (!anydelim && *s == ':' && s[1] == ':') {
7098 if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
7103 while (d < PL_bufend && isSPACE(*d))
7104 d++; /* no comments skipped here, or s### is misparsed */
7106 /* Is this a word before a => operator? */
7107 if (*d == '=' && d[1] == '>') {
7111 = newSVOP(OP_CONST, 0,
7112 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7113 pl_yylval.opval->op_private = OPpCONST_BARE;
7117 /* Check for plugged-in keyword */
7121 char *saved_bufptr = PL_bufptr;
7123 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7125 if (result == KEYWORD_PLUGIN_DECLINE) {
7126 /* not a plugged-in keyword */
7127 PL_bufptr = saved_bufptr;
7128 } else if (result == KEYWORD_PLUGIN_STMT) {
7129 pl_yylval.opval = o;
7131 if (!PL_nexttoke) PL_expect = XSTATE;
7132 return REPORT(PLUGSTMT);
7133 } else if (result == KEYWORD_PLUGIN_EXPR) {
7134 pl_yylval.opval = o;
7136 if (!PL_nexttoke) PL_expect = XOPERATOR;
7137 return REPORT(PLUGEXPR);
7139 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7144 /* Check for built-in keyword */
7145 tmp = keyword(PL_tokenbuf, len, 0);
7147 /* Is this a label? */
7148 if (!anydelim && PL_expect == XSTATE
7149 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7151 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7152 pl_yylval.pval[len] = '\0';
7153 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7158 /* Check for lexical sub */
7159 if (PL_expect != XOPERATOR) {
7160 char tmpbuf[sizeof PL_tokenbuf + 1];
7162 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7163 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7164 if (off != NOT_IN_PAD) {
7165 assert(off); /* we assume this is boolean-true below */
7166 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7167 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7168 HEK * const stashname = HvNAME_HEK(stash);
7169 sv = newSVhek(stashname);
7170 sv_catpvs(sv, "::");
7171 sv_catpvn_flags(sv, PL_tokenbuf, len,
7172 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7173 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7183 rv2cv_op = newOP(OP_PADANY, 0);
7184 rv2cv_op->op_targ = off;
7185 cv = find_lexical_cv(off);
7193 if (tmp < 0) { /* second-class keyword? */
7194 GV *ogv = NULL; /* override (winner) */
7195 GV *hgv = NULL; /* hidden (loser) */
7196 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7198 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7199 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7201 && (cv = GvCVu(gv)))
7203 if (GvIMPORTED_CV(gv))
7205 else if (! CvMETHOD(cv))
7209 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7212 && (isGV_with_GP(gv)
7213 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7214 : SvPCS_IMPORTED(gv)
7215 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7223 tmp = 0; /* overridden by import or by GLOBAL */
7226 && -tmp==KEY_lock /* XXX generalizable kludge */
7229 tmp = 0; /* any sub overrides "weak" keyword */
7231 else { /* no override */
7233 if (tmp == KEY_dump) {
7234 Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED),
7235 "dump() better written as CORE::dump(). "
7236 "dump() will no longer be available "
7241 if (hgv && tmp != KEY_x) /* never ambiguous */
7242 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7243 "Ambiguous call resolved as CORE::%s(), "
7244 "qualify as such or use &",
7249 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7250 && (!anydelim || *s != '#')) {
7251 /* no override, and not s### either; skipspace is safe here
7252 * check for => on following line */
7254 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7255 STRLEN soff = s - SvPVX(PL_linestr);
7257 arrow = *s == '=' && s[1] == '>';
7258 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7259 s = SvPVX(PL_linestr) + soff;
7267 /* Trade off - by using this evil construction we can pull the
7268 variable gv into the block labelled keylookup. If not, then
7269 we have to give it function scope so that the goto from the
7270 earlier ':' case doesn't bypass the initialisation. */
7271 just_a_word_zero_gv:
7281 default: /* not a keyword */
7284 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7286 bool no_op_error = FALSE;
7288 if (PL_expect == XOPERATOR) {
7289 if (PL_bufptr == PL_linestart) {
7290 CopLINE_dec(PL_curcop);
7291 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7292 CopLINE_inc(PL_curcop);
7295 /* We want to call no_op with s pointing after the
7296 bareword, so defer it. But we want it to come
7297 before the Bad name croak. */
7301 /* Get the rest if it looks like a package qualifier */
7303 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7305 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7308 no_op("Bareword",s);
7309 no_op_error = FALSE;
7312 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7313 UTF8fARG(UTF, len, PL_tokenbuf),
7314 *s == '\'' ? "'" : "::");
7320 no_op("Bareword",s);
7322 /* See if the name is "Foo::",
7323 in which case Foo is a bareword
7324 (and a package name). */
7327 && PL_tokenbuf[len - 2] == ':'
7328 && PL_tokenbuf[len - 1] == ':')
7330 if (ckWARN(WARN_BAREWORD)
7331 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7332 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7333 "Bareword \"%" UTF8f
7334 "\" refers to nonexistent package",
7335 UTF8fARG(UTF, len, PL_tokenbuf));
7337 PL_tokenbuf[len] = '\0';
7346 /* if we saw a global override before, get the right name */
7349 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7352 SV * const tmp_sv = sv;
7353 sv = newSVpvs("CORE::GLOBAL::");
7354 sv_catsv(sv, tmp_sv);
7355 SvREFCNT_dec(tmp_sv);
7359 /* Presume this is going to be a bareword of some sort. */
7361 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7362 pl_yylval.opval->op_private = OPpCONST_BARE;
7364 /* And if "Foo::", then that's what it certainly is. */
7370 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7371 const_op->op_private = OPpCONST_BARE;
7373 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7377 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7380 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7383 /* Use this var to track whether intuit_method has been
7384 called. intuit_method returns 0 or > 255. */
7387 /* See if it's the indirect object for a list operator. */
7390 && PL_oldoldbufptr < PL_bufptr
7391 && (PL_oldoldbufptr == PL_last_lop
7392 || PL_oldoldbufptr == PL_last_uni)
7393 && /* NO SKIPSPACE BEFORE HERE! */
7395 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7398 bool immediate_paren = *s == '(';
7401 /* (Now we can afford to cross potential line boundary.) */
7404 /* intuit_method() can indirectly call lex_next_chunk(),
7407 s_off = s - SvPVX(PL_linestr);
7408 /* Two barewords in a row may indicate method call. */
7409 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7411 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7413 /* the code at method: doesn't use s */
7416 s = SvPVX(PL_linestr) + s_off;
7418 /* If not a declared subroutine, it's an indirect object. */
7419 /* (But it's an indir obj regardless for sort.) */
7420 /* Also, if "_" follows a filetest operator, it's a bareword */
7423 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7425 && (PL_last_lop_op != OP_MAPSTART
7426 && PL_last_lop_op != OP_GREPSTART))))
7427 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7428 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7432 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7437 PL_expect = XOPERATOR;
7440 /* Is this a word before a => operator? */
7441 if (*s == '=' && s[1] == '>' && !pkgname) {
7444 if (gvp || (lex && !off)) {
7445 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7446 /* This is our own scalar, created a few lines
7447 above, so this is safe. */
7449 sv_setpv(sv, PL_tokenbuf);
7450 if (UTF && !IN_BYTES
7451 && is_utf8_string((U8*)PL_tokenbuf, len))
7458 /* If followed by a paren, it's certainly a subroutine. */
7463 while (SPACE_OR_TAB(*d))
7465 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7470 NEXTVAL_NEXTTOKE.opval =
7471 off ? rv2cv_op : pl_yylval.opval;
7473 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7474 else op_free(rv2cv_op), force_next(BAREWORD);
7479 /* If followed by var or block, call it a method (unless sub) */
7481 if ((*s == '$' || *s == '{') && !cv) {
7483 PL_last_lop = PL_oldbufptr;
7484 PL_last_lop_op = OP_METHOD;
7485 if (!PL_lex_allbrackets
7486 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7488 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7490 PL_expect = XBLOCKTERM;
7492 return REPORT(METHOD);
7495 /* If followed by a bareword, see if it looks like indir obj. */
7499 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7500 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7504 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7506 sv_setpvn(sv, PL_tokenbuf, len);
7507 if (UTF && !IN_BYTES
7508 && is_utf8_string((U8*)PL_tokenbuf, len))
7510 else SvUTF8_off(sv);
7513 if (tmp == METHOD && !PL_lex_allbrackets
7514 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7516 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7521 /* Not a method, so call it a subroutine (if defined) */
7524 /* Check for a constant sub */
7525 if ((sv = cv_const_sv_or_av(cv))) {
7528 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7529 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7530 if (SvTYPE(sv) == SVt_PVAV)
7531 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7534 pl_yylval.opval->op_private = 0;
7535 pl_yylval.opval->op_folded = 1;
7536 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7541 op_free(pl_yylval.opval);
7543 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7544 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7545 PL_last_lop = PL_oldbufptr;
7546 PL_last_lop_op = OP_ENTERSUB;
7547 /* Is there a prototype? */
7551 STRLEN protolen = CvPROTOLEN(cv);
7552 const char *proto = CvPROTO(cv);
7554 proto = S_strip_spaces(aTHX_ proto, &protolen);
7557 if ((optional = *proto == ';'))
7560 while (*proto == ';');
7564 *proto == '$' || *proto == '_'
7565 || *proto == '*' || *proto == '+'
7570 *proto == '\\' && proto[1] && proto[2] == '\0'
7573 UNIPROTO(UNIOPSUB,optional);
7574 if (*proto == '\\' && proto[1] == '[') {
7575 const char *p = proto + 2;
7576 while(*p && *p != ']')
7578 if(*p == ']' && !p[1])
7579 UNIPROTO(UNIOPSUB,optional);
7581 if (*proto == '&' && *s == '{') {
7583 sv_setpvs(PL_subname, "__ANON__");
7585 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7586 if (!PL_lex_allbrackets
7587 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7589 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7594 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7596 force_next(off ? PRIVATEREF : BAREWORD);
7597 if (!PL_lex_allbrackets
7598 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7600 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7605 /* Call it a bare word */
7607 if (PL_hints & HINT_STRICT_SUBS)
7608 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7611 /* after "print" and similar functions (corresponding to
7612 * "F? L" in opcode.pl), whatever wasn't already parsed as
7613 * a filehandle should be subject to "strict subs".
7614 * Likewise for the optional indirect-object argument to system
7615 * or exec, which can't be a bareword */
7616 if ((PL_last_lop_op == OP_PRINT
7617 || PL_last_lop_op == OP_PRTF
7618 || PL_last_lop_op == OP_SAY
7619 || PL_last_lop_op == OP_SYSTEM
7620 || PL_last_lop_op == OP_EXEC)
7621 && (PL_hints & HINT_STRICT_SUBS))
7622 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7623 if (lastchar != '-') {
7624 if (ckWARN(WARN_RESERVED)) {
7628 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7630 /* PL_warn_reserved is constant */
7631 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7632 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7634 GCC_DIAG_RESTORE_STMT;
7642 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7643 && saw_infix_sigil) {
7644 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7645 "Operator or semicolon missing before %c%" UTF8f,
7647 UTF8fARG(UTF, strlen(PL_tokenbuf),
7649 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7650 "Ambiguous use of %c resolved as operator %c",
7651 lastchar, lastchar);
7658 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7663 newSVOP(OP_CONST, 0,
7664 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7667 case KEY___PACKAGE__:
7669 newSVOP(OP_CONST, 0,
7671 ? newSVhek(HvNAME_HEK(PL_curstash))
7678 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7679 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7682 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7684 gv_init(gv,stash,"DATA",4,0);
7687 GvIOp(gv) = newIO();
7688 IoIFP(GvIOp(gv)) = PL_rsfp;
7689 /* Mark this internal pseudo-handle as clean */
7690 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7691 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7692 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7694 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7695 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7696 /* if the script was opened in binmode, we need to revert
7697 * it to text mode for compatibility; but only iff it has CRs
7698 * XXX this is a questionable hack at best. */
7699 if (PL_bufend-PL_bufptr > 2
7700 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7703 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7704 loc = PerlIO_tell(PL_rsfp);
7705 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7708 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7710 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7711 #endif /* NETWARE */
7713 PerlIO_seek(PL_rsfp, loc, 0);
7717 #ifdef PERLIO_LAYERS
7720 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7729 FUN0OP(CvCLONE(PL_compcv)
7730 ? newOP(OP_RUNCV, 0)
7731 : newPVOP(OP_RUNCV,0,NULL));
7740 if (PL_expect == XSTATE) {
7751 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7752 if ((*s == ':' && s[1] == ':')
7753 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7757 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7761 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7762 UTF8fARG(UTF, len, PL_tokenbuf));
7765 else if (tmp == KEY_require || tmp == KEY_do
7767 /* that's a way to remember we saw "CORE::" */
7779 LOP(OP_ACCEPT,XTERM);
7782 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7787 LOP(OP_ATAN2,XTERM);
7793 LOP(OP_BINMODE,XTERM);
7796 LOP(OP_BLESS,XTERM);
7805 /* We have to disambiguate the two senses of
7806 "continue". If the next token is a '{' then
7807 treat it as the start of a continue block;
7808 otherwise treat it as a control operator.
7818 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7828 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7837 if (!PL_cryptseen) {
7838 PL_cryptseen = TRUE;
7842 LOP(OP_CRYPT,XTERM);
7845 LOP(OP_CHMOD,XTERM);
7848 LOP(OP_CHOWN,XTERM);
7851 LOP(OP_CONNECT,XTERM);
7871 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7873 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
7874 && !keyword(PL_tokenbuf + 1, len, 0)) {
7875 SSize_t off = s-SvPVX(PL_linestr);
7877 s = SvPVX(PL_linestr)+off;
7879 force_ident_maybe_lex('&');
7884 if (orig_keyword == KEY_do) {
7893 PL_hints |= HINT_BLOCK_SCOPE;
7903 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7904 STR_WITH_LEN("NDBM_File::"),
7905 STR_WITH_LEN("DB_File::"),
7906 STR_WITH_LEN("GDBM_File::"),
7907 STR_WITH_LEN("SDBM_File::"),
7908 STR_WITH_LEN("ODBM_File::"),
7910 LOP(OP_DBMOPEN,XTERM);
7922 pl_yylval.ival = CopLINE(PL_curcop);
7926 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7938 if (*s == '{') { /* block eval */
7939 PL_expect = XTERMBLOCK;
7940 UNIBRACK(OP_ENTERTRY);
7942 else { /* string eval */
7944 UNIBRACK(OP_ENTEREVAL);
7949 UNIBRACK(-OP_ENTEREVAL);
7963 case KEY_endhostent:
7969 case KEY_endservent:
7972 case KEY_endprotoent:
7983 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7985 pl_yylval.ival = CopLINE(PL_curcop);
7987 if ( PL_expect == XSTATE
7988 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
7991 SSize_t s_off = s - SvPVX(PL_linestr);
7993 if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
7994 && isSPACE(*(p + 2)))
7998 else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
7999 && isSPACE(*(p + 3)))
8005 /* skip optional package name, as in "for my abc $x (..)" */
8006 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
8007 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8010 if (*p != '$' && *p != '\\')
8011 Perl_croak(aTHX_ "Missing $ on loop variable");
8013 /* The buffer may have been reallocated, update s */
8014 s = SvPVX(PL_linestr) + s_off;
8019 LOP(OP_FORMLINE,XTERM);
8028 LOP(OP_FCNTL,XTERM);
8034 LOP(OP_FLOCK,XTERM);
8037 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8042 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8047 LOP(OP_GREPSTART, XREF);
8064 case KEY_getpriority:
8065 LOP(OP_GETPRIORITY,XTERM);
8067 case KEY_getprotobyname:
8070 case KEY_getprotobynumber:
8071 LOP(OP_GPBYNUMBER,XTERM);
8073 case KEY_getprotoent:
8085 case KEY_getpeername:
8086 UNI(OP_GETPEERNAME);
8088 case KEY_gethostbyname:
8091 case KEY_gethostbyaddr:
8092 LOP(OP_GHBYADDR,XTERM);
8094 case KEY_gethostent:
8097 case KEY_getnetbyname:
8100 case KEY_getnetbyaddr:
8101 LOP(OP_GNBYADDR,XTERM);
8106 case KEY_getservbyname:
8107 LOP(OP_GSBYNAME,XTERM);
8109 case KEY_getservbyport:
8110 LOP(OP_GSBYPORT,XTERM);
8112 case KEY_getservent:
8115 case KEY_getsockname:
8116 UNI(OP_GETSOCKNAME);
8118 case KEY_getsockopt:
8119 LOP(OP_GSOCKOPT,XTERM);
8134 pl_yylval.ival = CopLINE(PL_curcop);
8135 Perl_ck_warner_d(aTHX_
8136 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8137 "given is experimental");
8142 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8150 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8152 pl_yylval.ival = CopLINE(PL_curcop);
8156 LOP(OP_INDEX,XTERM);
8162 LOP(OP_IOCTL,XTERM);
8189 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8194 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8208 LOP(OP_LISTEN,XTERM);
8217 s = scan_pat(s,OP_MATCH);
8218 TERM(sublex_start());
8221 LOP(OP_MAPSTART, XREF);
8224 LOP(OP_MKDIR,XTERM);
8227 LOP(OP_MSGCTL,XTERM);
8230 LOP(OP_MSGGET,XTERM);
8233 LOP(OP_MSGRCV,XTERM);
8236 LOP(OP_MSGSND,XTERM);
8243 yyerror(Perl_form(aTHX_
8244 "Can't redeclare \"%s\" in \"%s\"",
8245 tmp == KEY_my ? "my" :
8246 tmp == KEY_state ? "state" : "our",
8247 PL_in_my == KEY_my ? "my" :
8248 PL_in_my == KEY_state ? "state" : "our"));
8250 PL_in_my = (U16)tmp;
8252 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8253 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8254 if (memEQs(PL_tokenbuf, len, "sub"))
8256 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8257 if (!PL_in_my_stash) {
8261 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8262 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8263 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8266 else if (*s == '\\') {
8267 if (!FEATURE_MYREF_IS_ENABLED)
8268 Perl_croak(aTHX_ "The experimental declared_refs "
8269 "feature is not enabled");
8270 Perl_ck_warner_d(aTHX_
8271 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8272 "Declaring references is experimental");
8280 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8285 s = tokenize_use(0, s);
8289 if (*s == '(' || (s = skipspace(s), *s == '('))
8292 if (!PL_lex_allbrackets
8293 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8295 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8302 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8304 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8306 for (t=d; isSPACE(*t);)
8308 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8310 && !(t[0] == '=' && t[1] == '>')
8311 && !(t[0] == ':' && t[1] == ':')
8312 && !keyword(s, d-s, 0)
8314 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8315 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8316 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8322 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8324 pl_yylval.ival = OP_OR;
8334 LOP(OP_OPEN_DIR,XTERM);
8337 checkcomma(s,PL_tokenbuf,"filehandle");
8341 checkcomma(s,PL_tokenbuf,"filehandle");
8360 s = force_word(s,BAREWORD,FALSE,TRUE);
8362 s = force_strict_version(s);
8366 LOP(OP_PIPE_OP,XTERM);
8369 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8371 missingterm(NULL, 0);
8372 COPLINE_SET_FROM_MULTI_END;
8373 pl_yylval.ival = OP_CONST;
8374 TERM(sublex_start());
8381 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8383 missingterm(NULL, 0);
8384 COPLINE_SET_FROM_MULTI_END;
8385 PL_expect = XOPERATOR;
8386 if (SvCUR(PL_lex_stuff)) {
8387 int warned_comma = !ckWARN(WARN_QW);
8388 int warned_comment = warned_comma;
8389 d = SvPV_force(PL_lex_stuff, len);
8391 for (; isSPACE(*d) && len; --len, ++d)
8396 if (!warned_comma || !warned_comment) {
8397 for (; !isSPACE(*d) && len; --len, ++d) {
8398 if (!warned_comma && *d == ',') {
8399 Perl_warner(aTHX_ packWARN(WARN_QW),
8400 "Possible attempt to separate words with commas");
8403 else if (!warned_comment && *d == '#') {
8404 Perl_warner(aTHX_ packWARN(WARN_QW),
8405 "Possible attempt to put comments in qw() list");
8411 for (; !isSPACE(*d) && len; --len, ++d)
8414 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8415 words = op_append_elem(OP_LIST, words,
8416 newSVOP(OP_CONST, 0, tokeq(sv)));
8421 words = newNULLLIST();
8422 SvREFCNT_dec_NN(PL_lex_stuff);
8423 PL_lex_stuff = NULL;
8424 PL_expect = XOPERATOR;
8425 pl_yylval.opval = sawparens(words);
8430 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8432 missingterm(NULL, 0);
8433 pl_yylval.ival = OP_STRINGIFY;
8434 if (SvIVX(PL_lex_stuff) == '\'')
8435 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8436 TERM(sublex_start());
8439 s = scan_pat(s,OP_QR);
8440 TERM(sublex_start());
8443 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8445 missingterm(NULL, 0);
8446 pl_yylval.ival = OP_BACKTICK;
8447 TERM(sublex_start());
8455 s = force_version(s, FALSE);
8457 else if (*s != 'v' || !isDIGIT(s[1])
8458 || (s = force_version(s, TRUE), *s == 'v'))
8460 *PL_tokenbuf = '\0';
8461 s = force_word(s,BAREWORD,TRUE,TRUE);
8462 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8463 PL_tokenbuf + sizeof(PL_tokenbuf),
8466 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8467 GV_ADD | (UTF ? SVf_UTF8 : 0));
8470 yyerror("<> at require-statement should be quotes");
8472 if (orig_keyword == KEY_require) {
8478 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8480 PL_last_uni = PL_oldbufptr;
8481 PL_last_lop_op = OP_REQUIRE;
8483 return REPORT( (int)REQUIRE );
8492 LOP(OP_RENAME,XTERM);
8501 LOP(OP_RINDEX,XTERM);
8510 UNIDOR(OP_READLINE);
8513 UNIDOR(OP_BACKTICK);
8522 LOP(OP_REVERSE,XTERM);
8525 UNIDOR(OP_READLINK);
8532 if (pl_yylval.opval)
8533 TERM(sublex_start());
8535 TOKEN(1); /* force error */
8538 checkcomma(s,PL_tokenbuf,"filehandle");
8548 LOP(OP_SELECT,XTERM);
8554 LOP(OP_SEMCTL,XTERM);
8557 LOP(OP_SEMGET,XTERM);
8560 LOP(OP_SEMOP,XTERM);
8566 LOP(OP_SETPGRP,XTERM);
8568 case KEY_setpriority:
8569 LOP(OP_SETPRIORITY,XTERM);
8571 case KEY_sethostent:
8577 case KEY_setservent:
8580 case KEY_setprotoent:
8590 LOP(OP_SEEKDIR,XTERM);
8592 case KEY_setsockopt:
8593 LOP(OP_SSOCKOPT,XTERM);
8599 LOP(OP_SHMCTL,XTERM);
8602 LOP(OP_SHMGET,XTERM);
8605 LOP(OP_SHMREAD,XTERM);
8608 LOP(OP_SHMWRITE,XTERM);
8611 LOP(OP_SHUTDOWN,XTERM);
8620 LOP(OP_SOCKET,XTERM);
8622 case KEY_socketpair:
8623 LOP(OP_SOCKPAIR,XTERM);
8626 checkcomma(s,PL_tokenbuf,"subroutine name");
8629 s = force_word(s,BAREWORD,TRUE,TRUE);
8633 LOP(OP_SPLIT,XTERM);
8636 LOP(OP_SPRINTF,XTERM);
8639 LOP(OP_SPLICE,XTERM);
8654 LOP(OP_SUBSTR,XTERM);
8660 char * const tmpbuf = PL_tokenbuf + 1;
8661 expectation attrful;
8662 bool have_name, have_proto;
8663 const int key = tmp;
8664 SV *format_name = NULL;
8666 SSize_t off = s-SvPVX(PL_linestr);
8668 d = SvPVX(PL_linestr)+off;
8670 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8672 || (*s == ':' && s[1] == ':'))
8676 attrful = XATTRBLOCK;
8677 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8679 if (key == KEY_format)
8680 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8682 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8684 PL_tokenbuf, len + 1, 0
8686 sv_setpvn(PL_subname, tmpbuf, len);
8688 sv_setsv(PL_subname,PL_curstname);
8689 sv_catpvs(PL_subname,"::");
8690 sv_catpvn(PL_subname,tmpbuf,len);
8692 if (SvUTF8(PL_linestr))
8693 SvUTF8_on(PL_subname);
8700 if (key == KEY_my || key == KEY_our || key==KEY_state)
8703 /* diag_listed_as: Missing name in "%s sub" */
8705 "Missing name in \"%s\"", PL_bufptr);
8707 PL_expect = XTERMBLOCK;
8708 attrful = XATTRTERM;
8709 sv_setpvs(PL_subname,"?");
8713 if (key == KEY_format) {
8715 NEXTVAL_NEXTTOKE.opval
8716 = newSVOP(OP_CONST,0, format_name);
8717 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8718 force_next(BAREWORD);
8723 /* Look for a prototype */
8724 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8725 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8726 COPLINE_SET_FROM_MULTI_END;
8728 Perl_croak(aTHX_ "Prototype not terminated");
8729 (void)validate_proto(PL_subname, PL_lex_stuff,
8730 ckWARN(WARN_ILLEGALPROTO), 0);
8738 if (*s == ':' && s[1] != ':')
8739 PL_expect = attrful;
8740 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8741 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8742 key == KEY_DESTROY || key == KEY_BEGIN ||
8743 key == KEY_UNITCHECK || key == KEY_CHECK ||
8744 key == KEY_INIT || key == KEY_END ||
8745 key == KEY_my || key == KEY_state ||
8748 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8749 else if (*s != ';' && *s != '}')
8750 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8754 NEXTVAL_NEXTTOKE.opval =
8755 newSVOP(OP_CONST, 0, PL_lex_stuff);
8756 PL_lex_stuff = NULL;
8761 sv_setpvs(PL_subname, "__ANON__");
8763 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8766 force_ident_maybe_lex('&');
8771 LOP(OP_SYSTEM,XREF);
8774 LOP(OP_SYMLINK,XTERM);
8777 LOP(OP_SYSCALL,XTERM);
8780 LOP(OP_SYSOPEN,XTERM);
8783 LOP(OP_SYSSEEK,XTERM);
8786 LOP(OP_SYSREAD,XTERM);
8789 LOP(OP_SYSWRITE,XTERM);
8794 TERM(sublex_start());
8815 LOP(OP_TRUNCATE,XTERM);
8827 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8829 pl_yylval.ival = CopLINE(PL_curcop);
8833 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8835 pl_yylval.ival = CopLINE(PL_curcop);
8839 LOP(OP_UNLINK,XTERM);
8845 LOP(OP_UNPACK,XTERM);
8848 LOP(OP_UTIME,XTERM);
8854 LOP(OP_UNSHIFT,XTERM);
8857 s = tokenize_use(1, s);
8867 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8869 pl_yylval.ival = CopLINE(PL_curcop);
8870 Perl_ck_warner_d(aTHX_
8871 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8872 "when is experimental");
8876 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8878 pl_yylval.ival = CopLINE(PL_curcop);
8882 PL_hints |= HINT_BLOCK_SCOPE;
8889 LOP(OP_WAITPID,XTERM);
8895 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8896 * we use the same number on EBCDIC */
8897 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8901 if (PL_expect == XOPERATOR) {
8902 if (*s == '=' && !PL_lex_allbrackets
8903 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8913 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8915 pl_yylval.ival = OP_XOR;
8924 Looks up an identifier in the pad or in a package
8926 is_sig indicates that this is a subroutine signature variable
8927 rather than a plain pad var.
8930 PRIVATEREF if this is a lexical name.
8931 BAREWORD if this belongs to a package.
8934 if we're in a my declaration
8935 croak if they tried to say my($foo::bar)
8936 build the ops for a my() declaration
8937 if it's an access to a my() variable
8938 build ops for access to a my() variable
8939 if in a dq string, and they've said @foo and we can't find @foo
8941 build ops for a bareword
8945 S_pending_ident(pTHX)
8948 const char pit = (char)pl_yylval.ival;
8949 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8950 /* All routes through this function want to know if there is a colon. */
8951 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8953 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8954 "### Pending identifier '%s'\n", PL_tokenbuf); });
8955 assert(tokenbuf_len >= 2);
8957 /* if we're in a my(), we can't allow dynamics here.
8958 $foo'bar has already been turned into $foo::bar, so
8959 just check for colons.
8961 if it's a legal name, the OP is a PADANY.
8964 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8966 /* diag_listed_as: No package name allowed for variable %s
8968 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8969 "%se %s in \"our\"",
8970 *PL_tokenbuf=='&' ?"subroutin":"variabl",
8971 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8972 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8977 /* "my" variable %s can't be in a package */
8978 /* PL_no_myglob is constant */
8979 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
8980 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8981 PL_in_my == KEY_my ? "my" : "state",
8982 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8984 UTF ? SVf_UTF8 : 0);
8985 GCC_DIAG_RESTORE_STMT;
8988 if (PL_in_my == KEY_sigvar) {
8989 /* A signature 'padop' needs in addition, an op_first to
8990 * point to a child sigdefelem, and an extra field to hold
8991 * the signature index. We can achieve both by using an
8992 * UNOP_AUX and (ab)using the op_aux field to hold the
8993 * index. If we ever need more fields, use a real malloced
8994 * aux strut instead.
8996 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
8997 INT2PTR(UNOP_AUX_item *,
8998 (PL_parser->sig_elems)));
8999 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9000 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9004 o = newOP(OP_PADANY, 0);
9005 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9006 UTF ? SVf_UTF8 : 0);
9007 if (PL_in_my == KEY_sigvar)
9010 pl_yylval.opval = o;
9016 build the ops for accesses to a my() variable.
9021 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9023 if (tmp != NOT_IN_PAD) {
9024 /* might be an "our" variable" */
9025 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9026 /* build ops for a bareword */
9027 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9028 HEK * const stashname = HvNAME_HEK(stash);
9029 SV * const sym = newSVhek(stashname);
9030 sv_catpvs(sym, "::");
9031 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9032 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9033 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9037 ((PL_tokenbuf[0] == '$') ? SVt_PV
9038 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9043 pl_yylval.opval = newOP(OP_PADANY, 0);
9044 pl_yylval.opval->op_targ = tmp;
9050 Whine if they've said @foo or @foo{key} in a doublequoted string,
9051 and @foo (or %foo) isn't a variable we can find in the symbol
9054 if (ckWARN(WARN_AMBIGUOUS)
9056 && PL_lex_state != LEX_NORMAL
9057 && !PL_lex_brackets)
9059 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9060 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9062 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9065 /* Downgraded from fatal to warning 20000522 mjd */
9066 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9067 "Possible unintended interpolation of %" UTF8f
9069 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9073 /* build ops for a bareword */
9074 pl_yylval.opval = newSVOP(OP_CONST, 0,
9075 newSVpvn_flags(PL_tokenbuf + 1,
9077 UTF ? SVf_UTF8 : 0 ));
9078 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9080 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9081 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9082 | ( UTF ? SVf_UTF8 : 0 ),
9083 ((PL_tokenbuf[0] == '$') ? SVt_PV
9084 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9090 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9092 PERL_ARGS_ASSERT_CHECKCOMMA;
9094 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9095 if (ckWARN(WARN_SYNTAX)) {
9098 for (w = s+2; *w && level; w++) {
9106 /* the list of chars below is for end of statements or
9107 * block / parens, boolean operators (&&, ||, //) and branch
9108 * constructs (or, and, if, until, unless, while, err, for).
9109 * Not a very solid hack... */
9110 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9111 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9112 "%s (...) interpreted as function",name);
9115 while (s < PL_bufend && isSPACE(*s))
9119 while (s < PL_bufend && isSPACE(*s))
9121 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9122 const char * const w = s;
9123 s += UTF ? UTF8SKIP(s) : 1;
9124 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9125 s += UTF ? UTF8SKIP(s) : 1;
9126 while (s < PL_bufend && isSPACE(*s))
9130 if (keyword(w, s - w, 0))
9133 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9134 if (gv && GvCVu(gv))
9139 Copy(w, tmpbuf+1, s - w, char);
9141 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9142 if (off != NOT_IN_PAD) return;
9144 Perl_croak(aTHX_ "No comma allowed after %s", what);
9149 /* S_new_constant(): do any overload::constant lookup.
9151 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9152 Best used as sv=new_constant(..., sv, ...).
9153 If s, pv are NULL, calls subroutine with one argument,
9154 and <type> is used with error messages only.
9155 <type> is assumed to be well formed UTF-8 */
9158 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9159 SV *sv, SV *pv, const char *type, STRLEN typelen)
9162 HV * table = GvHV(PL_hintgv); /* ^H */
9167 const char *why1 = "", *why2 = "", *why3 = "";
9169 PERL_ARGS_ASSERT_NEW_CONSTANT;
9170 /* We assume that this is true: */
9171 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9174 /* charnames doesn't work well if there have been errors found */
9175 if (PL_error_count > 0 && *key == 'c')
9177 SvREFCNT_dec_NN(sv);
9178 return &PL_sv_undef;
9181 sv_2mortal(sv); /* Parent created it permanently */
9183 || ! (PL_hints & HINT_LOCALIZE_HH)
9184 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9189 /* Here haven't found what we're looking for. If it is charnames,
9190 * perhaps it needs to be loaded. Try doing that before giving up */
9192 Perl_load_module(aTHX_
9194 newSVpvs("_charnames"),
9195 /* version parameter; no need to specify it, as if
9196 * we get too early a version, will fail anyway,
9197 * not being able to find '_charnames' */
9202 assert(sp == PL_stack_sp);
9203 table = GvHV(PL_hintgv);
9205 && (PL_hints & HINT_LOCALIZE_HH)
9206 && (cvp = hv_fetch(table, key, keylen, FALSE))
9212 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9213 msg = Perl_form(aTHX_
9214 "Constant(%.*s) unknown",
9215 (int)(type ? typelen : len),
9221 why3 = "} is not defined";
9224 msg = Perl_form(aTHX_
9225 /* The +3 is for '\N{'; -4 for that, plus '}' */
9226 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9230 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9231 (int)(type ? typelen : len),
9232 (type ? type: s), why1, why2, why3);
9235 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9236 return SvREFCNT_inc_simple_NN(sv);
9241 pv = newSVpvn_flags(s, len, SVs_TEMP);
9243 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9245 typesv = &PL_sv_undef;
9247 PUSHSTACKi(PERLSI_OVERLOAD);
9259 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9263 /* Check the eval first */
9264 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9266 const char * errstr;
9267 sv_catpvs(errsv, "Propagated");
9268 errstr = SvPV_const(errsv, errlen);
9269 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9271 res = SvREFCNT_inc_simple_NN(sv);
9275 SvREFCNT_inc_simple_void_NN(res);
9284 why1 = "Call to &{$^H{";
9286 why3 = "}} did not return a defined value";
9288 (void)sv_2mortal(sv);
9295 PERL_STATIC_INLINE void
9296 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9297 bool is_utf8, bool check_dollar, bool tick_warn)
9300 const char *olds = *s;
9301 PERL_ARGS_ASSERT_PARSE_IDENT;
9303 while (*s < PL_bufend) {
9305 Perl_croak(aTHX_ "%s", ident_too_long);
9306 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9307 /* The UTF-8 case must come first, otherwise things
9308 * like c\N{COMBINING TILDE} would start failing, as the
9309 * isWORDCHAR_A case below would gobble the 'c' up.
9312 char *t = *s + UTF8SKIP(*s);
9313 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9316 if (*d + (t - *s) > e)
9317 Perl_croak(aTHX_ "%s", ident_too_long);
9318 Copy(*s, *d, t - *s, char);
9322 else if ( isWORDCHAR_A(**s) ) {
9325 } while (isWORDCHAR_A(**s) && *d < e);
9327 else if ( allow_package
9329 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9336 else if (allow_package && **s == ':' && (*s)[1] == ':'
9337 /* Disallow things like Foo::$bar. For the curious, this is
9338 * the code path that triggers the "Bad name after" warning
9339 * when looking for barewords.
9341 && !(check_dollar && (*s)[2] == '$')) {
9348 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9349 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9352 Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9355 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9356 "Old package separator used in string");
9357 if (olds[-1] == '#')
9361 if (*olds == '\'') {
9368 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9369 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9370 UTF8fARG(is_utf8, d2-d, d));
9375 /* Returns a NUL terminated string, with the length of the string written to
9379 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9382 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9383 bool is_utf8 = cBOOL(UTF);
9385 PERL_ARGS_ASSERT_SCAN_WORD;
9387 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9393 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9394 * iff Unicode semantics are to be used. The legal ones are any of:
9395 * a) all ASCII characters except:
9396 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9398 * The final case currently doesn't get this far in the program, so we
9399 * don't test for it. If that were to change, it would be ok to allow it.
9400 * b) When not under Unicode rules, any upper Latin1 character
9401 * c) Otherwise, when unicode rules are used, all XIDS characters.
9403 * Because all ASCII characters have the same representation whether
9404 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9405 * '{' without knowing if is UTF-8 or not. */
9406 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9407 (isGRAPH_A(*(s)) || ((is_utf8) \
9408 ? isIDFIRST_utf8_safe(s, e) \
9410 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9413 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9415 I32 herelines = PL_parser->herelines;
9416 SSize_t bracket = -1;
9419 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9420 bool is_utf8 = cBOOL(UTF);
9421 I32 orig_copline = 0, tmp_copline = 0;
9423 PERL_ARGS_ASSERT_SCAN_IDENT;
9425 if (isSPACE(*s) || !*s)
9428 while (isDIGIT(*s)) {
9430 Perl_croak(aTHX_ "%s", ident_too_long);
9434 else { /* See if it is a "normal" identifier */
9435 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9440 /* Either a digit variable, or parse_ident() found an identifier
9441 (anything valid as a bareword), so job done and return. */
9442 if (PL_lex_state != LEX_NORMAL)
9443 PL_lex_state = LEX_INTERPENDMAYBE;
9447 /* Here, it is not a run-of-the-mill identifier name */
9449 if (*s == '$' && s[1]
9450 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9451 || isDIGIT_A((U8)s[1])
9454 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9456 /* Dereferencing a value in a scalar variable.
9457 The alternatives are different syntaxes for a scalar variable.
9458 Using ' as a leading package separator isn't allowed. :: is. */
9461 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9463 bracket = s - SvPVX(PL_linestr);
9465 orig_copline = CopLINE(PL_curcop);
9466 if (s < PL_bufend && isSPACE(*s)) {
9470 if ((s <= PL_bufend - (is_utf8)
9473 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9476 const STRLEN skip = UTF8SKIP(s);
9479 for ( i = 0; i < skip; i++ )
9487 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9488 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9492 /* Warn about ambiguous code after unary operators if {...} notation isn't
9493 used. There's no difference in ambiguity; it's merely a heuristic
9494 about when not to warn. */
9495 else if (ck_uni && bracket == -1)
9497 if (bracket != -1) {
9500 /* If we were processing {...} notation then... */
9501 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9502 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9505 /* note we have to check for a normal identifier first,
9506 * as it handles utf8 symbols, and only after that has
9507 * been ruled out can we look at the caret words */
9508 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9509 /* if it starts as a valid identifier, assume that it is one.
9510 (the later check for } being at the expected point will trap
9511 cases where this doesn't pan out.) */
9512 d += is_utf8 ? UTF8SKIP(d) : 1;
9513 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
9516 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9518 while (isWORDCHAR(*s) && d < e) {
9522 Perl_croak(aTHX_ "%s", ident_too_long);
9525 tmp_copline = CopLINE(PL_curcop);
9526 if (s < PL_bufend && isSPACE(*s)) {
9529 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9530 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9531 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9532 const char * const brack =
9534 ((*s == '[') ? "[...]" : "{...}");
9535 orig_copline = CopLINE(PL_curcop);
9536 CopLINE_set(PL_curcop, tmp_copline);
9537 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9538 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9539 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9540 funny, dest, brack, funny, dest, brack);
9541 CopLINE_set(PL_curcop, orig_copline);
9544 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9545 PL_lex_allbrackets++;
9551 tmp_copline = CopLINE(PL_curcop);
9552 if ((skip = s < PL_bufend && isSPACE(*s))) {
9553 /* Avoid incrementing line numbers or resetting PL_linestart,
9554 in case we have to back up. */
9555 STRLEN s_off = s - SvPVX(PL_linestr);
9557 s = SvPVX(PL_linestr) + s_off;
9562 /* Expect to find a closing } after consuming any trailing whitespace.
9565 /* Now increment line numbers if applicable. */
9569 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9570 PL_lex_state = LEX_INTERPEND;
9573 if (PL_lex_state == LEX_NORMAL) {
9574 if (ckWARN(WARN_AMBIGUOUS)
9575 && (keyword(dest, d - dest, 0)
9576 || get_cvn_flags(dest, d - dest, is_utf8
9580 SV *tmp = newSVpvn_flags( dest, d - dest,
9581 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9584 orig_copline = CopLINE(PL_curcop);
9585 CopLINE_set(PL_curcop, tmp_copline);
9586 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9587 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9588 funny, SVfARG(tmp), funny, SVfARG(tmp));
9589 CopLINE_set(PL_curcop, orig_copline);
9594 /* Didn't find the closing } at the point we expected, so restore
9595 state such that the next thing to process is the opening { and */
9596 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9597 CopLINE_set(PL_curcop, orig_copline);
9598 PL_parser->herelines = herelines;
9600 PL_parser->sub_no_recover = TRUE;
9603 else if ( PL_lex_state == LEX_INTERPNORMAL
9605 && !intuit_more(s, PL_bufend))
9606 PL_lex_state = LEX_INTERPEND;
9611 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9613 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9614 * found in the parse starting at 's', based on the subset that are valid
9615 * in this context input to this routine in 'valid_flags'. Advances s.
9616 * Returns TRUE if the input should be treated as a valid flag, so the next
9617 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9618 * upon first call on the current regex. This routine will set it to any
9619 * charset modifier found. The caller shouldn't change it. This way,
9620 * another charset modifier encountered in the parse can be detected as an
9621 * error, as we have decided to allow only one */
9624 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9626 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9627 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9628 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9629 UTF ? SVf_UTF8 : 0);
9631 /* Pretend that it worked, so will continue processing before
9640 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9641 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9642 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9643 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9644 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9645 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9646 case LOCALE_PAT_MOD:
9648 goto multiple_charsets;
9650 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9653 case UNICODE_PAT_MOD:
9655 goto multiple_charsets;
9657 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9660 case ASCII_RESTRICT_PAT_MOD:
9662 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9666 /* Error if previous modifier wasn't an 'a', but if it was, see
9667 * if, and accept, a second occurrence (only) */
9669 || get_regex_charset(*pmfl)
9670 != REGEX_ASCII_RESTRICTED_CHARSET)
9672 goto multiple_charsets;
9674 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9678 case DEPENDS_PAT_MOD:
9680 goto multiple_charsets;
9682 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9691 if (*charset != c) {
9692 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9694 else if (c == 'a') {
9695 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9696 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9699 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9702 /* Pretend that it worked, so will continue processing before dieing */
9708 S_scan_pat(pTHX_ char *start, I32 type)
9712 const char * const valid_flags =
9713 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9714 char charset = '\0'; /* character set modifier */
9715 unsigned int x_mod_count = 0;
9717 PERL_ARGS_ASSERT_SCAN_PAT;
9719 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9721 Perl_croak(aTHX_ "Search pattern not terminated");
9723 pm = (PMOP*)newPMOP(type, 0);
9724 if (PL_multi_open == '?') {
9725 /* This is the only point in the code that sets PMf_ONCE: */
9726 pm->op_pmflags |= PMf_ONCE;
9728 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9729 allows us to restrict the list needed by reset to just the ??
9731 assert(type != OP_TRANS);
9733 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9736 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9739 elements = mg->mg_len / sizeof(PMOP**);
9740 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9741 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9742 mg->mg_len = elements * sizeof(PMOP**);
9743 PmopSTASH_set(pm,PL_curstash);
9747 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9748 * anon CV. False positives like qr/[(?{]/ are harmless */
9750 if (type == OP_QR) {
9752 char *e, *p = SvPV(PL_lex_stuff, len);
9754 for (; p < e; p++) {
9755 if (p[0] == '(' && p[1] == '?'
9756 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9758 pm->op_pmflags |= PMf_HAS_CV;
9762 pm->op_pmflags |= PMf_IS_QR;
9765 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9766 &s, &charset, &x_mod_count))
9768 /* issue a warning if /c is specified,but /g is not */
9769 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9771 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9772 "Use of /c modifier is meaningless without /g" );
9775 PL_lex_op = (OP*)pm;
9776 pl_yylval.ival = OP_MATCH;
9781 S_scan_subst(pTHX_ char *start)
9787 line_t linediff = 0;
9789 char charset = '\0'; /* character set modifier */
9790 unsigned int x_mod_count = 0;
9793 PERL_ARGS_ASSERT_SCAN_SUBST;
9795 pl_yylval.ival = OP_NULL;
9797 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9800 Perl_croak(aTHX_ "Substitution pattern not terminated");
9804 first_start = PL_multi_start;
9805 first_line = CopLINE(PL_curcop);
9806 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9808 SvREFCNT_dec_NN(PL_lex_stuff);
9809 PL_lex_stuff = NULL;
9810 Perl_croak(aTHX_ "Substitution replacement not terminated");
9812 PL_multi_start = first_start; /* so whole substitution is taken together */
9814 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9818 if (*s == EXEC_PAT_MOD) {
9822 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9823 &s, &charset, &x_mod_count))
9829 if ((pm->op_pmflags & PMf_CONTINUE)) {
9830 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9834 SV * const repl = newSVpvs("");
9837 pm->op_pmflags |= PMf_EVAL;
9838 for (; es > 1; es--) {
9839 sv_catpvs(repl, "eval ");
9841 sv_catpvs(repl, "do {");
9842 sv_catsv(repl, PL_parser->lex_sub_repl);
9843 sv_catpvs(repl, "}");
9844 SvREFCNT_dec(PL_parser->lex_sub_repl);
9845 PL_parser->lex_sub_repl = repl;
9849 linediff = CopLINE(PL_curcop) - first_line;
9851 CopLINE_set(PL_curcop, first_line);
9853 if (linediff || es) {
9854 /* the IVX field indicates that the replacement string is a s///e;
9855 * the NVX field indicates how many src code lines the replacement
9857 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9858 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
9859 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9863 PL_lex_op = (OP*)pm;
9864 pl_yylval.ival = OP_SUBST;
9869 S_scan_trans(pTHX_ char *start)
9876 bool nondestruct = 0;
9879 PERL_ARGS_ASSERT_SCAN_TRANS;
9881 pl_yylval.ival = OP_NULL;
9883 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9885 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9889 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9891 SvREFCNT_dec_NN(PL_lex_stuff);
9892 PL_lex_stuff = NULL;
9893 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9896 complement = del = squash = 0;
9900 complement = OPpTRANS_COMPLEMENT;
9903 del = OPpTRANS_DELETE;
9906 squash = OPpTRANS_SQUASH;
9918 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9919 o->op_private &= ~OPpTRANS_ALL;
9920 o->op_private |= del|squash|complement|
9921 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9922 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9925 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9932 Takes a pointer to the first < in <<FOO.
9933 Returns a pointer to the byte following <<FOO.
9935 This function scans a heredoc, which involves different methods
9936 depending on whether we are in a string eval, quoted construct, etc.
9937 This is because PL_linestr could containing a single line of input, or
9938 a whole string being evalled, or the contents of the current quote-
9941 The two basic methods are:
9942 - Steal lines from the input stream
9943 - Scan the heredoc in PL_linestr and remove it therefrom
9945 In a file scope or filtered eval, the first method is used; in a
9946 string eval, the second.
9948 In a quote-like operator, we have to choose between the two,
9949 depending on where we can find a newline. We peek into outer lex-
9950 ing scopes until we find one with a newline in it. If we reach the
9951 outermost lexing scope and it is a file, we use the stream method.
9952 Otherwise it is treated as an eval.
9956 S_scan_heredoc(pTHX_ char *s)
9958 I32 op_type = OP_SCALAR;
9967 bool indented = FALSE;
9968 const bool infile = PL_rsfp || PL_parser->filtered;
9969 const line_t origline = CopLINE(PL_curcop);
9970 LEXSHARED *shared = PL_parser->lex_shared;
9972 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9975 d = PL_tokenbuf + 1;
9976 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9977 *PL_tokenbuf = '\n';
9983 while (SPACE_OR_TAB(*peek))
9985 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9988 s = delimcpy(d, e, s, PL_bufend, term, &len);
9990 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9996 /* <<\FOO is equivalent to <<'FOO' */
10000 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10001 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10003 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10004 peek += UTF ? UTF8SKIP(peek) : 1;
10006 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10007 Copy(s, d, len, char);
10011 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10012 Perl_croak(aTHX_ "Delimiter for here document is too long");
10015 len = d - PL_tokenbuf;
10017 #ifndef PERL_STRICT_CR
10018 d = (char *) memchr(s, '\r', PL_bufend - s);
10020 char * const olds = s;
10022 while (s < PL_bufend) {
10028 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10037 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10042 tmpstr = newSV_type(SVt_PVIV);
10043 SvGROW(tmpstr, 80);
10044 if (term == '\'') {
10045 op_type = OP_CONST;
10046 SvIV_set(tmpstr, -1);
10048 else if (term == '`') {
10049 op_type = OP_BACKTICK;
10050 SvIV_set(tmpstr, '\\');
10053 PL_multi_start = origline + 1 + PL_parser->herelines;
10054 PL_multi_open = PL_multi_close = '<';
10055 /* inside a string eval or quote-like operator */
10056 if (!infile || PL_lex_inwhat) {
10059 char * const olds = s;
10060 PERL_CONTEXT * const cx = CX_CUR();
10061 /* These two fields are not set until an inner lexing scope is
10062 entered. But we need them set here. */
10063 shared->ls_bufptr = s;
10064 shared->ls_linestr = PL_linestr;
10066 /* Look for a newline. If the current buffer does not have one,
10067 peek into the line buffer of the parent lexing scope, going
10068 up as many levels as necessary to find one with a newline
10071 while (!(s = (char *)memchr(
10072 (void *)shared->ls_bufptr, '\n',
10073 SvEND(shared->ls_linestr)-shared->ls_bufptr
10075 shared = shared->ls_prev;
10076 /* shared is only null if we have gone beyond the outermost
10077 lexing scope. In a file, we will have broken out of the
10078 loop in the previous iteration. In an eval, the string buf-
10079 fer ends with "\n;", so the while condition above will have
10080 evaluated to false. So shared can never be null. Or so you
10081 might think. Odd syntax errors like s;@{<<; can gobble up
10082 the implicit semicolon at the end of a flie, causing the
10083 file handle to be closed even when we are not in a string
10084 eval. So shared may be null in that case.
10085 (Closing '}' here to balance the earlier open brace for
10086 editors that look for matched pairs.) */
10087 if (UNLIKELY(!shared))
10089 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10090 most lexing scope. In a file, shared->ls_linestr at that
10091 level is just one line, so there is no body to steal. */
10092 if (infile && !shared->ls_prev) {
10097 else { /* eval or we've already hit EOF */
10098 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10102 linestr = shared->ls_linestr;
10103 bufend = SvEND(linestr);
10108 while (s < bufend - len + 1) {
10110 ++PL_parser->herelines;
10112 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10116 /* Only valid if it's preceded by whitespace only */
10117 while (backup != myolds && --backup >= myolds) {
10118 if (! SPACE_OR_TAB(*backup)) {
10125 /* No whitespace or all! */
10126 if (backup == s || *backup == '\n') {
10127 Newx(indent, indent_len + 1, char);
10128 memcpy(indent, backup + 1, indent_len);
10129 indent[indent_len] = 0;
10130 s--; /* before our delimiter */
10131 PL_parser->herelines--; /* this line doesn't count */
10137 while (s < bufend - len + 1
10138 && memNE(s,PL_tokenbuf,len) )
10141 ++PL_parser->herelines;
10145 if (s >= bufend - len + 1) {
10148 sv_setpvn(tmpstr,d+1,s-d);
10150 /* the preceding stmt passes a newline */
10151 PL_parser->herelines++;
10153 /* s now points to the newline after the heredoc terminator.
10154 d points to the newline before the body of the heredoc.
10157 /* We are going to modify linestr in place here, so set
10158 aside copies of the string if necessary for re-evals or
10160 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10161 check shared->re_eval_str. */
10162 if (shared->re_eval_start || shared->re_eval_str) {
10163 /* Set aside the rest of the regexp */
10164 if (!shared->re_eval_str)
10165 shared->re_eval_str =
10166 newSVpvn(shared->re_eval_start,
10167 bufend - shared->re_eval_start);
10168 shared->re_eval_start -= s-d;
10170 if (cxstack_ix >= 0
10171 && CxTYPE(cx) == CXt_EVAL
10172 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10173 && cx->blk_eval.cur_text == linestr)
10175 cx->blk_eval.cur_text = newSVsv(linestr);
10176 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10178 /* Copy everything from s onwards back to d. */
10179 Move(s,d,bufend-s + 1,char);
10180 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10181 /* Setting PL_bufend only applies when we have not dug deeper
10182 into other scopes, because sublex_done sets PL_bufend to
10183 SvEND(PL_linestr). */
10184 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10190 char *oldbufptr_save;
10191 char *oldoldbufptr_save;
10193 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10194 term = PL_tokenbuf[1];
10196 linestr_save = PL_linestr; /* must restore this afterwards */
10197 d = s; /* and this */
10198 oldbufptr_save = PL_oldbufptr;
10199 oldoldbufptr_save = PL_oldoldbufptr;
10200 PL_linestr = newSVpvs("");
10201 PL_bufend = SvPVX(PL_linestr);
10203 PL_bufptr = PL_bufend;
10204 CopLINE_set(PL_curcop,
10205 origline + 1 + PL_parser->herelines);
10206 if (!lex_next_chunk(LEX_NO_TERM)
10207 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10208 /* Simply freeing linestr_save might seem simpler here, as it
10209 does not matter what PL_linestr points to, since we are
10210 about to croak; but in a quote-like op, linestr_save
10211 will have been prospectively freed already, via
10212 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10213 restore PL_linestr. */
10214 SvREFCNT_dec_NN(PL_linestr);
10215 PL_linestr = linestr_save;
10216 PL_oldbufptr = oldbufptr_save;
10217 PL_oldoldbufptr = oldoldbufptr_save;
10220 CopLINE_set(PL_curcop, origline);
10221 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10222 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10223 /* ^That should be enough to avoid this needing to grow: */
10224 sv_catpvs(PL_linestr, "\n\0");
10225 assert(s == SvPVX(PL_linestr));
10226 PL_bufend = SvEND(PL_linestr);
10229 PL_parser->herelines++;
10230 PL_last_lop = PL_last_uni = NULL;
10231 #ifndef PERL_STRICT_CR
10232 if (PL_bufend - PL_linestart >= 2) {
10233 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10234 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10236 PL_bufend[-2] = '\n';
10238 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10240 else if (PL_bufend[-1] == '\r')
10241 PL_bufend[-1] = '\n';
10243 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10244 PL_bufend[-1] = '\n';
10246 if (indented && (PL_bufend-s) >= len) {
10247 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10250 char *backup = found;
10253 /* Only valid if it's preceded by whitespace only */
10254 while (backup != s && --backup >= s) {
10255 if (! SPACE_OR_TAB(*backup)) {
10261 /* All whitespace or none! */
10262 if (backup == found || SPACE_OR_TAB(*backup)) {
10263 Newx(indent, indent_len + 1, char);
10264 memcpy(indent, backup, indent_len);
10265 indent[indent_len] = 0;
10266 SvREFCNT_dec(PL_linestr);
10267 PL_linestr = linestr_save;
10268 PL_linestart = SvPVX(linestr_save);
10269 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10270 PL_oldbufptr = oldbufptr_save;
10271 PL_oldoldbufptr = oldoldbufptr_save;
10277 /* Didn't find it */
10278 sv_catsv(tmpstr,PL_linestr);
10280 if (*s == term && PL_bufend-s >= len
10281 && memEQ(s,PL_tokenbuf + 1,len))
10283 SvREFCNT_dec(PL_linestr);
10284 PL_linestr = linestr_save;
10285 PL_linestart = SvPVX(linestr_save);
10286 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10287 PL_oldbufptr = oldbufptr_save;
10288 PL_oldoldbufptr = oldoldbufptr_save;
10292 sv_catsv(tmpstr,PL_linestr);
10297 PL_multi_end = origline + PL_parser->herelines;
10298 if (indented && indent) {
10299 STRLEN linecount = 1;
10300 STRLEN herelen = SvCUR(tmpstr);
10301 char *ss = SvPVX(tmpstr);
10302 char *se = ss + herelen;
10303 SV *newstr = newSV(herelen+1);
10306 /* Trim leading whitespace */
10308 /* newline only? Copy and move on */
10310 sv_catpv(newstr,"\n");
10314 /* Found our indentation? Strip it */
10315 } else if (se - ss >= indent_len
10316 && memEQ(ss, indent, indent_len))
10322 while ((ss + le) < se && *(ss + le) != '\n')
10325 sv_catpvn(newstr, ss, le);
10329 /* Line doesn't begin with our indentation? Croak */
10332 "Indentation on line %d of here-doc doesn't match delimiter",
10337 /* avoid sv_setsv() as we dont wan't to COW here */
10338 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10340 SvREFCNT_dec_NN(newstr);
10342 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10343 SvPV_shrink_to_cur(tmpstr);
10346 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10349 PL_lex_stuff = tmpstr;
10350 pl_yylval.ival = op_type;
10354 SvREFCNT_dec(tmpstr);
10355 CopLINE_set(PL_curcop, origline);
10356 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10359 /* scan_inputsymbol
10360 takes: position of first '<' in input buffer
10361 returns: position of first char following the matching '>' in
10363 side-effects: pl_yylval and lex_op are set.
10368 <<>> read from ARGV without magic open
10369 <FH> read from filehandle
10370 <pkg::FH> read from package qualified filehandle
10371 <pkg'FH> read from package qualified filehandle
10372 <$fh> read from filehandle in $fh
10373 <*.h> filename glob
10378 S_scan_inputsymbol(pTHX_ char *start)
10380 char *s = start; /* current position in buffer */
10383 bool nomagicopen = FALSE;
10384 char *d = PL_tokenbuf; /* start of temp holding space */
10385 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10387 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10389 end = (char *) memchr(s, '\n', PL_bufend - s);
10392 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10393 nomagicopen = TRUE;
10399 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10401 /* die if we didn't have space for the contents of the <>,
10402 or if it didn't end, or if we see a newline
10405 if (len >= (I32)sizeof PL_tokenbuf)
10406 Perl_croak(aTHX_ "Excessively long <> operator");
10408 Perl_croak(aTHX_ "Unterminated <> operator");
10413 Remember, only scalar variables are interpreted as filehandles by
10414 this code. Anything more complex (e.g., <$fh{$num}>) will be
10415 treated as a glob() call.
10416 This code makes use of the fact that except for the $ at the front,
10417 a scalar variable and a filehandle look the same.
10419 if (*d == '$' && d[1]) d++;
10421 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10422 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10423 d += UTF ? UTF8SKIP(d) : 1;
10426 /* If we've tried to read what we allow filehandles to look like, and
10427 there's still text left, then it must be a glob() and not a getline.
10428 Use scan_str to pull out the stuff between the <> and treat it
10429 as nothing more than a string.
10432 if (d - PL_tokenbuf != len) {
10433 pl_yylval.ival = OP_GLOB;
10434 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10436 Perl_croak(aTHX_ "Glob not terminated");
10440 bool readline_overriden = FALSE;
10442 /* we're in a filehandle read situation */
10445 /* turn <> into <ARGV> */
10447 Copy("ARGV",d,5,char);
10449 /* Check whether readline() is overriden */
10450 if ((gv_readline = gv_override("readline",8)))
10451 readline_overriden = TRUE;
10453 /* if <$fh>, create the ops to turn the variable into a
10457 /* try to find it in the pad for this block, otherwise find
10458 add symbol table ops
10460 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10461 if (tmp != NOT_IN_PAD) {
10462 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10463 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10464 HEK * const stashname = HvNAME_HEK(stash);
10465 SV * const sym = sv_2mortal(newSVhek(stashname));
10466 sv_catpvs(sym, "::");
10467 sv_catpv(sym, d+1);
10472 OP * const o = newOP(OP_PADSV, 0);
10474 PL_lex_op = readline_overriden
10475 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10476 op_append_elem(OP_LIST, o,
10477 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10478 : newUNOP(OP_READLINE, 0, o);
10486 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10488 PL_lex_op = readline_overriden
10489 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10490 op_append_elem(OP_LIST,
10491 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10492 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10493 : newUNOP(OP_READLINE, 0,
10494 newUNOP(OP_RV2SV, 0,
10495 newGVOP(OP_GV, 0, gv)));
10497 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10498 pl_yylval.ival = OP_NULL;
10501 /* If it's none of the above, it must be a literal filehandle
10502 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10504 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10505 PL_lex_op = readline_overriden
10506 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10507 op_append_elem(OP_LIST,
10508 newGVOP(OP_GV, 0, gv),
10509 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10510 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10511 pl_yylval.ival = OP_NULL;
10521 start position in buffer
10522 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10523 only if they are of the open/close form
10524 keep_delims preserve the delimiters around the string
10525 re_reparse compiling a run-time /(?{})/:
10526 collapse // to /, and skip encoding src
10527 delimp if non-null, this is set to the position of
10528 the closing delimiter, or just after it if
10529 the closing and opening delimiters differ
10530 (i.e., the opening delimiter of a substitu-
10532 returns: position to continue reading from buffer
10533 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10534 updates the read buffer.
10536 This subroutine pulls a string out of the input. It is called for:
10537 q single quotes q(literal text)
10538 ' single quotes 'literal text'
10539 qq double quotes qq(interpolate $here please)
10540 " double quotes "interpolate $here please"
10541 qx backticks qx(/bin/ls -l)
10542 ` backticks `/bin/ls -l`
10543 qw quote words @EXPORT_OK = qw( func() $spam )
10544 m// regexp match m/this/
10545 s/// regexp substitute s/this/that/
10546 tr/// string transliterate tr/this/that/
10547 y/// string transliterate y/this/that/
10548 ($*@) sub prototypes sub foo ($)
10549 (stuff) sub attr parameters sub foo : attr(stuff)
10550 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10552 In most of these cases (all but <>, patterns and transliterate)
10553 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10554 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10555 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10558 It skips whitespace before the string starts, and treats the first
10559 character as the delimiter. If the delimiter is one of ([{< then
10560 the corresponding "close" character )]}> is used as the closing
10561 delimiter. It allows quoting of delimiters, and if the string has
10562 balanced delimiters ([{<>}]) it allows nesting.
10564 On success, the SV with the resulting string is put into lex_stuff or,
10565 if that is already non-NULL, into lex_repl. The second case occurs only
10566 when parsing the RHS of the special constructs s/// and tr/// (y///).
10567 For convenience, the terminating delimiter character is stuffed into
10572 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10576 SV *sv; /* scalar value: string */
10577 const char *tmps; /* temp string, used for delimiter matching */
10578 char *s = start; /* current position in the buffer */
10579 char term; /* terminating character */
10580 char *to; /* current position in the sv's data */
10581 I32 brackets = 1; /* bracket nesting level */
10582 bool has_utf8 = FALSE; /* is there any utf8 content? */
10583 IV termcode; /* terminating char. code */
10584 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
10585 STRLEN termlen; /* length of terminating string */
10588 /* The delimiters that have a mirror-image closing one */
10589 const char * opening_delims = "([{<";
10590 const char * closing_delims = ")]}>";
10592 const char * non_grapheme_msg = "Use of unassigned code point or"
10593 " non-standalone grapheme for a delimiter"
10594 " will be a fatal error starting in Perl"
10596 /* The only non-UTF character that isn't a stand alone grapheme is
10597 * white-space, hence can't be a delimiter. So can skip for non-UTF-8 */
10598 bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED);
10600 PERL_ARGS_ASSERT_SCAN_STR;
10602 /* skip space before the delimiter */
10607 /* mark where we are, in case we need to report errors */
10610 /* after skipping whitespace, the next character is the terminator */
10612 if (!UTF || UTF8_IS_INVARIANT(term)) {
10613 termcode = termstr[0] = term;
10617 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10618 if (check_grapheme) {
10619 if ( UNLIKELY(UNICODE_IS_SUPER(termcode))
10620 || UNLIKELY(UNICODE_IS_NONCHAR(termcode)))
10622 /* These are considered graphemes, and since the ending
10623 * delimiter will be the same, we don't have to check the other
10625 check_grapheme = FALSE;
10627 else if (UNLIKELY(! _is_grapheme((U8 *) start,
10632 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "%s", non_grapheme_msg);
10634 /* Don't have to check the other end, as have already warned at
10636 check_grapheme = FALSE;
10640 Copy(s, termstr, termlen, U8);
10643 /* mark where we are */
10644 PL_multi_start = CopLINE(PL_curcop);
10645 PL_multi_open = termcode;
10646 herelines = PL_parser->herelines;
10648 /* If the delimiter has a mirror-image closing one, get it */
10649 if (term && (tmps = strchr(opening_delims, term))) {
10650 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10653 PL_multi_close = termcode;
10655 if (PL_multi_open == PL_multi_close) {
10656 keep_bracketed_quoted = FALSE;
10659 /* create a new SV to hold the contents. 79 is the SV's initial length.
10660 What a random number. */
10661 sv = newSV_type(SVt_PVIV);
10663 SvIV_set(sv, termcode);
10664 (void)SvPOK_only(sv); /* validate pointer */
10666 /* move past delimiter and try to read a complete string */
10668 sv_catpvn(sv, s, termlen);
10671 /* extend sv if need be */
10672 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10673 /* set 'to' to the next character in the sv's string */
10674 to = SvPVX(sv)+SvCUR(sv);
10676 /* if open delimiter is the close delimiter read unbridle */
10677 if (PL_multi_open == PL_multi_close) {
10678 for (; s < PL_bufend; s++,to++) {
10679 /* embedded newlines increment the current line number */
10680 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10681 COPLINE_INC_WITH_HERELINES;
10682 /* handle quoted delimiters */
10683 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10684 if (!keep_bracketed_quoted
10686 || (re_reparse && s[1] == '\\'))
10689 else /* any other quotes are simply copied straight through */
10692 /* terminate when run out of buffer (the for() condition), or
10693 have found the terminator */
10694 else if (*s == term) { /* First byte of terminator matches */
10695 if (termlen == 1) /* If is the only byte, are done */
10698 /* If the remainder of the terminator matches, also are
10699 * done, after checking that is a separate grapheme */
10700 if ( s + termlen <= PL_bufend
10701 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10703 if ( check_grapheme
10704 && UNLIKELY(! _is_grapheme((U8 *) start,
10709 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10710 "%s", non_grapheme_msg);
10715 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10723 /* if the terminator isn't the same as the start character (e.g.,
10724 matched brackets), we have to allow more in the quoting, and
10725 be prepared for nested brackets.
10728 /* read until we run out of string, or we find the terminator */
10729 for (; s < PL_bufend; s++,to++) {
10730 /* embedded newlines increment the line count */
10731 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10732 COPLINE_INC_WITH_HERELINES;
10733 /* backslashes can escape the open or closing characters */
10734 if (*s == '\\' && s+1 < PL_bufend) {
10735 if (!keep_bracketed_quoted
10736 && ( ((UV)s[1] == PL_multi_open)
10737 || ((UV)s[1] == PL_multi_close) ))
10744 /* allow nested opens and closes */
10745 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10747 else if ((UV)*s == PL_multi_open)
10749 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10754 /* terminate the copied string and update the sv's end-of-string */
10756 SvCUR_set(sv, to - SvPVX_const(sv));
10759 * this next chunk reads more into the buffer if we're not done yet
10763 break; /* handle case where we are done yet :-) */
10765 #ifndef PERL_STRICT_CR
10766 if (to - SvPVX_const(sv) >= 2) {
10767 if ( (to[-2] == '\r' && to[-1] == '\n')
10768 || (to[-2] == '\n' && to[-1] == '\r'))
10772 SvCUR_set(sv, to - SvPVX_const(sv));
10774 else if (to[-1] == '\r')
10777 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10781 /* if we're out of file, or a read fails, bail and reset the current
10782 line marker so we can report where the unterminated string began
10784 COPLINE_INC_WITH_HERELINES;
10785 PL_bufptr = PL_bufend;
10786 if (!lex_next_chunk(0)) {
10788 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10791 s = start = PL_bufptr;
10794 /* at this point, we have successfully read the delimited string */
10797 sv_catpvn(sv, s, termlen);
10803 PL_multi_end = CopLINE(PL_curcop);
10804 CopLINE_set(PL_curcop, PL_multi_start);
10805 PL_parser->herelines = herelines;
10807 /* if we allocated too much space, give some back */
10808 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10809 SvLEN_set(sv, SvCUR(sv) + 1);
10810 SvPV_renew(sv, SvLEN(sv));
10813 /* decide whether this is the first or second quoted string we've read
10818 PL_parser->lex_sub_repl = sv;
10821 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10827 takes: pointer to position in buffer
10828 returns: pointer to new position in buffer
10829 side-effects: builds ops for the constant in pl_yylval.op
10831 Read a number in any of the formats that Perl accepts:
10833 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10834 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10835 0b[01](_?[01])* binary integers
10836 0[0-7](_?[0-7])* octal integers
10837 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10838 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10840 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10843 If it reads a number without a decimal point or an exponent, it will
10844 try converting the number to an integer and see if it can do so
10845 without loss of precision.
10849 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10851 const char *s = start; /* current position in buffer */
10852 char *d; /* destination in temp buffer */
10853 char *e; /* end of temp buffer */
10854 NV nv; /* number read, as a double */
10855 SV *sv = NULL; /* place to put the converted number */
10856 bool floatit; /* boolean: int or float? */
10857 const char *lastub = NULL; /* position of last underbar */
10858 static const char* const number_too_long = "Number too long";
10859 bool warned_about_underscore = 0;
10860 #define WARN_ABOUT_UNDERSCORE() \
10862 if (!warned_about_underscore) { \
10863 warned_about_underscore = 1; \
10864 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10865 "Misplaced _ in number"); \
10868 /* Hexadecimal floating point.
10870 * In many places (where we have quads and NV is IEEE 754 double)
10871 * we can fit the mantissa bits of a NV into an unsigned quad.
10872 * (Note that UVs might not be quads even when we have quads.)
10873 * This will not work everywhere, though (either no quads, or
10874 * using long doubles), in which case we have to resort to NV,
10875 * which will probably mean horrible loss of precision due to
10876 * multiple fp operations. */
10877 bool hexfp = FALSE;
10878 int total_bits = 0;
10879 int significant_bits = 0;
10880 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10881 # define HEXFP_UQUAD
10882 Uquad_t hexfp_uquad = 0;
10883 int hexfp_frac_bits = 0;
10888 NV hexfp_mult = 1.0;
10889 UV high_non_zero = 0; /* highest digit */
10890 int non_zero_integer_digits = 0;
10892 PERL_ARGS_ASSERT_SCAN_NUM;
10894 /* We use the first character to decide what type of number this is */
10898 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10900 /* if it starts with a 0, it could be an octal number, a decimal in
10901 0.13 disguise, or a hexadecimal number, or a binary number. */
10905 u holds the "number so far"
10906 shift the power of 2 of the base
10907 (hex == 4, octal == 3, binary == 1)
10908 overflowed was the number more than we can hold?
10910 Shift is used when we add a digit. It also serves as an "are
10911 we in octal/hex/binary?" indicator to disallow hex characters
10912 when in octal mode.
10917 bool overflowed = FALSE;
10918 bool just_zero = TRUE; /* just plain 0 or binary number? */
10919 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10920 static const char* const bases[5] =
10921 { "", "binary", "", "octal", "hexadecimal" };
10922 static const char* const Bases[5] =
10923 { "", "Binary", "", "Octal", "Hexadecimal" };
10924 static const char* const maxima[5] =
10926 "0b11111111111111111111111111111111",
10930 const char *base, *Base, *max;
10932 /* check for hex */
10933 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10937 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10942 /* check for a decimal in disguise */
10943 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10945 /* so it must be octal */
10952 WARN_ABOUT_UNDERSCORE();
10956 base = bases[shift];
10957 Base = Bases[shift];
10958 max = maxima[shift];
10960 /* read the rest of the number */
10962 /* x is used in the overflow test,
10963 b is the digit we're adding on. */
10968 /* if we don't mention it, we're done */
10972 /* _ are ignored -- but warned about if consecutive */
10974 if (lastub && s == lastub + 1)
10975 WARN_ABOUT_UNDERSCORE();
10979 /* 8 and 9 are not octal */
10980 case '8': case '9':
10982 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10986 case '2': case '3': case '4':
10987 case '5': case '6': case '7':
10989 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10992 case '0': case '1':
10993 b = *s++ & 15; /* ASCII digit -> value of digit */
10997 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10998 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10999 /* make sure they said 0x */
11002 b = (*s++ & 7) + 9;
11004 /* Prepare to put the digit we have onto the end
11005 of the number so far. We check for overflows.
11011 assert(shift >= 0);
11012 x = u << shift; /* make room for the digit */
11014 total_bits += shift;
11016 if ((x >> shift) != u
11017 && !(PL_hints & HINT_NEW_BINARY)) {
11020 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11021 "Integer overflow in %s number",
11024 u = x | b; /* add the digit to the end */
11027 n *= nvshift[shift];
11028 /* If an NV has not enough bits in its
11029 * mantissa to represent an UV this summing of
11030 * small low-order numbers is a waste of time
11031 * (because the NV cannot preserve the
11032 * low-order bits anyway): we could just
11033 * remember when did we overflow and in the
11034 * end just multiply n by the right
11039 if (high_non_zero == 0 && b > 0)
11043 non_zero_integer_digits++;
11045 /* this could be hexfp, but peek ahead
11046 * to avoid matching ".." */
11047 if (UNLIKELY(HEXFP_PEEK(s))) {
11055 /* if we get here, we had success: make a scalar value from
11060 /* final misplaced underbar check */
11062 WARN_ABOUT_UNDERSCORE();
11064 if (UNLIKELY(HEXFP_PEEK(s))) {
11065 /* Do sloppy (on the underbars) but quick detection
11066 * (and value construction) for hexfp, the decimal
11067 * detection will shortly be more thorough with the
11068 * underbar checks. */
11070 significant_bits = non_zero_integer_digits * shift;
11073 #else /* HEXFP_NV */
11076 /* Ignore the leading zero bits of
11077 * the high (first) non-zero digit. */
11078 if (high_non_zero) {
11079 if (high_non_zero < 0x8)
11080 significant_bits--;
11081 if (high_non_zero < 0x4)
11082 significant_bits--;
11083 if (high_non_zero < 0x2)
11084 significant_bits--;
11091 bool accumulate = TRUE;
11093 int lim = 1 << shift;
11094 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11096 if (isXDIGIT(*h)) {
11097 significant_bits += shift;
11100 if (significant_bits < NV_MANT_DIG) {
11101 /* We are in the long "run" of xdigits,
11102 * accumulate the full four bits. */
11103 assert(shift >= 0);
11104 hexfp_uquad <<= shift;
11106 hexfp_frac_bits += shift;
11107 } else if (significant_bits - shift < NV_MANT_DIG) {
11108 /* We are at a hexdigit either at,
11109 * or straddling, the edge of mantissa.
11110 * We will try grabbing as many as
11111 * possible bits. */
11113 significant_bits - NV_MANT_DIG;
11117 hexfp_uquad <<= tail;
11118 assert((shift - tail) >= 0);
11119 hexfp_uquad |= b >> (shift - tail);
11120 hexfp_frac_bits += tail;
11122 /* Ignore the trailing zero bits
11123 * of the last non-zero xdigit.
11125 * The assumption here is that if
11126 * one has input of e.g. the xdigit
11127 * eight (0x8), there is only one
11128 * bit being input, not the full
11129 * four bits. Conversely, if one
11130 * specifies a zero xdigit, the
11131 * assumption is that one really
11132 * wants all those bits to be zero. */
11134 if ((b & 0x1) == 0x0) {
11135 significant_bits--;
11136 if ((b & 0x2) == 0x0) {
11137 significant_bits--;
11138 if ((b & 0x4) == 0x0) {
11139 significant_bits--;
11145 accumulate = FALSE;
11148 /* Keep skipping the xdigits, and
11149 * accumulating the significant bits,
11150 * but do not shift the uquad
11151 * (which would catastrophically drop
11152 * high-order bits) or accumulate the
11153 * xdigits anymore. */
11155 #else /* HEXFP_NV */
11157 nv_mult /= nvshift[shift];
11159 hexfp_nv += b * nv_mult;
11161 accumulate = FALSE;
11165 if (significant_bits >= NV_MANT_DIG)
11166 accumulate = FALSE;
11170 if ((total_bits > 0 || significant_bits > 0) &&
11171 isALPHA_FOLD_EQ(*h, 'p')) {
11172 bool negexp = FALSE;
11176 else if (*h == '-') {
11182 while (isDIGIT(*h) || *h == '_') {
11185 hexfp_exp += *h - '0';
11188 && -hexfp_exp < NV_MIN_EXP - 1) {
11189 /* NOTE: this means that the exponent
11190 * underflow warning happens for
11191 * the IEEE 754 subnormals (denormals),
11192 * because DBL_MIN_EXP etc are the lowest
11193 * possible binary (or, rather, DBL_RADIX-base)
11194 * exponent for normals, not subnormals.
11196 * This may or may not be a good thing. */
11197 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11198 "Hexadecimal float: exponent underflow");
11204 && hexfp_exp > NV_MAX_EXP - 1) {
11205 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11206 "Hexadecimal float: exponent overflow");
11214 hexfp_exp = -hexfp_exp;
11216 hexfp_exp -= hexfp_frac_bits;
11218 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11226 if (n > 4294967295.0)
11227 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11228 "%s number > %s non-portable",
11234 if (u > 0xffffffff)
11235 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11236 "%s number > %s non-portable",
11241 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11242 sv = new_constant(start, s - start, "integer",
11243 sv, NULL, NULL, 0);
11244 else if (PL_hints & HINT_NEW_BINARY)
11245 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11250 handle decimal numbers.
11251 we're also sent here when we read a 0 as the first digit
11253 case '1': case '2': case '3': case '4': case '5':
11254 case '6': case '7': case '8': case '9': case '.':
11257 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11266 /* read next group of digits and _ and copy into d */
11269 || UNLIKELY(hexfp && isXDIGIT(*s)))
11271 /* skip underscores, checking for misplaced ones
11275 if (lastub && s == lastub + 1)
11276 WARN_ABOUT_UNDERSCORE();
11280 /* check for end of fixed-length buffer */
11282 Perl_croak(aTHX_ "%s", number_too_long);
11283 /* if we're ok, copy the character */
11288 /* final misplaced underbar check */
11289 if (lastub && s == lastub + 1)
11290 WARN_ABOUT_UNDERSCORE();
11292 /* read a decimal portion if there is one. avoid
11293 3..5 being interpreted as the number 3. followed
11296 if (*s == '.' && s[1] != '.') {
11301 WARN_ABOUT_UNDERSCORE();
11305 /* copy, ignoring underbars, until we run out of digits.
11309 || UNLIKELY(hexfp && isXDIGIT(*s));
11312 /* fixed length buffer check */
11314 Perl_croak(aTHX_ "%s", number_too_long);
11316 if (lastub && s == lastub + 1)
11317 WARN_ABOUT_UNDERSCORE();
11323 /* fractional part ending in underbar? */
11325 WARN_ABOUT_UNDERSCORE();
11326 if (*s == '.' && isDIGIT(s[1])) {
11327 /* oops, it's really a v-string, but without the "v" */
11333 /* read exponent part, if present */
11334 if ((isALPHA_FOLD_EQ(*s, 'e')
11335 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11336 && strchr("+-0123456789_", s[1]))
11338 int exp_digits = 0;
11339 const char *save_s = s;
11342 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11343 ditto for p (hexfloats) */
11344 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11345 /* At least some Mach atof()s don't grok 'E' */
11348 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11355 /* stray preinitial _ */
11357 WARN_ABOUT_UNDERSCORE();
11361 /* allow positive or negative exponent */
11362 if (*s == '+' || *s == '-')
11365 /* stray initial _ */
11367 WARN_ABOUT_UNDERSCORE();
11371 /* read digits of exponent */
11372 while (isDIGIT(*s) || *s == '_') {
11376 Perl_croak(aTHX_ "%s", number_too_long);
11380 if (((lastub && s == lastub + 1)
11381 || (!isDIGIT(s[1]) && s[1] != '_')))
11382 WARN_ABOUT_UNDERSCORE();
11388 /* no exponent digits, the [eEpP] could be for something else,
11389 * though in practice we don't get here for p since that's preparsed
11390 * earlier, and results in only the 0xX being consumed, so behave similarly
11391 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11404 We try to do an integer conversion first if no characters
11405 indicating "float" have been found.
11410 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11412 if (flags == IS_NUMBER_IN_UV) {
11414 sv = newSViv(uv); /* Prefer IVs over UVs. */
11417 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11418 if (uv <= (UV) IV_MIN)
11419 sv = newSViv(-(IV)uv);
11426 /* terminate the string */
11428 if (UNLIKELY(hexfp)) {
11429 # ifdef NV_MANT_DIG
11430 if (significant_bits > NV_MANT_DIG)
11431 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11432 "Hexadecimal float: mantissa overflow");
11435 nv = hexfp_uquad * hexfp_mult;
11436 #else /* HEXFP_NV */
11437 nv = hexfp_nv * hexfp_mult;
11440 nv = Atof(PL_tokenbuf);
11446 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11447 const char *const key = floatit ? "float" : "integer";
11448 const STRLEN keylen = floatit ? 5 : 7;
11449 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11450 key, keylen, sv, NULL, NULL, 0);
11454 /* if it starts with a v, it could be a v-string */
11457 sv = newSV(5); /* preallocate storage space */
11458 ENTER_with_name("scan_vstring");
11460 s = scan_vstring(s, PL_bufend, sv);
11461 SvREFCNT_inc_simple_void_NN(sv);
11462 LEAVE_with_name("scan_vstring");
11466 /* make the op for the constant and return */
11469 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11471 lvalp->opval = NULL;
11477 S_scan_formline(pTHX_ char *s)
11479 SV * const stuff = newSVpvs("");
11480 bool needargs = FALSE;
11481 bool eofmt = FALSE;
11483 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11485 while (!needargs) {
11489 #ifdef PERL_STRICT_CR
11490 while (SPACE_OR_TAB(*t))
11493 while (SPACE_OR_TAB(*t) || *t == '\r')
11496 if (*t == '\n' || t == PL_bufend) {
11501 eol = (char *) memchr(s,'\n',PL_bufend-s);
11506 for (t = s; t < eol; t++) {
11507 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11509 goto enough; /* ~~ must be first line in formline */
11511 if (*t == '@' || *t == '^')
11515 sv_catpvn(stuff, s, eol-s);
11516 #ifndef PERL_STRICT_CR
11517 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11518 char *end = SvPVX(stuff) + SvCUR(stuff);
11521 SvCUR_set(stuff, SvCUR(stuff) - 1);
11529 if ((PL_rsfp || PL_parser->filtered)
11530 && PL_parser->form_lex_state == LEX_NORMAL) {
11532 PL_bufptr = PL_bufend;
11533 COPLINE_INC_WITH_HERELINES;
11534 got_some = lex_next_chunk(0);
11535 CopLINE_dec(PL_curcop);
11540 incline(s, PL_bufend);
11543 if (!SvCUR(stuff) || needargs)
11544 PL_lex_state = PL_parser->form_lex_state;
11545 if (SvCUR(stuff)) {
11546 PL_expect = XSTATE;
11548 const char *s2 = s;
11549 while (isSPACE(*s2) && *s2 != '\n')
11552 PL_expect = XTERMBLOCK;
11553 NEXTVAL_NEXTTOKE.ival = 0;
11556 NEXTVAL_NEXTTOKE.ival = 0;
11557 force_next(FORMLBRACK);
11560 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11563 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11567 SvREFCNT_dec(stuff);
11569 PL_lex_formbrack = 0;
11575 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11577 const I32 oldsavestack_ix = PL_savestack_ix;
11578 CV* const outsidecv = PL_compcv;
11580 SAVEI32(PL_subline);
11581 save_item(PL_subname);
11582 SAVESPTR(PL_compcv);
11584 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11585 CvFLAGS(PL_compcv) |= flags;
11587 PL_subline = CopLINE(PL_curcop);
11588 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11589 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11590 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11591 if (outsidecv && CvPADLIST(outsidecv))
11592 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11594 return oldsavestack_ix;
11598 S_yywarn(pTHX_ const char *const s, U32 flags)
11600 PERL_ARGS_ASSERT_YYWARN;
11602 PL_in_eval |= EVAL_WARNONLY;
11603 yyerror_pv(s, flags);
11608 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11610 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11613 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11616 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11618 NOT_REACHED; /* NOTREACHED */
11624 /* Called, after at least one error has been found, to abort the parse now,
11625 * instead of trying to forge ahead */
11627 yyerror_pvn(NULL, 0, 0);
11631 Perl_yyerror(pTHX_ const char *const s)
11633 PERL_ARGS_ASSERT_YYERROR;
11634 return yyerror_pvn(s, strlen(s), 0);
11638 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11640 PERL_ARGS_ASSERT_YYERROR_PV;
11641 return yyerror_pvn(s, strlen(s), flags);
11645 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11647 const char *context = NULL;
11650 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11651 int yychar = PL_parser->yychar;
11653 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11654 * apply. If the number of errors found is large enough, it abandons
11655 * parsing. If 's' is NULL, there is no message, and it abandons
11656 * processing unconditionally */
11659 if (!yychar || (yychar == ';' && !PL_rsfp))
11660 sv_catpvs(where_sv, "at EOF");
11661 else if ( PL_oldoldbufptr
11662 && PL_bufptr > PL_oldoldbufptr
11663 && PL_bufptr - PL_oldoldbufptr < 200
11664 && PL_oldoldbufptr != PL_oldbufptr
11665 && PL_oldbufptr != PL_bufptr)
11669 The code below is removed for NetWare because it
11670 abends/crashes on NetWare when the script has error such as
11671 not having the closing quotes like:
11672 if ($var eq "value)
11673 Checking of white spaces is anyway done in NetWare code.
11676 while (isSPACE(*PL_oldoldbufptr))
11679 context = PL_oldoldbufptr;
11680 contlen = PL_bufptr - PL_oldoldbufptr;
11682 else if ( PL_oldbufptr
11683 && PL_bufptr > PL_oldbufptr
11684 && PL_bufptr - PL_oldbufptr < 200
11685 && PL_oldbufptr != PL_bufptr) {
11688 The code below is removed for NetWare because it
11689 abends/crashes on NetWare when the script has error such as
11690 not having the closing quotes like:
11691 if ($var eq "value)
11692 Checking of white spaces is anyway done in NetWare code.
11695 while (isSPACE(*PL_oldbufptr))
11698 context = PL_oldbufptr;
11699 contlen = PL_bufptr - PL_oldbufptr;
11701 else if (yychar > 255)
11702 sv_catpvs(where_sv, "next token ???");
11703 else if (yychar == YYEMPTY) {
11704 if (PL_lex_state == LEX_NORMAL)
11705 sv_catpvs(where_sv, "at end of line");
11706 else if (PL_lex_inpat)
11707 sv_catpvs(where_sv, "within pattern");
11709 sv_catpvs(where_sv, "within string");
11712 sv_catpvs(where_sv, "next char ");
11714 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11715 else if (isPRINT_LC(yychar)) {
11716 const char string = yychar;
11717 sv_catpvn(where_sv, &string, 1);
11720 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11722 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11723 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11724 OutCopFILE(PL_curcop),
11725 (IV)(PL_parser->preambling == NOLINE
11726 ? CopLINE(PL_curcop)
11727 : PL_parser->preambling));
11729 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11730 UTF8fARG(UTF, contlen, context));
11732 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11733 if ( PL_multi_start < PL_multi_end
11734 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11736 Perl_sv_catpvf(aTHX_ msg,
11737 " (Might be a runaway multi-line %c%c string starting on"
11738 " line %" IVdf ")\n",
11739 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11742 if (PL_in_eval & EVAL_WARNONLY) {
11743 PL_in_eval &= ~EVAL_WARNONLY;
11744 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11750 if (s == NULL || PL_error_count >= 10) {
11751 const char * msg = "";
11752 const char * const name = OutCopFILE(PL_curcop);
11755 SV * errsv = ERRSV;
11756 if (SvCUR(errsv)) {
11757 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11762 abort_execution(msg, name);
11765 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11769 PL_in_my_stash = NULL;
11774 S_swallow_bom(pTHX_ U8 *s)
11776 const STRLEN slen = SvCUR(PL_linestr);
11778 PERL_ARGS_ASSERT_SWALLOW_BOM;
11782 if (s[1] == 0xFE) {
11783 /* UTF-16 little-endian? (or UTF-32LE?) */
11784 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11785 /* diag_listed_as: Unsupported script encoding %s */
11786 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11787 #ifndef PERL_NO_UTF16_FILTER
11789 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11792 if (PL_bufend > (char*)s) {
11793 s = add_utf16_textfilter(s, TRUE);
11796 /* diag_listed_as: Unsupported script encoding %s */
11797 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11802 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11803 #ifndef PERL_NO_UTF16_FILTER
11805 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11808 if (PL_bufend > (char *)s) {
11809 s = add_utf16_textfilter(s, FALSE);
11812 /* diag_listed_as: Unsupported script encoding %s */
11813 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11817 case BOM_UTF8_FIRST_BYTE: {
11818 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
11820 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11822 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
11829 if (s[2] == 0xFE && s[3] == 0xFF) {
11830 /* UTF-32 big-endian */
11831 /* diag_listed_as: Unsupported script encoding %s */
11832 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11835 else if (s[2] == 0 && s[3] != 0) {
11838 * are a good indicator of UTF-16BE. */
11839 #ifndef PERL_NO_UTF16_FILTER
11841 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11843 s = add_utf16_textfilter(s, FALSE);
11845 /* diag_listed_as: Unsupported script encoding %s */
11846 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11853 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11856 * are a good indicator of UTF-16LE. */
11857 #ifndef PERL_NO_UTF16_FILTER
11859 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11861 s = add_utf16_textfilter(s, TRUE);
11863 /* diag_listed_as: Unsupported script encoding %s */
11864 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11872 #ifndef PERL_NO_UTF16_FILTER
11874 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11876 SV *const filter = FILTER_DATA(idx);
11877 /* We re-use this each time round, throwing the contents away before we
11879 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11880 SV *const utf8_buffer = filter;
11881 IV status = IoPAGE(filter);
11882 const bool reverse = cBOOL(IoLINES(filter));
11885 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11887 /* As we're automatically added, at the lowest level, and hence only called
11888 from this file, we can be sure that we're not called in block mode. Hence
11889 don't bother writing code to deal with block mode. */
11891 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11894 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11896 DEBUG_P(PerlIO_printf(Perl_debug_log,
11897 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11898 FPTR2DPTR(void *, S_utf16_textfilter),
11899 reverse ? 'l' : 'b', idx, maxlen, status,
11900 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11907 /* First, look in our buffer of existing UTF-8 data: */
11908 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11912 } else if (status == 0) {
11914 IoPAGE(filter) = 0;
11915 nl = SvEND(utf8_buffer);
11918 STRLEN got = nl - SvPVX(utf8_buffer);
11919 /* Did we have anything to append? */
11921 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11922 /* Everything else in this code works just fine if SVp_POK isn't
11923 set. This, however, needs it, and we need it to work, else
11924 we loop infinitely because the buffer is never consumed. */
11925 sv_chop(utf8_buffer, nl);
11929 /* OK, not a complete line there, so need to read some more UTF-16.
11930 Read an extra octect if the buffer currently has an odd number. */
11934 if (SvCUR(utf16_buffer) >= 2) {
11935 /* Location of the high octet of the last complete code point.
11936 Gosh, UTF-16 is a pain. All the benefits of variable length,
11937 *coupled* with all the benefits of partial reads and
11939 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11940 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11942 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11946 /* We have the first half of a surrogate. Read more. */
11947 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11950 status = FILTER_READ(idx + 1, utf16_buffer,
11951 160 + (SvCUR(utf16_buffer) & 1));
11952 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11953 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11956 IoPAGE(filter) = status;
11961 /* 'chars' isn't quite the right name, as code points above 0xFFFF
11962 * require 4 bytes per char */
11963 chars = SvCUR(utf16_buffer) >> 1;
11964 have = SvCUR(utf8_buffer);
11966 /* Assume the worst case size as noted by the functions: twice the
11967 * number of input bytes */
11968 SvGROW(utf8_buffer, have + chars * 4 + 1);
11971 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11972 (U8*)SvPVX_const(utf8_buffer) + have,
11973 chars * 2, &newlen);
11975 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11976 (U8*)SvPVX_const(utf8_buffer) + have,
11977 chars * 2, &newlen);
11979 SvCUR_set(utf8_buffer, have + newlen);
11982 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11983 it's private to us, and utf16_to_utf8{,reversed} take a
11984 (pointer,length) pair, rather than a NUL-terminated string. */
11985 if(SvCUR(utf16_buffer) & 1) {
11986 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11987 SvCUR_set(utf16_buffer, 1);
11989 SvCUR_set(utf16_buffer, 0);
11992 DEBUG_P(PerlIO_printf(Perl_debug_log,
11993 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11995 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11996 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12001 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12003 SV *filter = filter_add(S_utf16_textfilter, NULL);
12005 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12007 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12009 IoLINES(filter) = reversed;
12010 IoPAGE(filter) = 1; /* Not EOF */
12012 /* Sadly, we have to return a valid pointer, come what may, so we have to
12013 ignore any error return from this. */
12014 SvCUR_set(PL_linestr, 0);
12015 if (FILTER_READ(0, PL_linestr, 0)) {
12016 SvUTF8_on(PL_linestr);
12018 SvUTF8_on(PL_linestr);
12020 PL_bufend = SvEND(PL_linestr);
12021 return (U8*)SvPVX(PL_linestr);
12026 Returns a pointer to the next character after the parsed
12027 vstring, as well as updating the passed in sv.
12029 Function must be called like
12031 sv = sv_2mortal(newSV(5));
12032 s = scan_vstring(s,e,sv);
12034 where s and e are the start and end of the string.
12035 The sv should already be large enough to store the vstring
12036 passed in, for performance reasons.
12038 This function may croak if fatal warnings are enabled in the
12039 calling scope, hence the sv_2mortal in the example (to prevent
12040 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12046 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12048 const char *pos = s;
12049 const char *start = s;
12051 PERL_ARGS_ASSERT_SCAN_VSTRING;
12053 if (*pos == 'v') pos++; /* get past 'v' */
12054 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12056 if ( *pos != '.') {
12057 /* this may not be a v-string if followed by => */
12058 const char *next = pos;
12059 while (next < e && isSPACE(*next))
12061 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12062 /* return string not v-string */
12063 sv_setpvn(sv,(char *)s,pos-s);
12064 return (char *)pos;
12068 if (!isALPHA(*pos)) {
12069 U8 tmpbuf[UTF8_MAXBYTES+1];
12072 s++; /* get past 'v' */
12077 /* this is atoi() that tolerates underscores */
12080 const char *end = pos;
12082 while (--end >= s) {
12084 const UV orev = rev;
12085 rev += (*end - '0') * mult;
12088 /* diag_listed_as: Integer overflow in %s number */
12089 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12090 "Integer overflow in decimal number");
12094 /* Append native character for the rev point */
12095 tmpend = uvchr_to_utf8(tmpbuf, rev);
12096 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12097 if (!UVCHR_IS_INVARIANT(rev))
12099 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12105 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12109 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12116 Perl_keyword_plugin_standard(pTHX_
12117 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12119 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12120 PERL_UNUSED_CONTEXT;
12121 PERL_UNUSED_ARG(keyword_ptr);
12122 PERL_UNUSED_ARG(keyword_len);
12123 PERL_UNUSED_ARG(op_ptr);
12124 return KEYWORD_PLUGIN_DECLINE;
12128 =for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
12130 Puts a C function into the chain of keyword plugins. This is the
12131 preferred way to manipulate the L</PL_keyword_plugin> variable.
12132 C<new_plugin> is a pointer to the C function that is to be added to the
12133 keyword plugin chain, and C<old_plugin_p> points to the storage location
12134 where a pointer to the next function in the chain will be stored. The
12135 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12136 while the value previously stored there is written to C<*old_plugin_p>.
12138 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12139 to hook keyword parsing may find itself invoked more than once per
12140 process, typically in different threads. To handle that situation, this
12141 function is idempotent. The location C<*old_plugin_p> must initially
12142 (once per process) contain a null pointer. A C variable of static
12143 duration (declared at file scope, typically also marked C<static> to give
12144 it internal linkage) will be implicitly initialised appropriately, if it
12145 does not have an explicit initialiser. This function will only actually
12146 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12147 function is also thread safe on the small scale. It uses appropriate
12148 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12150 When this function is called, the function referenced by C<new_plugin>
12151 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12152 In a threading situation, C<new_plugin> may be called immediately, even
12153 before this function has returned. C<*old_plugin_p> will always be
12154 appropriately set before C<new_plugin> is called. If C<new_plugin>
12155 decides not to do anything special with the identifier that it is given
12156 (which is the usual case for most calls to a keyword plugin), it must
12157 chain the plugin function referenced by C<*old_plugin_p>.
12159 Taken all together, XS code to install a keyword plugin should typically
12160 look something like this:
12162 static Perl_keyword_plugin_t next_keyword_plugin;
12163 static OP *my_keyword_plugin(pTHX_
12164 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12166 if (memEQs(keyword_ptr, keyword_len,
12167 "my_new_keyword")) {
12170 return next_keyword_plugin(aTHX_
12171 keyword_ptr, keyword_len, op_ptr);
12175 wrap_keyword_plugin(my_keyword_plugin,
12176 &next_keyword_plugin);
12178 Direct access to L</PL_keyword_plugin> should be avoided.
12184 Perl_wrap_keyword_plugin(pTHX_
12185 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12189 PERL_UNUSED_CONTEXT;
12190 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12191 if (*old_plugin_p) return;
12192 KEYWORD_PLUGIN_MUTEX_LOCK;
12193 if (!*old_plugin_p) {
12194 *old_plugin_p = PL_keyword_plugin;
12195 PL_keyword_plugin = new_plugin;
12197 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12200 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12202 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12204 SAVEI32(PL_lex_brackets);
12205 if (PL_lex_brackets > 100)
12206 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12207 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12208 SAVEI32(PL_lex_allbrackets);
12209 PL_lex_allbrackets = 0;
12210 SAVEI8(PL_lex_fakeeof);
12211 PL_lex_fakeeof = (U8)fakeeof;
12212 if(yyparse(gramtype) && !PL_parser->error_count)
12213 qerror(Perl_mess(aTHX_ "Parse error"));
12216 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12218 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12222 SAVEVPTR(PL_eval_root);
12223 PL_eval_root = NULL;
12224 parse_recdescent(gramtype, fakeeof);
12230 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12232 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12235 if (flags & ~PARSE_OPTIONAL)
12236 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12237 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12238 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12239 if (!PL_parser->error_count)
12240 qerror(Perl_mess(aTHX_ "Parse error"));
12241 exprop = newOP(OP_NULL, 0);
12247 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12249 Parse a Perl arithmetic expression. This may contain operators of precedence
12250 down to the bit shift operators. The expression must be followed (and thus
12251 terminated) either by a comparison or lower-precedence operator or by
12252 something that would normally terminate an expression such as semicolon.
12253 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12254 otherwise it is mandatory. It is up to the caller to ensure that the
12255 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12256 the source of the code to be parsed and the lexical context for the
12259 The op tree representing the expression is returned. If an optional
12260 expression is absent, a null pointer is returned, otherwise the pointer
12263 If an error occurs in parsing or compilation, in most cases a valid op
12264 tree is returned anyway. The error is reflected in the parser state,
12265 normally resulting in a single exception at the top level of parsing
12266 which covers all the compilation errors that occurred. Some compilation
12267 errors, however, will throw an exception immediately.
12273 Perl_parse_arithexpr(pTHX_ U32 flags)
12275 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12279 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12281 Parse a Perl term expression. This may contain operators of precedence
12282 down to the assignment operators. The expression must be followed (and thus
12283 terminated) either by a comma or lower-precedence operator or by
12284 something that would normally terminate an expression such as semicolon.
12285 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12286 otherwise it is mandatory. It is up to the caller to ensure that the
12287 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12288 the source of the code to be parsed and the lexical context for the
12291 The op tree representing the expression is returned. If an optional
12292 expression is absent, a null pointer is returned, otherwise the pointer
12295 If an error occurs in parsing or compilation, in most cases a valid op
12296 tree is returned anyway. The error is reflected in the parser state,
12297 normally resulting in a single exception at the top level of parsing
12298 which covers all the compilation errors that occurred. Some compilation
12299 errors, however, will throw an exception immediately.
12305 Perl_parse_termexpr(pTHX_ U32 flags)
12307 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12311 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12313 Parse a Perl list expression. This may contain operators of precedence
12314 down to the comma operator. The expression must be followed (and thus
12315 terminated) either by a low-precedence logic operator such as C<or> or by
12316 something that would normally terminate an expression such as semicolon.
12317 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12318 otherwise it is mandatory. It is up to the caller to ensure that the
12319 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12320 the source of the code to be parsed and the lexical context for the
12323 The op tree representing the expression is returned. If an optional
12324 expression is absent, a null pointer is returned, otherwise the pointer
12327 If an error occurs in parsing or compilation, in most cases a valid op
12328 tree is returned anyway. The error is reflected in the parser state,
12329 normally resulting in a single exception at the top level of parsing
12330 which covers all the compilation errors that occurred. Some compilation
12331 errors, however, will throw an exception immediately.
12337 Perl_parse_listexpr(pTHX_ U32 flags)
12339 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12343 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12345 Parse a single complete Perl expression. This allows the full
12346 expression grammar, including the lowest-precedence operators such
12347 as C<or>. The expression must be followed (and thus terminated) by a
12348 token that an expression would normally be terminated by: end-of-file,
12349 closing bracketing punctuation, semicolon, or one of the keywords that
12350 signals a postfix expression-statement modifier. If C<flags> has the
12351 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12352 mandatory. It is up to the caller to ensure that the dynamic parser
12353 state (L</PL_parser> et al) is correctly set to reflect the source of
12354 the code to be parsed and the lexical context for the expression.
12356 The op tree representing the expression is returned. If an optional
12357 expression is absent, a null pointer is returned, otherwise the pointer
12360 If an error occurs in parsing or compilation, in most cases a valid op
12361 tree is returned anyway. The error is reflected in the parser state,
12362 normally resulting in a single exception at the top level of parsing
12363 which covers all the compilation errors that occurred. Some compilation
12364 errors, however, will throw an exception immediately.
12370 Perl_parse_fullexpr(pTHX_ U32 flags)
12372 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12376 =for apidoc Amx|OP *|parse_block|U32 flags
12378 Parse a single complete Perl code block. This consists of an opening
12379 brace, a sequence of statements, and a closing brace. The block
12380 constitutes a lexical scope, so C<my> variables and various compile-time
12381 effects can be contained within it. It is up to the caller to ensure
12382 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12383 reflect the source of the code to be parsed and the lexical context for
12386 The op tree representing the code block is returned. This is always a
12387 real op, never a null pointer. It will normally be a C<lineseq> list,
12388 including C<nextstate> or equivalent ops. No ops to construct any kind
12389 of runtime scope are included by virtue of it being a block.
12391 If an error occurs in parsing or compilation, in most cases a valid op
12392 tree (most likely null) is returned anyway. The error is reflected in
12393 the parser state, normally resulting in a single exception at the top
12394 level of parsing which covers all the compilation errors that occurred.
12395 Some compilation errors, however, will throw an exception immediately.
12397 The C<flags> parameter is reserved for future use, and must always
12404 Perl_parse_block(pTHX_ U32 flags)
12407 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12408 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12412 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12414 Parse a single unadorned Perl statement. This may be a normal imperative
12415 statement or a declaration that has compile-time effect. It does not
12416 include any label or other affixture. It is up to the caller to ensure
12417 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12418 reflect the source of the code to be parsed and the lexical context for
12421 The op tree representing the statement is returned. This may be a
12422 null pointer if the statement is null, for example if it was actually
12423 a subroutine definition (which has compile-time side effects). If not
12424 null, it will be ops directly implementing the statement, suitable to
12425 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12426 equivalent op (except for those embedded in a scope contained entirely
12427 within the statement).
12429 If an error occurs in parsing or compilation, in most cases a valid op
12430 tree (most likely null) is returned anyway. The error is reflected in
12431 the parser state, normally resulting in a single exception at the top
12432 level of parsing which covers all the compilation errors that occurred.
12433 Some compilation errors, however, will throw an exception immediately.
12435 The C<flags> parameter is reserved for future use, and must always
12442 Perl_parse_barestmt(pTHX_ U32 flags)
12445 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12446 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12450 =for apidoc Amx|SV *|parse_label|U32 flags
12452 Parse a single label, possibly optional, of the type that may prefix a
12453 Perl statement. It is up to the caller to ensure that the dynamic parser
12454 state (L</PL_parser> et al) is correctly set to reflect the source of
12455 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12456 label is optional, otherwise it is mandatory.
12458 The name of the label is returned in the form of a fresh scalar. If an
12459 optional label is absent, a null pointer is returned.
12461 If an error occurs in parsing, which can only occur if the label is
12462 mandatory, a valid label is returned anyway. The error is reflected in
12463 the parser state, normally resulting in a single exception at the top
12464 level of parsing which covers all the compilation errors that occurred.
12470 Perl_parse_label(pTHX_ U32 flags)
12472 if (flags & ~PARSE_OPTIONAL)
12473 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12475 PL_parser->yychar = yylex();
12476 if (PL_parser->yychar == LABEL) {
12477 char * const lpv = pl_yylval.pval;
12478 STRLEN llen = strlen(lpv);
12479 PL_parser->yychar = YYEMPTY;
12480 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12487 STRLEN wlen, bufptr_pos;
12490 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12492 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12493 if (word_takes_any_delimiter(s, wlen))
12495 bufptr_pos = s - SvPVX(PL_linestr);
12497 lex_read_space(LEX_KEEP_PREVIOUS);
12499 s = SvPVX(PL_linestr) + bufptr_pos;
12500 if (t[0] == ':' && t[1] != ':') {
12501 PL_oldoldbufptr = PL_oldbufptr;
12504 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12508 if (flags & PARSE_OPTIONAL) {
12511 qerror(Perl_mess(aTHX_ "Parse error"));
12512 return newSVpvs("x");
12519 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12521 Parse a single complete Perl statement. This may be a normal imperative
12522 statement or a declaration that has compile-time effect, and may include
12523 optional labels. It is up to the caller to ensure that the dynamic
12524 parser state (L</PL_parser> et al) is correctly set to reflect the source
12525 of the code to be parsed and the lexical context for the statement.
12527 The op tree representing the statement is returned. This may be a
12528 null pointer if the statement is null, for example if it was actually
12529 a subroutine definition (which has compile-time side effects). If not
12530 null, it will be the result of a L</newSTATEOP> call, normally including
12531 a C<nextstate> or equivalent op.
12533 If an error occurs in parsing or compilation, in most cases a valid op
12534 tree (most likely null) is returned anyway. The error is reflected in
12535 the parser state, normally resulting in a single exception at the top
12536 level of parsing which covers all the compilation errors that occurred.
12537 Some compilation errors, however, will throw an exception immediately.
12539 The C<flags> parameter is reserved for future use, and must always
12546 Perl_parse_fullstmt(pTHX_ U32 flags)
12549 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12550 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12554 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12556 Parse a sequence of zero or more Perl statements. These may be normal
12557 imperative statements, including optional labels, or declarations
12558 that have compile-time effect, or any mixture thereof. The statement
12559 sequence ends when a closing brace or end-of-file is encountered in a
12560 place where a new statement could have validly started. It is up to
12561 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12562 is correctly set to reflect the source of the code to be parsed and the
12563 lexical context for the statements.
12565 The op tree representing the statement sequence is returned. This may
12566 be a null pointer if the statements were all null, for example if there
12567 were no statements or if there were only subroutine definitions (which
12568 have compile-time side effects). If not null, it will be a C<lineseq>
12569 list, normally including C<nextstate> or equivalent ops.
12571 If an error occurs in parsing or compilation, in most cases a valid op
12572 tree is returned anyway. The error is reflected in the parser state,
12573 normally resulting in a single exception at the top level of parsing
12574 which covers all the compilation errors that occurred. Some compilation
12575 errors, however, will throw an exception immediately.
12577 The C<flags> parameter is reserved for future use, and must always
12584 Perl_parse_stmtseq(pTHX_ U32 flags)
12589 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12590 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12591 c = lex_peek_unichar(0);
12592 if (c != -1 && c != /*{*/'}')
12593 qerror(Perl_mess(aTHX_ "Parse error"));
12598 * ex: set ts=8 sts=4 sw=4 et: