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 AmnU|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 "invlist_inline.h"
43 #define new_constant(a,b,c,d,e,f,g, h) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g, h)
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";
97 static const char* const ident_var_zero_multi_digit = "Numeric variables with more than one digit may not start with '0'";
99 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
101 #define XENUMMASK 0x3f
102 #define XFAKEEOF 0x40
103 #define XFAKEBRACK 0x80
105 #ifdef USE_UTF8_SCRIPTS
106 # define UTF cBOOL(!IN_BYTES)
108 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
111 /* The maximum number of characters preceding the unrecognized one to display */
112 #define UNRECOGNIZED_PRECEDE_COUNT 10
114 /* In variables named $^X, these are the legal values for X.
115 * 1999-02-27 mjd-perl-patch@plover.com */
116 #define isCONTROLVAR(x) (isUPPER(x) || memCHRs("[\\]^_?", (x)))
118 #define SPACE_OR_TAB(c) isBLANK_A(c)
120 #define HEXFP_PEEK(s) \
122 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
123 isALPHA_FOLD_EQ(s[0], 'p'))
125 /* LEX_* are values for PL_lex_state, the state of the lexer.
126 * They are arranged oddly so that the guard on the switch statement
127 * can get by with a single comparison (if the compiler is smart enough).
129 * These values refer to the various states within a sublex parse,
130 * i.e. within a double quotish string
133 /* #define LEX_NOTPARSING 11 is done in perl.h. */
135 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
136 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
137 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
138 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
139 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
141 /* at end of code, eg "$x" followed by: */
142 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
143 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
145 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
146 string or after \E, $foo, etc */
147 #define LEX_INTERPCONST 2 /* NOT USED */
148 #define LEX_FORMLINE 1 /* expecting a format line */
152 static const char* const lex_state_names[] = {
167 #include "keywords.h"
169 /* CLINE is a macro that ensures PL_copline has a sane value */
171 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
174 * Convenience functions to return different tokens and prime the
175 * lexer for the next token. They all take an argument.
177 * TOKEN : generic token (used for '(', DOLSHARP, etc)
178 * OPERATOR : generic operator
179 * AOPERATOR : assignment operator
180 * PREBLOCK : beginning the block after an if, while, foreach, ...
181 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
182 * PREREF : *EXPR where EXPR is not a simple identifier
183 * TERM : expression term
184 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
185 * LOOPX : loop exiting command (goto, last, dump, etc)
186 * FTST : file test operator
187 * FUN0 : zero-argument function
188 * FUN0OP : zero-argument function, with its op created in this file
189 * FUN1 : not used, except for not, which isn't a UNIOP
190 * BOop : bitwise or or xor
192 * BCop : bitwise complement
193 * SHop : shift operator
194 * PWop : power operator
195 * PMop : pattern-matching operator
196 * Aop : addition-level operator
197 * AopNOASSIGN : addition-level operator that is never part of .=
198 * Mop : multiplication-level operator
199 * Eop : equality-testing operator
200 * Rop : relational operator <= != gt
202 * Also see LOP and lop() below.
205 #ifdef DEBUGGING /* Serve -DT. */
206 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
208 # define REPORT(retval) (retval)
211 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
212 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
213 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
214 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
216 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
217 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
218 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
219 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
221 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
223 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
224 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
225 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
226 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
227 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
228 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
229 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
231 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
232 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
233 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
234 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
235 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
236 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
237 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
238 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
240 /* This bit of chicanery makes a unary function followed by
241 * a parenthesis into a function with one argument, highest precedence.
242 * The UNIDOR macro is for unary functions that can be followed by the //
243 * operator (such as C<shift // 0>).
245 #define UNI3(f,x,have_x) { \
246 pl_yylval.ival = f; \
247 if (have_x) PL_expect = x; \
249 PL_last_uni = PL_oldbufptr; \
250 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
252 return REPORT( (int)FUNC1 ); \
254 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
256 #define UNI(f) UNI3(f,XTERM,1)
257 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
258 #define UNIPROTO(f,optional) { \
259 if (optional) PL_last_uni = PL_oldbufptr; \
263 #define UNIBRACK(f) UNI3(f,0,0)
265 /* grandfather return to old style */
268 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
269 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
270 pl_yylval.ival = (f); \
276 #define COPLINE_INC_WITH_HERELINES \
278 CopLINE_inc(PL_curcop); \
279 if (PL_parser->herelines) \
280 CopLINE(PL_curcop) += PL_parser->herelines, \
281 PL_parser->herelines = 0; \
283 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
284 * is no sublex_push to follow. */
285 #define COPLINE_SET_FROM_MULTI_END \
287 CopLINE_set(PL_curcop, PL_multi_end); \
288 if (PL_multi_end != PL_multi_start) \
289 PL_parser->herelines = 0; \
293 /* A file-local structure for passing around information about subroutines and
294 * related definable words */
304 static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE };
309 /* how to interpret the pl_yylval associated with the token */
313 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
318 static struct debug_tokens {
320 enum token_type type;
322 } const debug_tokens[] =
324 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
325 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
326 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
327 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
328 { ANON_SIGSUB, TOKENTYPE_IVAL, "ANON_SIGSUB" },
329 { ARROW, TOKENTYPE_NONE, "ARROW" },
330 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
331 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
332 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
333 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
334 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
335 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
336 { DO, TOKENTYPE_NONE, "DO" },
337 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
338 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
339 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
340 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
341 { ELSE, TOKENTYPE_NONE, "ELSE" },
342 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
343 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
344 { FOR, TOKENTYPE_IVAL, "FOR" },
345 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
346 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
347 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
348 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
349 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
350 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
351 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
352 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
353 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
354 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
355 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
356 { IF, TOKENTYPE_IVAL, "IF" },
357 { LABEL, TOKENTYPE_OPVAL, "LABEL" },
358 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
359 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
360 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
361 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
362 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
363 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
364 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
365 { MY, TOKENTYPE_IVAL, "MY" },
366 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
367 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
368 { OROP, TOKENTYPE_IVAL, "OROP" },
369 { OROR, TOKENTYPE_NONE, "OROR" },
370 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
371 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
372 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
373 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
374 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
375 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
376 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
377 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
378 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
379 { PREINC, TOKENTYPE_NONE, "PREINC" },
380 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
381 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
382 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
383 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
384 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
385 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
386 { SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
387 { SUB, TOKENTYPE_NONE, "SUB" },
388 { SUBLEXEND, TOKENTYPE_NONE, "SUBLEXEND" },
389 { SUBLEXSTART, TOKENTYPE_NONE, "SUBLEXSTART" },
390 { THING, TOKENTYPE_OPVAL, "THING" },
391 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
392 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
393 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
394 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
395 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
396 { USE, TOKENTYPE_IVAL, "USE" },
397 { WHEN, TOKENTYPE_IVAL, "WHEN" },
398 { WHILE, TOKENTYPE_IVAL, "WHILE" },
399 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
400 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
401 { 0, TOKENTYPE_NONE, NULL }
404 /* dump the returned token in rv, plus any optional arg in pl_yylval */
407 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
409 PERL_ARGS_ASSERT_TOKEREPORT;
412 const char *name = NULL;
413 enum token_type type = TOKENTYPE_NONE;
414 const struct debug_tokens *p;
415 SV* const report = newSVpvs("<== ");
417 for (p = debug_tokens; p->token; p++) {
418 if (p->token == (int)rv) {
425 Perl_sv_catpv(aTHX_ report, name);
426 else if (isGRAPH(rv))
428 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
430 sv_catpvs(report, " (pending identifier)");
433 sv_catpvs(report, "EOF");
435 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
440 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
442 case TOKENTYPE_OPNUM:
443 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
444 PL_op_name[lvalp->ival]);
447 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
449 case TOKENTYPE_OPVAL:
451 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
452 PL_op_name[lvalp->opval->op_type]);
453 if (lvalp->opval->op_type == OP_CONST) {
454 Perl_sv_catpvf(aTHX_ report, " %s",
455 SvPEEK(cSVOPx_sv(lvalp->opval)));
460 sv_catpvs(report, "(opval=null)");
463 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
469 /* print the buffer with suitable escapes */
472 S_printbuf(pTHX_ const char *const fmt, const char *const s)
474 SV* const tmp = newSVpvs("");
476 PERL_ARGS_ASSERT_PRINTBUF;
478 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
479 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
480 GCC_DIAG_RESTORE_STMT;
489 * This subroutine looks for an '=' next to the operator that has just been
490 * parsed and turns it into an ASSIGNOP if it finds one.
494 S_ao(pTHX_ int toketype)
496 if (*PL_bufptr == '=') {
498 if (toketype == ANDAND)
499 pl_yylval.ival = OP_ANDASSIGN;
500 else if (toketype == OROR)
501 pl_yylval.ival = OP_ORASSIGN;
502 else if (toketype == DORDOR)
503 pl_yylval.ival = OP_DORASSIGN;
506 return REPORT(toketype);
511 * When Perl expects an operator and finds something else, no_op
512 * prints the warning. It always prints "<something> found where
513 * operator expected. It prints "Missing semicolon on previous line?"
514 * if the surprise occurs at the start of the line. "do you need to
515 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
516 * where the compiler doesn't know if foo is a method call or a function.
517 * It prints "Missing operator before end of line" if there's nothing
518 * after the missing operator, or "... before <...>" if there is something
519 * after the missing operator.
521 * PL_bufptr is expected to point to the start of the thing that was found,
522 * and s after the next token or partial token.
526 S_no_op(pTHX_ const char *const what, char *s)
528 char * const oldbp = PL_bufptr;
529 const bool is_first = (PL_oldbufptr == PL_linestart);
531 PERL_ARGS_ASSERT_NO_OP;
537 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
538 if (ckWARN_d(WARN_SYNTAX)) {
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing semicolon on previous line?)\n");
542 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
547 for (t = PL_oldoldbufptr;
548 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
549 t += UTF ? UTF8SKIP(t) : 1)
553 if (t < PL_bufptr && isSPACE(*t))
554 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
555 "\t(Do you need to predeclare %" UTF8f "?)\n",
556 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
560 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
561 "\t(Missing operator before %" UTF8f "?)\n",
562 UTF8fARG(UTF, s - oldbp, oldbp));
570 * Complain about missing quote/regexp/heredoc terminator.
571 * If it's called with NULL then it cauterizes the line buffer.
572 * If we're in a delimited string and the delimiter is a control
573 * character, it's reformatted into a two-char sequence like ^C.
578 S_missingterm(pTHX_ char *s, STRLEN len)
580 char tmpbuf[UTF8_MAXBYTES + 1];
585 char * const nl = (char *) my_memrchr(s, '\n', len);
592 else if (PL_multi_close < 32) {
594 tmpbuf[1] = (char)toCTRL(PL_multi_close);
600 if (LIKELY(PL_multi_close < 256)) {
601 *tmpbuf = (char)PL_multi_close;
606 char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close);
613 q = memchr(s, '"', len) ? '\'' : '"';
614 sv = sv_2mortal(newSVpvn(s, len));
617 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c"
618 " anywhere before EOF", q, SVfARG(sv), q);
624 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
625 * utf16-to-utf8-reversed.
628 #ifdef PERL_CR_FILTER
632 const char *s = SvPVX_const(sv);
633 const char * const e = s + SvCUR(sv);
635 PERL_ARGS_ASSERT_STRIP_RETURN;
637 /* outer loop optimized to do nothing if there are no CR-LFs */
639 if (*s++ == '\r' && *s == '\n') {
640 /* hit a CR-LF, need to copy the rest */
644 if (*s == '\r' && s[1] == '\n')
655 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
657 const I32 count = FILTER_READ(idx+1, sv, maxlen);
658 if (count > 0 && !maxlen)
665 =for apidoc lex_start
667 Creates and initialises a new lexer/parser state object, supplying
668 a context in which to lex and parse from a new source of Perl code.
669 A pointer to the new state object is placed in L</PL_parser>. An entry
670 is made on the save stack so that upon unwinding, the new state object
671 will be destroyed and the former value of L</PL_parser> will be restored.
672 Nothing else need be done to clean up the parsing context.
674 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
675 non-null, provides a string (in SV form) containing code to be parsed.
676 A copy of the string is made, so subsequent modification of C<line>
677 does not affect parsing. C<rsfp>, if non-null, provides an input stream
678 from which code will be read to be parsed. If both are non-null, the
679 code in C<line> comes first and must consist of complete lines of input,
680 and C<rsfp> supplies the remainder of the source.
682 The C<flags> parameter is reserved for future use. Currently it is only
683 used by perl internally, so extensions should always pass zero.
688 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
689 can share filters with the current parser.
690 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
691 caller, hence isn't owned by the parser, so shouldn't be closed on parser
692 destruction. This is used to handle the case of defaulting to reading the
693 script from the standard input because no filename was given on the command
694 line (without getting confused by situation where STDIN has been closed, so
695 the script handle is opened on fd 0) */
698 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
700 const char *s = NULL;
701 yy_parser *parser, *oparser;
703 if (flags && flags & ~LEX_START_FLAGS)
704 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
706 /* create and initialise a parser */
708 Newxz(parser, 1, yy_parser);
709 parser->old_parser = oparser = PL_parser;
712 parser->stack = NULL;
713 parser->stack_max1 = NULL;
716 /* on scope exit, free this parser and restore any outer one */
718 parser->saved_curcop = PL_curcop;
720 /* initialise lexer state */
722 parser->nexttoke = 0;
723 parser->error_count = oparser ? oparser->error_count : 0;
724 parser->copline = parser->preambling = NOLINE;
725 parser->lex_state = LEX_NORMAL;
726 parser->expect = XSTATE;
728 parser->recheck_utf8_validity = TRUE;
729 parser->rsfp_filters =
730 !(flags & LEX_START_SAME_FILTER) || !oparser
732 : MUTABLE_AV(SvREFCNT_inc(
733 oparser->rsfp_filters
734 ? oparser->rsfp_filters
735 : (oparser->rsfp_filters = newAV())
738 Newx(parser->lex_brackstack, 120, char);
739 Newx(parser->lex_casestack, 12, char);
740 *parser->lex_casestack = '\0';
741 Newxz(parser->lex_shared, 1, LEXSHARED);
745 const U8* first_bad_char_loc;
747 s = SvPV_const(line, len);
750 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
752 &first_bad_char_loc)))
754 _force_out_malformed_utf8_message(first_bad_char_loc,
755 (U8 *) s + SvCUR(line),
757 1 /* 1 means die */ );
758 NOT_REACHED; /* NOTREACHED */
761 parser->linestr = flags & LEX_START_COPIED
762 ? SvREFCNT_inc_simple_NN(line)
763 : newSVpvn_flags(s, len, SvUTF8(line));
765 sv_catpvs(parser->linestr, "\n;");
767 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
770 parser->oldoldbufptr =
773 parser->linestart = SvPVX(parser->linestr);
774 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
775 parser->last_lop = parser->last_uni = NULL;
777 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
778 |LEX_DONT_CLOSE_RSFP));
779 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
780 |LEX_DONT_CLOSE_RSFP));
782 parser->in_pod = parser->filtered = 0;
786 /* delete a parser object */
789 Perl_parser_free(pTHX_ const yy_parser *parser)
791 PERL_ARGS_ASSERT_PARSER_FREE;
793 PL_curcop = parser->saved_curcop;
794 SvREFCNT_dec(parser->linestr);
796 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
797 PerlIO_clearerr(parser->rsfp);
798 else if (parser->rsfp && (!parser->old_parser
799 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
800 PerlIO_close(parser->rsfp);
801 SvREFCNT_dec(parser->rsfp_filters);
802 SvREFCNT_dec(parser->lex_stuff);
803 SvREFCNT_dec(parser->lex_sub_repl);
805 Safefree(parser->lex_brackstack);
806 Safefree(parser->lex_casestack);
807 Safefree(parser->lex_shared);
808 PL_parser = parser->old_parser;
813 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
815 I32 nexttoke = parser->nexttoke;
816 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
818 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
819 && parser->nextval[nexttoke].opval
820 && parser->nextval[nexttoke].opval->op_slabbed
821 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
822 op_free(parser->nextval[nexttoke].opval);
823 parser->nextval[nexttoke].opval = NULL;
830 =for apidoc AmnxUN|SV *|PL_parser-E<gt>linestr
832 Buffer scalar containing the chunk currently under consideration of the
833 text currently being lexed. This is always a plain string scalar (for
834 which C<SvPOK> is true). It is not intended to be used as a scalar by
835 normal scalar means; instead refer to the buffer directly by the pointer
836 variables described below.
838 The lexer maintains various C<char*> pointers to things in the
839 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
840 reallocated, all of these pointers must be updated. Don't attempt to
841 do this manually, but rather use L</lex_grow_linestr> if you need to
842 reallocate the buffer.
844 The content of the text chunk in the buffer is commonly exactly one
845 complete line of input, up to and including a newline terminator,
846 but there are situations where it is otherwise. The octets of the
847 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
848 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
849 flag on this scalar, which may disagree with it.
851 For direct examination of the buffer, the variable
852 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
853 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
854 of these pointers is usually preferable to examination of the scalar
855 through normal scalar means.
857 =for apidoc AmnxUN|char *|PL_parser-E<gt>bufend
859 Direct pointer to the end of the chunk of text currently being lexed, the
860 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
861 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
862 always located at the end of the buffer, and does not count as part of
863 the buffer's contents.
865 =for apidoc AmnxUN|char *|PL_parser-E<gt>bufptr
867 Points to the current position of lexing inside the lexer buffer.
868 Characters around this point may be freely examined, within
869 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
870 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
871 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
873 Lexing code (whether in the Perl core or not) moves this pointer past
874 the characters that it consumes. It is also expected to perform some
875 bookkeeping whenever a newline character is consumed. This movement
876 can be more conveniently performed by the function L</lex_read_to>,
877 which handles newlines appropriately.
879 Interpretation of the buffer's octets can be abstracted out by
880 using the slightly higher-level functions L</lex_peek_unichar> and
881 L</lex_read_unichar>.
883 =for apidoc AmnxUN|char *|PL_parser-E<gt>linestart
885 Points to the start of the current line inside the lexer buffer.
886 This is useful for indicating at which column an error occurred, and
887 not much else. This must be updated by any lexing code that consumes
888 a newline; the function L</lex_read_to> handles this detail.
894 =for apidoc lex_bufutf8
896 Indicates whether the octets in the lexer buffer
897 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
898 of Unicode characters. If not, they should be interpreted as Latin-1
899 characters. This is analogous to the C<SvUTF8> flag for scalars.
901 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
902 contains valid UTF-8. Lexing code must be robust in the face of invalid
905 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
906 is significant, but not the whole story regarding the input character
907 encoding. Normally, when a file is being read, the scalar contains octets
908 and its C<SvUTF8> flag is off, but the octets should be interpreted as
909 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
910 however, the scalar may have the C<SvUTF8> flag on, and in this case its
911 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
912 is in effect. This logic may change in the future; use this function
913 instead of implementing the logic yourself.
919 Perl_lex_bufutf8(pTHX)
925 =for apidoc lex_grow_linestr
927 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
928 at least C<len> octets (including terminating C<NUL>). Returns a
929 pointer to the reallocated buffer. This is necessary before making
930 any direct modification of the buffer that would increase its length.
931 L</lex_stuff_pvn> provides a more convenient way to insert text into
934 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
935 this function updates all of the lexer's variables that point directly
942 Perl_lex_grow_linestr(pTHX_ STRLEN len)
946 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
947 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
950 linestr = PL_parser->linestr;
951 buf = SvPVX(linestr);
952 if (len <= SvLEN(linestr))
955 /* Is the lex_shared linestr SV the same as the current linestr SV?
956 * Only in this case does re_eval_start need adjusting, since it
957 * points within lex_shared->ls_linestr's buffer */
958 current = ( !PL_parser->lex_shared->ls_linestr
959 || linestr == PL_parser->lex_shared->ls_linestr);
961 bufend_pos = PL_parser->bufend - buf;
962 bufptr_pos = PL_parser->bufptr - buf;
963 oldbufptr_pos = PL_parser->oldbufptr - buf;
964 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
965 linestart_pos = PL_parser->linestart - buf;
966 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
967 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
968 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
969 PL_parser->lex_shared->re_eval_start - buf : 0;
971 buf = sv_grow(linestr, len);
973 PL_parser->bufend = buf + bufend_pos;
974 PL_parser->bufptr = buf + bufptr_pos;
975 PL_parser->oldbufptr = buf + oldbufptr_pos;
976 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
977 PL_parser->linestart = buf + linestart_pos;
978 if (PL_parser->last_uni)
979 PL_parser->last_uni = buf + last_uni_pos;
980 if (PL_parser->last_lop)
981 PL_parser->last_lop = buf + last_lop_pos;
982 if (current && PL_parser->lex_shared->re_eval_start)
983 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
988 =for apidoc lex_stuff_pvn
990 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
991 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
992 reallocating the buffer if necessary. This means that lexing code that
993 runs later will see the characters as if they had appeared in the input.
994 It is not recommended to do this as part of normal parsing, and most
995 uses of this facility run the risk of the inserted characters being
996 interpreted in an unintended manner.
998 The string to be inserted is represented by C<len> octets starting
999 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1000 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1001 The characters are recoded for the lexer buffer, according to how the
1002 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1003 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1004 function is more convenient.
1006 =for apidoc Amnh||LEX_STUFF_UTF8
1012 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1016 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1017 if (flags & ~(LEX_STUFF_UTF8))
1018 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1020 if (flags & LEX_STUFF_UTF8) {
1023 STRLEN highhalf = variant_under_utf8_count((U8 *) pv,
1025 const char *p, *e = pv+len;;
1028 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1029 bufptr = PL_parser->bufptr;
1030 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1031 SvCUR_set(PL_parser->linestr,
1032 SvCUR(PL_parser->linestr) + len+highhalf);
1033 PL_parser->bufend += len+highhalf;
1034 for (p = pv; p != e; p++) {
1035 append_utf8_from_native_byte(*p, (U8 **) &bufptr);
1039 if (flags & LEX_STUFF_UTF8) {
1040 STRLEN highhalf = 0;
1041 const char *p, *e = pv+len;
1042 for (p = pv; p != e; p++) {
1044 if (UTF8_IS_ABOVE_LATIN1(c)) {
1045 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1046 "non-Latin-1 character into Latin-1 input");
1047 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1050 } else assert(UTF8_IS_INVARIANT(c));
1054 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1055 bufptr = PL_parser->bufptr;
1056 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1057 SvCUR_set(PL_parser->linestr,
1058 SvCUR(PL_parser->linestr) + len-highhalf);
1059 PL_parser->bufend += len-highhalf;
1062 if (UTF8_IS_INVARIANT(*p)) {
1068 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1074 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1075 bufptr = PL_parser->bufptr;
1076 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1077 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1078 PL_parser->bufend += len;
1079 Copy(pv, bufptr, len, char);
1085 =for apidoc lex_stuff_pv
1087 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1088 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1089 reallocating the buffer if necessary. This means that lexing code that
1090 runs later will see the characters as if they had appeared in the input.
1091 It is not recommended to do this as part of normal parsing, and most
1092 uses of this facility run the risk of the inserted characters being
1093 interpreted in an unintended manner.
1095 The string to be inserted is represented by octets starting at C<pv>
1096 and continuing to the first nul. These octets are interpreted as either
1097 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1098 in C<flags>. The characters are recoded for the lexer buffer, according
1099 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1100 If it is not convenient to nul-terminate a string to be inserted, the
1101 L</lex_stuff_pvn> function is more appropriate.
1107 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1109 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1110 lex_stuff_pvn(pv, strlen(pv), flags);
1114 =for apidoc lex_stuff_sv
1116 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1117 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1118 reallocating the buffer if necessary. This means that lexing code that
1119 runs later will see the characters as if they had appeared in the input.
1120 It is not recommended to do this as part of normal parsing, and most
1121 uses of this facility run the risk of the inserted characters being
1122 interpreted in an unintended manner.
1124 The string to be inserted is the string value of C<sv>. The characters
1125 are recoded for the lexer buffer, according to how the buffer is currently
1126 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1127 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1128 need to construct a scalar.
1134 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1138 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1142 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1146 =for apidoc lex_unstuff
1148 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1149 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1150 This hides the discarded text from any lexing code that runs later,
1151 as if the text had never appeared.
1153 This is not the normal way to consume lexed text. For that, use
1160 Perl_lex_unstuff(pTHX_ char *ptr)
1164 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1165 buf = PL_parser->bufptr;
1167 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1170 bufend = PL_parser->bufend;
1172 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1173 unstuff_len = ptr - buf;
1174 Move(ptr, buf, bufend+1-ptr, char);
1175 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1176 PL_parser->bufend = bufend - unstuff_len;
1180 =for apidoc lex_read_to
1182 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1183 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1184 performing the correct bookkeeping whenever a newline character is passed.
1185 This is the normal way to consume lexed text.
1187 Interpretation of the buffer's octets can be abstracted out by
1188 using the slightly higher-level functions L</lex_peek_unichar> and
1189 L</lex_read_unichar>.
1195 Perl_lex_read_to(pTHX_ char *ptr)
1198 PERL_ARGS_ASSERT_LEX_READ_TO;
1199 s = PL_parser->bufptr;
1200 if (ptr < s || ptr > PL_parser->bufend)
1201 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1202 for (; s != ptr; s++)
1204 COPLINE_INC_WITH_HERELINES;
1205 PL_parser->linestart = s+1;
1207 PL_parser->bufptr = ptr;
1211 =for apidoc lex_discard_to
1213 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1214 up to C<ptr>. The remaining content of the buffer will be moved, and
1215 all pointers into the buffer updated appropriately. C<ptr> must not
1216 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1217 it is not permitted to discard text that has yet to be lexed.
1219 Normally it is not necessarily to do this directly, because it suffices to
1220 use the implicit discarding behaviour of L</lex_next_chunk> and things
1221 based on it. However, if a token stretches across multiple lines,
1222 and the lexing code has kept multiple lines of text in the buffer for
1223 that purpose, then after completion of the token it would be wise to
1224 explicitly discard the now-unneeded earlier lines, to avoid future
1225 multi-line tokens growing the buffer without bound.
1231 Perl_lex_discard_to(pTHX_ char *ptr)
1235 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1236 buf = SvPVX(PL_parser->linestr);
1238 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1241 if (ptr > PL_parser->bufptr)
1242 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1243 discard_len = ptr - buf;
1244 if (PL_parser->oldbufptr < ptr)
1245 PL_parser->oldbufptr = ptr;
1246 if (PL_parser->oldoldbufptr < ptr)
1247 PL_parser->oldoldbufptr = ptr;
1248 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1249 PL_parser->last_uni = NULL;
1250 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1251 PL_parser->last_lop = NULL;
1252 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1253 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1254 PL_parser->bufend -= discard_len;
1255 PL_parser->bufptr -= discard_len;
1256 PL_parser->oldbufptr -= discard_len;
1257 PL_parser->oldoldbufptr -= discard_len;
1258 if (PL_parser->last_uni)
1259 PL_parser->last_uni -= discard_len;
1260 if (PL_parser->last_lop)
1261 PL_parser->last_lop -= discard_len;
1265 Perl_notify_parser_that_changed_to_utf8(pTHX)
1267 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1268 * off to on. At compile time, this has the effect of entering a 'use
1269 * utf8' section. This means that any input was not previously checked for
1270 * UTF-8 (because it was off), but now we do need to check it, or our
1271 * assumptions about the input being sane could be wrong, and we could
1272 * segfault. This routine just sets a flag so that the next time we look
1273 * at the input we do the well-formed UTF-8 check. If we aren't in the
1274 * proper phase, there may not be a parser object, but if there is, setting
1275 * the flag is harmless */
1278 PL_parser->recheck_utf8_validity = TRUE;
1283 =for apidoc lex_next_chunk
1285 Reads in the next chunk of text to be lexed, appending it to
1286 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1287 looked to the end of the current chunk and wants to know more. It is
1288 usual, but not necessary, for lexing to have consumed the entirety of
1289 the current chunk at this time.
1291 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1292 chunk (i.e., the current chunk has been entirely consumed), normally the
1293 current chunk will be discarded at the same time that the new chunk is
1294 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1295 will not be discarded. If the current chunk has not been entirely
1296 consumed, then it will not be discarded regardless of the flag.
1298 Returns true if some new text was added to the buffer, or false if the
1299 buffer has reached the end of the input text.
1301 =for apidoc Amnh||LEX_KEEP_PREVIOUS
1306 #define LEX_FAKE_EOF 0x80000000
1307 #define LEX_NO_TERM 0x40000000 /* here-doc */
1310 Perl_lex_next_chunk(pTHX_ U32 flags)
1314 STRLEN old_bufend_pos, new_bufend_pos;
1315 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1316 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1317 bool got_some_for_debugger = 0;
1320 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1321 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1322 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1324 linestr = PL_parser->linestr;
1325 buf = SvPVX(linestr);
1326 if (!(flags & LEX_KEEP_PREVIOUS)
1327 && PL_parser->bufptr == PL_parser->bufend)
1329 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1331 if (PL_parser->last_uni != PL_parser->bufend)
1332 PL_parser->last_uni = NULL;
1333 if (PL_parser->last_lop != PL_parser->bufend)
1334 PL_parser->last_lop = NULL;
1335 last_uni_pos = last_lop_pos = 0;
1337 SvCUR_set(linestr, 0);
1339 old_bufend_pos = PL_parser->bufend - buf;
1340 bufptr_pos = PL_parser->bufptr - buf;
1341 oldbufptr_pos = PL_parser->oldbufptr - buf;
1342 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1343 linestart_pos = PL_parser->linestart - buf;
1344 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1345 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1347 if (flags & LEX_FAKE_EOF) {
1349 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1351 } else if (filter_gets(linestr, old_bufend_pos)) {
1353 got_some_for_debugger = 1;
1354 } else if (flags & LEX_NO_TERM) {
1357 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1360 /* End of real input. Close filehandle (unless it was STDIN),
1361 * then add implicit termination.
1363 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1364 PerlIO_clearerr(PL_parser->rsfp);
1365 else if (PL_parser->rsfp)
1366 (void)PerlIO_close(PL_parser->rsfp);
1367 PL_parser->rsfp = NULL;
1368 PL_parser->in_pod = PL_parser->filtered = 0;
1369 if (!PL_in_eval && PL_minus_p) {
1371 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1372 PL_minus_n = PL_minus_p = 0;
1373 } else if (!PL_in_eval && PL_minus_n) {
1374 sv_catpvs(linestr, /*{*/";}");
1377 sv_catpvs(linestr, ";");
1380 buf = SvPVX(linestr);
1381 new_bufend_pos = SvCUR(linestr);
1382 PL_parser->bufend = buf + new_bufend_pos;
1383 PL_parser->bufptr = buf + bufptr_pos;
1386 const U8* first_bad_char_loc;
1387 if (UNLIKELY(! is_utf8_string_loc(
1388 (U8 *) PL_parser->bufptr,
1389 PL_parser->bufend - PL_parser->bufptr,
1390 &first_bad_char_loc)))
1392 _force_out_malformed_utf8_message(first_bad_char_loc,
1393 (U8 *) PL_parser->bufend,
1395 1 /* 1 means die */ );
1396 NOT_REACHED; /* NOTREACHED */
1400 PL_parser->oldbufptr = buf + oldbufptr_pos;
1401 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1402 PL_parser->linestart = buf + linestart_pos;
1403 if (PL_parser->last_uni)
1404 PL_parser->last_uni = buf + last_uni_pos;
1405 if (PL_parser->last_lop)
1406 PL_parser->last_lop = buf + last_lop_pos;
1407 if (PL_parser->preambling != NOLINE) {
1408 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1409 PL_parser->preambling = NOLINE;
1411 if ( got_some_for_debugger
1412 && PERLDB_LINE_OR_SAVESRC
1413 && PL_curstash != PL_debstash)
1415 /* debugger active and we're not compiling the debugger code,
1416 * so store the line into the debugger's array of lines
1418 update_debugger_info(NULL, buf+old_bufend_pos,
1419 new_bufend_pos-old_bufend_pos);
1425 =for apidoc lex_peek_unichar
1427 Looks ahead one (Unicode) character in the text currently being lexed.
1428 Returns the codepoint (unsigned integer value) of the next character,
1429 or -1 if lexing has reached the end of the input text. To consume the
1430 peeked character, use L</lex_read_unichar>.
1432 If the next character is in (or extends into) the next chunk of input
1433 text, the next chunk will be read in. Normally the current chunk will be
1434 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1435 bit set, then the current chunk will not be discarded.
1437 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1438 is encountered, an exception is generated.
1444 Perl_lex_peek_unichar(pTHX_ U32 flags)
1448 if (flags & ~(LEX_KEEP_PREVIOUS))
1449 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1450 s = PL_parser->bufptr;
1451 bufend = PL_parser->bufend;
1457 if (!lex_next_chunk(flags))
1459 s = PL_parser->bufptr;
1460 bufend = PL_parser->bufend;
1463 if (UTF8_IS_INVARIANT(head))
1465 if (UTF8_IS_START(head)) {
1466 len = UTF8SKIP(&head);
1467 while ((STRLEN)(bufend-s) < len) {
1468 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1470 s = PL_parser->bufptr;
1471 bufend = PL_parser->bufend;
1474 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1475 if (retlen == (STRLEN)-1) {
1476 _force_out_malformed_utf8_message((U8 *) s,
1479 1 /* 1 means die */ );
1480 NOT_REACHED; /* NOTREACHED */
1485 if (!lex_next_chunk(flags))
1487 s = PL_parser->bufptr;
1494 =for apidoc lex_read_unichar
1496 Reads the next (Unicode) character in the text currently being lexed.
1497 Returns the codepoint (unsigned integer value) of the character read,
1498 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1499 if lexing has reached the end of the input text. To non-destructively
1500 examine the next character, use L</lex_peek_unichar> instead.
1502 If the next character is in (or extends into) the next chunk of input
1503 text, the next chunk will be read in. Normally the current chunk will be
1504 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1505 bit set, then the current chunk will not be discarded.
1507 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1508 is encountered, an exception is generated.
1514 Perl_lex_read_unichar(pTHX_ U32 flags)
1517 if (flags & ~(LEX_KEEP_PREVIOUS))
1518 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1519 c = lex_peek_unichar(flags);
1522 COPLINE_INC_WITH_HERELINES;
1524 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1526 ++(PL_parser->bufptr);
1532 =for apidoc lex_read_space
1534 Reads optional spaces, in Perl style, in the text currently being
1535 lexed. The spaces may include ordinary whitespace characters and
1536 Perl-style comments. C<#line> directives are processed if encountered.
1537 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1538 at a non-space character (or the end of the input text).
1540 If spaces extend into the next chunk of input text, the next chunk will
1541 be read in. Normally the current chunk will be discarded at the same
1542 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1543 chunk will not be discarded.
1548 #define LEX_NO_INCLINE 0x40000000
1549 #define LEX_NO_NEXT_CHUNK 0x80000000
1552 Perl_lex_read_space(pTHX_ U32 flags)
1555 const bool can_incline = !(flags & LEX_NO_INCLINE);
1556 bool need_incline = 0;
1557 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1558 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1559 s = PL_parser->bufptr;
1560 bufend = PL_parser->bufend;
1566 } while (!(c == '\n' || (c == 0 && s == bufend)));
1567 } else if (c == '\n') {
1570 PL_parser->linestart = s;
1576 } else if (isSPACE(c)) {
1578 } else if (c == 0 && s == bufend) {
1581 if (flags & LEX_NO_NEXT_CHUNK)
1583 PL_parser->bufptr = s;
1584 l = CopLINE(PL_curcop);
1585 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1586 got_more = lex_next_chunk(flags);
1587 CopLINE_set(PL_curcop, l);
1588 s = PL_parser->bufptr;
1589 bufend = PL_parser->bufend;
1592 if (can_incline && need_incline && PL_parser->rsfp) {
1602 PL_parser->bufptr = s;
1607 =for apidoc validate_proto
1609 This function performs syntax checking on a prototype, C<proto>.
1610 If C<warn> is true, any illegal characters or mismatched brackets
1611 will trigger illegalproto warnings, declaring that they were
1612 detected in the prototype for C<name>.
1614 The return value is C<true> if this is a valid prototype, and
1615 C<false> if it is not, regardless of whether C<warn> was C<true> or
1618 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1625 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1627 STRLEN len, origlen;
1629 bool bad_proto = FALSE;
1630 bool in_brackets = FALSE;
1631 bool after_slash = FALSE;
1632 char greedy_proto = ' ';
1633 bool proto_after_greedy_proto = FALSE;
1634 bool must_be_last = FALSE;
1635 bool underscore = FALSE;
1636 bool bad_proto_after_underscore = FALSE;
1638 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1643 p = SvPV(proto, len);
1645 for (; len--; p++) {
1648 proto_after_greedy_proto = TRUE;
1650 if (!memCHRs(";@%", *p))
1651 bad_proto_after_underscore = TRUE;
1654 if (!memCHRs("$@%*;[]&\\_+", *p) || *p == '\0') {
1661 in_brackets = FALSE;
1662 else if ((*p == '@' || *p == '%')
1666 must_be_last = TRUE;
1675 after_slash = FALSE;
1680 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1683 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1684 origlen, UNI_DISPLAY_ISPRINT)
1685 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1687 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1688 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1689 sv_catpvs(name2, "::");
1690 sv_catsv(name2, (SV *)name);
1694 if (proto_after_greedy_proto)
1695 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1696 "Prototype after '%c' for %" SVf " : %s",
1697 greedy_proto, SVfARG(name), p);
1699 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1700 "Missing ']' in prototype for %" SVf " : %s",
1703 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1704 "Illegal character in prototype for %" SVf " : %s",
1706 if (bad_proto_after_underscore)
1707 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1708 "Illegal character after '_' in prototype for %" SVf " : %s",
1712 return (! (proto_after_greedy_proto || bad_proto) );
1717 * This subroutine has nothing to do with tilting, whether at windmills
1718 * or pinball tables. Its name is short for "increment line". It
1719 * increments the current line number in CopLINE(PL_curcop) and checks
1720 * to see whether the line starts with a comment of the form
1721 * # line 500 "foo.pm"
1722 * If so, it sets the current line number and file to the values in the comment.
1726 S_incline(pTHX_ const char *s, const char *end)
1734 PERL_ARGS_ASSERT_INCLINE;
1738 COPLINE_INC_WITH_HERELINES;
1739 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1740 && s+1 == PL_bufend && *s == ';') {
1741 /* fake newline in string eval */
1742 CopLINE_dec(PL_curcop);
1747 while (SPACE_OR_TAB(*s))
1749 if (memBEGINs(s, (STRLEN) (end - s), "line"))
1750 s += sizeof("line") - 1;
1753 if (SPACE_OR_TAB(*s))
1757 while (SPACE_OR_TAB(*s))
1765 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1767 while (SPACE_OR_TAB(*s))
1769 if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) {
1775 while (*t && !isSPACE(*t))
1779 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1781 if (*e != '\n' && *e != '\0')
1782 return; /* false alarm */
1784 if (!grok_atoUV(n, &uv, &e))
1786 line_num = ((line_t)uv) - 1;
1789 const STRLEN len = t - s;
1791 if (!PL_rsfp && !PL_parser->filtered) {
1792 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1793 * to *{"::_<newfilename"} */
1794 /* However, the long form of evals is only turned on by the
1795 debugger - usually they're "(eval %lu)" */
1796 GV * const cfgv = CopFILEGV(PL_curcop);
1799 STRLEN tmplen2 = len;
1803 if (tmplen2 + 2 <= sizeof smallbuf)
1806 Newx(tmpbuf2, tmplen2 + 2, char);
1811 memcpy(tmpbuf2 + 2, s, tmplen2);
1814 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1816 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1817 /* adjust ${"::_<newfilename"} to store the new file name */
1818 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1819 /* The line number may differ. If that is the case,
1820 alias the saved lines that are in the array.
1821 Otherwise alias the whole array. */
1822 if (CopLINE(PL_curcop) == line_num) {
1823 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1824 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1826 else if (GvAV(cfgv)) {
1827 AV * const av = GvAV(cfgv);
1828 const line_t start = CopLINE(PL_curcop)+1;
1829 SSize_t items = AvFILLp(av) - start;
1831 AV * const av2 = GvAVn(gv2);
1832 SV **svp = AvARRAY(av) + start;
1833 Size_t l = line_num+1;
1834 while (items-- && l < SSize_t_MAX && l == (line_t)l)
1835 av_store(av2, (SSize_t)l++, SvREFCNT_inc(*svp++));
1840 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1843 CopFILE_free(PL_curcop);
1844 CopFILE_setn(PL_curcop, s, len);
1846 CopLINE_set(PL_curcop, line_num);
1850 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1852 AV *av = CopFILEAVx(PL_curcop);
1855 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1857 sv = *av_fetch(av, 0, 1);
1858 SvUPGRADE(sv, SVt_PVMG);
1860 if (!SvPOK(sv)) SvPVCLEAR(sv);
1862 sv_catsv(sv, orig_sv);
1864 sv_catpvn(sv, buf, len);
1869 if (PL_parser->preambling == NOLINE)
1870 av_store(av, CopLINE(PL_curcop), sv);
1876 * Called to gobble the appropriate amount and type of whitespace.
1877 * Skips comments as well.
1878 * Returns the next character after the whitespace that is skipped.
1881 * Same thing, but look ahead without incrementing line numbers or
1882 * adjusting PL_linestart.
1885 #define skipspace(s) skipspace_flags(s, 0)
1886 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1889 Perl_skipspace_flags(pTHX_ char *s, U32 flags)
1891 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1892 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1893 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1896 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1898 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1899 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1900 LEX_NO_NEXT_CHUNK : 0));
1902 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1903 if (PL_linestart > PL_bufptr)
1904 PL_bufptr = PL_linestart;
1912 * Check the unary operators to ensure there's no ambiguity in how they're
1913 * used. An ambiguous piece of code would be:
1915 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1916 * the +5 is its argument.
1924 if (PL_oldoldbufptr != PL_last_uni)
1926 while (isSPACE(*PL_last_uni))
1929 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1930 s += UTF ? UTF8SKIP(s) : 1;
1931 if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s))
1934 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1935 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1936 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1940 * LOP : macro to build a list operator. Its behaviour has been replaced
1941 * with a subroutine, S_lop() for which LOP is just another name.
1944 #define LOP(f,x) return lop(f,x,s)
1948 * Build a list operator (or something that might be one). The rules:
1949 * - if we have a next token, then it's a list operator (no parens) for
1950 * which the next token has already been parsed; e.g.,
1953 * - if the next thing is an opening paren, then it's a function
1954 * - else it's a list operator
1958 S_lop(pTHX_ I32 f, U8 x, char *s)
1960 PERL_ARGS_ASSERT_LOP;
1965 PL_last_lop = PL_oldbufptr;
1966 PL_last_lop_op = (OPCODE)f;
1971 return REPORT(FUNC);
1974 return REPORT(FUNC);
1977 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1978 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1979 return REPORT(LSTOP);
1985 * When the lexer realizes it knows the next token (for instance,
1986 * it is reordering tokens for the parser) then it can call S_force_next
1987 * to know what token to return the next time the lexer is called. Caller
1988 * will need to set PL_nextval[] and possibly PL_expect to ensure
1989 * the lexer handles the token correctly.
1993 S_force_next(pTHX_ I32 type)
1997 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1998 tokereport(type, &NEXTVAL_NEXTTOKE);
2001 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2002 PL_nexttype[PL_nexttoke] = type;
2009 * This subroutine handles postfix deref syntax after the arrow has already
2010 * been emitted. @* $* etc. are emitted as two separate tokens right here.
2011 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2012 * only the first, leaving yylex to find the next.
2016 S_postderef(pTHX_ int const funny, char const next)
2018 assert(funny == DOLSHARP || memCHRs("$@%&*", funny));
2020 PL_expect = XOPERATOR;
2021 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2022 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2023 PL_lex_state = LEX_INTERPEND;
2025 force_next(POSTJOIN);
2031 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2032 && !PL_lex_brackets)
2034 PL_expect = XOPERATOR;
2043 int yyc = PL_parser->yychar;
2044 if (yyc != YYEMPTY) {
2046 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2047 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2048 PL_lex_allbrackets--;
2050 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2051 } else if (yyc == '('/*)*/) {
2052 PL_lex_allbrackets--;
2057 PL_parser->yychar = YYEMPTY;
2062 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2064 SV * const sv = newSVpvn_utf8(start, len,
2068 && is_utf8_non_invariant_string((const U8*)start, len));
2074 * When the lexer knows the next thing is a word (for instance, it has
2075 * just seen -> and it knows that the next char is a word char, then
2076 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2080 * char *start : buffer position (must be within PL_linestr)
2081 * int token : PL_next* will be this type of bare word
2082 * (e.g., METHOD,BAREWORD)
2083 * int check_keyword : if true, Perl checks to make sure the word isn't
2084 * a keyword (do this if the word is a label, e.g. goto FOO)
2085 * int allow_pack : if true, : characters will also be allowed (require,
2086 * use, etc. do this)
2090 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2095 PERL_ARGS_ASSERT_FORCE_WORD;
2097 start = skipspace(start);
2099 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2100 || (allow_pack && *s == ':' && s[1] == ':') )
2102 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2103 if (check_keyword) {
2104 char *s2 = PL_tokenbuf;
2106 if (allow_pack && memBEGINPs(s2, len, "CORE::")) {
2107 s2 += sizeof("CORE::") - 1;
2108 len2 -= sizeof("CORE::") - 1;
2110 if (keyword(s2, len2, 0))
2113 if (token == METHOD) {
2118 PL_expect = XOPERATOR;
2121 NEXTVAL_NEXTTOKE.opval
2122 = newSVOP(OP_CONST,0,
2123 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2124 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2132 * Called when the lexer wants $foo *foo &foo etc, but the program
2133 * text only contains the "foo" portion. The first argument is a pointer
2134 * to the "foo", and the second argument is the type symbol to prefix.
2135 * Forces the next token to be a "BAREWORD".
2136 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2140 S_force_ident(pTHX_ const char *s, int kind)
2142 PERL_ARGS_ASSERT_FORCE_IDENT;
2145 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2146 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2147 UTF ? SVf_UTF8 : 0));
2148 NEXTVAL_NEXTTOKE.opval = o;
2149 force_next(BAREWORD);
2151 o->op_private = OPpCONST_ENTERED;
2152 /* XXX see note in pp_entereval() for why we forgo typo
2153 warnings if the symbol must be introduced in an eval.
2155 gv_fetchpvn_flags(s, len,
2156 (PL_in_eval ? GV_ADDMULTI
2157 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2158 kind == '$' ? SVt_PV :
2159 kind == '@' ? SVt_PVAV :
2160 kind == '%' ? SVt_PVHV :
2168 S_force_ident_maybe_lex(pTHX_ char pit)
2170 NEXTVAL_NEXTTOKE.ival = pit;
2175 Perl_str_to_version(pTHX_ SV *sv)
2180 const char *start = SvPV_const(sv,len);
2181 const char * const end = start + len;
2182 const bool utf = cBOOL(SvUTF8(sv));
2184 PERL_ARGS_ASSERT_STR_TO_VERSION;
2186 while (start < end) {
2190 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2195 retval += ((NV)n)/nshift;
2204 * Forces the next token to be a version number.
2205 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2206 * and if "guessing" is TRUE, then no new token is created (and the caller
2207 * must use an alternative parsing method).
2211 S_force_version(pTHX_ char *s, int guessing)
2216 PERL_ARGS_ASSERT_FORCE_VERSION;
2224 while (isDIGIT(*d) || *d == '_' || *d == '.')
2226 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2228 s = scan_num(s, &pl_yylval);
2229 version = pl_yylval.opval;
2230 ver = cSVOPx(version)->op_sv;
2231 if (SvPOK(ver) && !SvNIOK(ver)) {
2232 SvUPGRADE(ver, SVt_PVNV);
2233 SvNV_set(ver, str_to_version(ver));
2234 SvNOK_on(ver); /* hint that it is a version */
2237 else if (guessing) {
2242 /* NOTE: The parser sees the package name and the VERSION swapped */
2243 NEXTVAL_NEXTTOKE.opval = version;
2244 force_next(BAREWORD);
2250 * S_force_strict_version
2251 * Forces the next token to be a version number using strict syntax rules.
2255 S_force_strict_version(pTHX_ char *s)
2258 const char *errstr = NULL;
2260 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2262 while (isSPACE(*s)) /* leading whitespace */
2265 if (is_STRICT_VERSION(s,&errstr)) {
2267 s = (char *)scan_version(s, ver, 0);
2268 version = newSVOP(OP_CONST, 0, ver);
2270 else if ((*s != ';' && *s != '{' && *s != '}' )
2271 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2275 yyerror(errstr); /* version required */
2279 /* NOTE: The parser sees the package name and the VERSION swapped */
2280 NEXTVAL_NEXTTOKE.opval = version;
2281 force_next(BAREWORD);
2288 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2289 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2290 * unchanged, and a new SV containing the modified input is returned.
2294 S_tokeq(pTHX_ SV *sv)
2301 PERL_ARGS_ASSERT_TOKEQ;
2305 assert (!SvIsCOW(sv));
2306 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2310 /* This is relying on the SV being "well formed" with a trailing '\0' */
2311 while (s < send && !(*s == '\\' && s[1] == '\\'))
2316 if ( PL_hints & HINT_NEW_STRING ) {
2317 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2318 SVs_TEMP | SvUTF8(sv));
2322 if (s + 1 < send && (s[1] == '\\'))
2323 s++; /* all that, just for this */
2328 SvCUR_set(sv, d - SvPVX_const(sv));
2330 if ( PL_hints & HINT_NEW_STRING )
2331 return new_constant(NULL, 0, "q", sv, pv, "q", 1, NULL);
2336 * Now come three functions related to double-quote context,
2337 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2338 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2339 * interact with PL_lex_state, and create fake ( ... ) argument lists
2340 * to handle functions and concatenation.
2344 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2349 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2351 * Pattern matching will set PL_lex_op to the pattern-matching op to
2352 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2354 * OP_CONST is easy--just make the new op and return.
2356 * Everything else becomes a FUNC.
2358 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2359 * had an OP_CONST. This just sets us up for a
2360 * call to S_sublex_push().
2364 S_sublex_start(pTHX)
2366 const I32 op_type = pl_yylval.ival;
2368 if (op_type == OP_NULL) {
2369 pl_yylval.opval = PL_lex_op;
2373 if (op_type == OP_CONST) {
2374 SV *sv = PL_lex_stuff;
2375 PL_lex_stuff = NULL;
2378 if (SvTYPE(sv) == SVt_PVIV) {
2379 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2381 const char * const p = SvPV_const(sv, len);
2382 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2386 pl_yylval.opval = newSVOP(op_type, 0, sv);
2390 PL_parser->lex_super_state = PL_lex_state;
2391 PL_parser->lex_sub_inwhat = (U16)op_type;
2392 PL_parser->lex_sub_op = PL_lex_op;
2393 PL_parser->sub_no_recover = FALSE;
2394 PL_parser->sub_error_count = PL_error_count;
2395 PL_lex_state = LEX_INTERPPUSH;
2399 pl_yylval.opval = PL_lex_op;
2409 * Create a new scope to save the lexing state. The scope will be
2410 * ended in S_sublex_done. Returns a '(', starting the function arguments
2411 * to the uc, lc, etc. found before.
2412 * Sets PL_lex_state to LEX_INTERPCONCAT.
2419 const bool is_heredoc = PL_multi_close == '<';
2422 PL_lex_state = PL_parser->lex_super_state;
2423 SAVEI8(PL_lex_dojoin);
2424 SAVEI32(PL_lex_brackets);
2425 SAVEI32(PL_lex_allbrackets);
2426 SAVEI32(PL_lex_formbrack);
2427 SAVEI8(PL_lex_fakeeof);
2428 SAVEI32(PL_lex_casemods);
2429 SAVEI32(PL_lex_starts);
2430 SAVEI8(PL_lex_state);
2431 SAVESPTR(PL_lex_repl);
2432 SAVEVPTR(PL_lex_inpat);
2433 SAVEI16(PL_lex_inwhat);
2436 SAVECOPLINE(PL_curcop);
2437 SAVEI32(PL_multi_end);
2438 SAVEI32(PL_parser->herelines);
2439 PL_parser->herelines = 0;
2441 SAVEIV(PL_multi_close);
2442 SAVEPPTR(PL_bufptr);
2443 SAVEPPTR(PL_bufend);
2444 SAVEPPTR(PL_oldbufptr);
2445 SAVEPPTR(PL_oldoldbufptr);
2446 SAVEPPTR(PL_last_lop);
2447 SAVEPPTR(PL_last_uni);
2448 SAVEPPTR(PL_linestart);
2449 SAVESPTR(PL_linestr);
2450 SAVEGENERICPV(PL_lex_brackstack);
2451 SAVEGENERICPV(PL_lex_casestack);
2452 SAVEGENERICPV(PL_parser->lex_shared);
2453 SAVEBOOL(PL_parser->lex_re_reparsing);
2454 SAVEI32(PL_copline);
2456 /* The here-doc parser needs to be able to peek into outer lexing
2457 scopes to find the body of the here-doc. So we put PL_linestr and
2458 PL_bufptr into lex_shared, to ‘share’ those values.
2460 PL_parser->lex_shared->ls_linestr = PL_linestr;
2461 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2463 PL_linestr = PL_lex_stuff;
2464 PL_lex_repl = PL_parser->lex_sub_repl;
2465 PL_lex_stuff = NULL;
2466 PL_parser->lex_sub_repl = NULL;
2468 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2469 set for an inner quote-like operator and then an error causes scope-
2470 popping. We must not have a PL_lex_stuff value left dangling, as
2471 that breaks assumptions elsewhere. See bug #123617. */
2472 SAVEGENERICSV(PL_lex_stuff);
2473 SAVEGENERICSV(PL_parser->lex_sub_repl);
2475 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2476 = SvPVX(PL_linestr);
2477 PL_bufend += SvCUR(PL_linestr);
2478 PL_last_lop = PL_last_uni = NULL;
2479 SAVEFREESV(PL_linestr);
2480 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2482 PL_lex_dojoin = FALSE;
2483 PL_lex_brackets = PL_lex_formbrack = 0;
2484 PL_lex_allbrackets = 0;
2485 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2486 Newx(PL_lex_brackstack, 120, char);
2487 Newx(PL_lex_casestack, 12, char);
2488 PL_lex_casemods = 0;
2489 *PL_lex_casestack = '\0';
2491 PL_lex_state = LEX_INTERPCONCAT;
2493 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2494 PL_copline = NOLINE;
2496 Newxz(shared, 1, LEXSHARED);
2497 shared->ls_prev = PL_parser->lex_shared;
2498 PL_parser->lex_shared = shared;
2500 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2501 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2502 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2503 PL_lex_inpat = PL_parser->lex_sub_op;
2505 PL_lex_inpat = NULL;
2507 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2508 PL_in_eval &= ~EVAL_RE_REPARSING;
2515 * Restores lexer state after a S_sublex_push.
2521 if (!PL_lex_starts++) {
2522 SV * const sv = newSVpvs("");
2523 if (SvUTF8(PL_linestr))
2525 PL_expect = XOPERATOR;
2526 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2530 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2531 PL_lex_state = LEX_INTERPCASEMOD;
2535 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2536 assert(PL_lex_inwhat != OP_TRANSR);
2538 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2539 PL_linestr = PL_lex_repl;
2541 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2542 PL_bufend += SvCUR(PL_linestr);
2543 PL_last_lop = PL_last_uni = NULL;
2544 PL_lex_dojoin = FALSE;
2545 PL_lex_brackets = 0;
2546 PL_lex_allbrackets = 0;
2547 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2548 PL_lex_casemods = 0;
2549 *PL_lex_casestack = '\0';
2551 if (SvEVALED(PL_lex_repl)) {
2552 PL_lex_state = LEX_INTERPNORMAL;
2554 /* we don't clear PL_lex_repl here, so that we can check later
2555 whether this is an evalled subst; that means we rely on the
2556 logic to ensure sublex_done() is called again only via the
2557 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2560 PL_lex_state = LEX_INTERPCONCAT;
2563 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2564 CopLINE(PL_curcop) +=
2565 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2566 + PL_parser->herelines;
2567 PL_parser->herelines = 0;
2572 const line_t l = CopLINE(PL_curcop);
2574 if (PL_parser->sub_error_count != PL_error_count) {
2575 if (PL_parser->sub_no_recover) {
2580 if (PL_multi_close == '<')
2581 PL_parser->herelines += l - PL_multi_end;
2582 PL_bufend = SvPVX(PL_linestr);
2583 PL_bufend += SvCUR(PL_linestr);
2584 PL_expect = XOPERATOR;
2590 Perl_load_charnames(pTHX_ SV * char_name, const char * context,
2591 const STRLEN context_len, const char ** error_msg)
2593 /* Load the official _charnames module if not already there. The
2594 * parameters are just to give info for any error messages generated:
2595 * char_name a name to look up which is the reason for loading this
2596 * context 'char_name' in the context in the input in which it appears
2597 * context_len how many bytes 'context' occupies
2598 * error_msg *error_msg will be set to any error
2600 * Returns the ^H table if success; otherwise NULL */
2607 PERL_ARGS_ASSERT_LOAD_CHARNAMES;
2609 /* This loop is executed 1 1/2 times. On the first time through, if it
2610 * isn't already loaded, try loading it, and iterate just once to see if it
2612 for (i = 0; i < 2; i++) {
2613 table = GvHV(PL_hintgv); /* ^H */
2616 && (PL_hints & HINT_LOCALIZE_HH)
2617 && (cvp = hv_fetchs(table, "charnames", FALSE))
2620 return table; /* Quit if already loaded */
2624 Perl_load_module(aTHX_
2626 newSVpvs("_charnames"),
2628 /* version parameter; no need to specify it, as if we get too early
2629 * a version, will fail anyway, not being able to find 'charnames'
2638 /* Here, it failed; new_constant will give appropriate error messages */
2640 res = new_constant( NULL, 0, "charnames", char_name, NULL,
2641 context, context_len, error_msg);
2648 S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e)
2650 /* This justs wraps get_and_check_backslash_N_name() to output any error
2651 * message it returns. */
2653 const char * error_msg = NULL;
2656 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME_WRAPPER;
2658 /* charnames doesn't work well if there have been errors found */
2659 if (PL_error_count > 0) {
2663 result = get_and_check_backslash_N_name(s, e, cBOOL(UTF), &error_msg);
2666 yyerror_pv(error_msg, UTF ? SVf_UTF8 : 0);
2673 Perl_get_and_check_backslash_N_name(pTHX_ const char* s,
2674 const char* const e,
2676 const char ** error_msg)
2678 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2679 * interior, hence to the "}". Finds what the name resolves to, returning
2680 * an SV* containing it; NULL if no valid one found.
2682 * 'is_utf8' is TRUE if we know we want the result to be UTF-8 even if it
2683 * doesn't have to be. */
2693 /* Points to the beginning of the \N{... so that any messages include the
2694 * context of what's failing*/
2695 const char* context = s - 3;
2696 STRLEN context_len = e - context + 1; /* include all of \N{...} */
2700 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2703 assert(s > (char *) 3);
2705 char_name = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0);
2707 if (!SvCUR(char_name)) {
2708 SvREFCNT_dec_NN(char_name);
2709 /* diag_listed_as: Unknown charname '%s' */
2710 *error_msg = Perl_form(aTHX_ "Unknown charname ''");
2714 /* Autoload the charnames module */
2716 table = load_charnames(char_name, context, context_len, error_msg);
2717 if (table == NULL) {
2722 res = new_constant( NULL, 0, "charnames", char_name, NULL,
2723 context, context_len, error_msg);
2725 *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name));
2731 /* See if the charnames handler is the Perl core's, and if so, we can skip
2732 * the validation needed for a user-supplied one, as Perl's does its own
2734 cvp = hv_fetchs(table, "charnames", FALSE);
2735 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2736 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2738 const char * const name = HvNAME(stash);
2739 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2744 /* Here, it isn't Perl's charname handler. We can't rely on a
2745 * user-supplied handler to validate the input name. For non-ut8 input,
2746 * look to see that the first character is legal. Then loop through the
2747 * rest checking that each is a continuation */
2749 /* This code makes the reasonable assumption that the only Latin1-range
2750 * characters that begin a character name alias are alphabetic, otherwise
2751 * would have to create a isCHARNAME_BEGIN macro */
2754 if (! isALPHAU(*s)) {
2759 if (! isCHARNAME_CONT(*s)) {
2762 if (*s == ' ' && *(s-1) == ' ') {
2769 /* Similarly for utf8. For invariants can check directly; for other
2770 * Latin1, can calculate their code point and check; otherwise use an
2772 if (UTF8_IS_INVARIANT(*s)) {
2773 if (! isALPHAU(*s)) {
2777 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2778 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2784 if (! _invlist_contains_cp(PL_utf8_charname_begin,
2785 utf8_to_uvchr_buf((U8 *) s,
2795 if (UTF8_IS_INVARIANT(*s)) {
2796 if (! isCHARNAME_CONT(*s)) {
2799 if (*s == ' ' && *(s-1) == ' ') {
2804 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2805 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2812 if (! _invlist_contains_cp(PL_utf8_charname_continue,
2813 utf8_to_uvchr_buf((U8 *) s,
2823 if (*(s-1) == ' ') {
2824 /* diag_listed_as: charnames alias definitions may not contain
2825 trailing white-space; marked by <-- HERE in %s
2827 *error_msg = Perl_form(aTHX_
2828 "charnames alias definitions may not contain trailing "
2829 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2830 (int)(s - context + 1), context,
2831 (int)(e - s + 1), s + 1);
2835 if (SvUTF8(res)) { /* Don't accept malformed charname value */
2836 const U8* first_bad_char_loc;
2838 const char* const str = SvPV_const(res, len);
2839 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2840 &first_bad_char_loc)))
2842 _force_out_malformed_utf8_message(first_bad_char_loc,
2843 (U8 *) PL_parser->bufend,
2845 0 /* 0 means don't die */ );
2846 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2847 immediately after '%s' */
2848 *error_msg = Perl_form(aTHX_
2849 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2850 (int) context_len, context,
2851 (int) ((char *) first_bad_char_loc - str), str);
2860 /* The final %.*s makes sure that should the trailing NUL be missing
2861 * that this print won't run off the end of the string */
2862 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2864 *error_msg = Perl_form(aTHX_
2865 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2866 (int)(s - context + 1), context,
2867 (int)(e - s + 1), s + 1);
2872 /* diag_listed_as: charnames alias definitions may not contain a
2873 sequence of multiple spaces; marked by <-- HERE
2875 *error_msg = Perl_form(aTHX_
2876 "charnames alias definitions may not contain a sequence of "
2877 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2878 (int)(s - context + 1), context,
2879 (int)(e - s + 1), s + 1);
2886 Extracts the next constant part of a pattern, double-quoted string,
2887 or transliteration. This is terrifying code.
2889 For example, in parsing the double-quoted string "ab\x63$d", it would
2890 stop at the '$' and return an OP_CONST containing 'abc'.
2892 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2893 processing a pattern (PL_lex_inpat is true), a transliteration
2894 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2896 Returns a pointer to the character scanned up to. If this is
2897 advanced from the start pointer supplied (i.e. if anything was
2898 successfully parsed), will leave an OP_CONST for the substring scanned
2899 in pl_yylval. Caller must intuit reason for not parsing further
2900 by looking at the next characters herself.
2904 \N{FOO} => \N{U+hex_for_character_FOO}
2905 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2908 all other \-char, including \N and \N{ apart from \N{ABC}
2911 @ and $ where it appears to be a var, but not for $ as tail anchor
2915 In transliterations:
2916 characters are VERY literal, except for - not at the start or end
2917 of the string, which indicates a range. However some backslash sequences
2918 are recognized: \r, \n, and the like
2919 \007 \o{}, \x{}, \N{}
2920 If all elements in the transliteration are below 256,
2921 scan_const expands the range to the full set of intermediate
2922 characters. If the range is in utf8, the hyphen is replaced with
2923 a certain range mark which will be handled by pmtrans() in op.c.
2925 In double-quoted strings:
2927 all those recognized in transliterations
2928 deprecated backrefs: \1 (in substitution replacements)
2929 case and quoting: \U \Q \E
2932 scan_const does *not* construct ops to handle interpolated strings.
2933 It stops processing as soon as it finds an embedded $ or @ variable
2934 and leaves it to the caller to work out what's going on.
2936 embedded arrays (whether in pattern or not) could be:
2937 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2939 $ in double-quoted strings must be the symbol of an embedded scalar.
2941 $ in pattern could be $foo or could be tail anchor. Assumption:
2942 it's a tail anchor if $ is the last thing in the string, or if it's
2943 followed by one of "()| \r\n\t"
2945 \1 (backreferences) are turned into $1 in substitutions
2947 The structure of the code is
2948 while (there's a character to process) {
2949 handle transliteration ranges
2950 skip regexp comments /(?#comment)/ and codes /(?{code})/
2951 skip #-initiated comments in //x patterns
2952 check for embedded arrays
2953 check for embedded scalars
2955 deprecate \1 in substitution replacements
2956 handle string-changing backslashes \l \U \Q \E, etc.
2957 switch (what was escaped) {
2958 handle \- in a transliteration (becomes a literal -)
2959 if a pattern and not \N{, go treat as regular character
2960 handle \132 (octal characters)
2961 handle \x15 and \x{1234} (hex characters)
2962 handle \N{name} (named characters, also \N{3,5} in a pattern)
2963 handle \cV (control characters)
2964 handle printf-style backslashes (\f, \r, \n, etc)
2967 } (end if backslash)
2968 handle regular character
2969 } (end while character to read)
2974 S_scan_const(pTHX_ char *start)
2976 char *send = PL_bufend; /* end of the constant */
2977 SV *sv = newSV(send - start); /* sv for the constant. See note below
2979 char *s = start; /* start of the constant */
2980 char *d = SvPVX(sv); /* destination for copies */
2981 bool dorange = FALSE; /* are we in a translit range? */
2982 bool didrange = FALSE; /* did we just finish a range? */
2983 bool in_charclass = FALSE; /* within /[...]/ */
2984 bool s_is_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2985 UTF8? But, this can show as true
2986 when the source isn't utf8, as for
2987 example when it is entirely composed
2989 bool d_is_utf8 = FALSE; /* Output constant is UTF8 */
2990 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2991 number of characters found so far
2992 that will expand (into 2 bytes)
2993 should we have to convert to
2995 SV *res; /* result from charnames */
2996 STRLEN offset_to_max = 0; /* The offset in the output to where the range
2997 high-end character is temporarily placed */
2999 /* Does something require special handling in tr/// ? This avoids extra
3000 * work in a less likely case. As such, khw didn't feel it was worth
3001 * adding any branches to the more mainline code to handle this, which
3002 * means that this doesn't get set in some circumstances when things like
3003 * \x{100} get expanded out. As a result there needs to be extra testing
3004 * done in the tr code */
3005 bool has_above_latin1 = FALSE;
3007 /* Note on sizing: The scanned constant is placed into sv, which is
3008 * initialized by newSV() assuming one byte of output for every byte of
3009 * input. This routine expects newSV() to allocate an extra byte for a
3010 * trailing NUL, which this routine will append if it gets to the end of
3011 * the input. There may be more bytes of input than output (eg., \N{LATIN
3012 * CAPITAL LETTER A}), or more output than input if the constant ends up
3013 * recoded to utf8, but each time a construct is found that might increase
3014 * the needed size, SvGROW() is called. Its size parameter each time is
3015 * based on the best guess estimate at the time, namely the length used so
3016 * far, plus the length the current construct will occupy, plus room for
3017 * the trailing NUL, plus one byte for every input byte still unscanned */
3019 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3022 int backslash_N = 0; /* ? was the character from \N{} */
3023 int non_portable_endpoint = 0; /* ? In a range is an endpoint
3024 platform-specific like \x65 */
3027 PERL_ARGS_ASSERT_SCAN_CONST;
3029 assert(PL_lex_inwhat != OP_TRANSR);
3031 /* Protect sv from errors and fatal warnings. */
3032 ENTER_with_name("scan_const");
3035 /* A bunch of code in the loop below assumes that if s[n] exists and is not
3036 * NUL, then s[n+1] exists. This assertion makes sure that assumption is
3038 assert(*send == '\0');
3041 || dorange /* Handle tr/// range at right edge of input */
3044 /* get transliterations out of the way (they're most literal) */
3045 if (PL_lex_inwhat == OP_TRANS) {
3047 /* But there isn't any special handling necessary unless there is a
3048 * range, so for most cases we just drop down and handle the value
3049 * as any other. There are two exceptions.
3051 * 1. A hyphen indicates that we are actually going to have a
3052 * range. In this case, skip the '-', set a flag, then drop
3053 * down to handle what should be the end range value.
3054 * 2. After we've handled that value, the next time through, that
3055 * flag is set and we fix up the range.
3057 * Ranges entirely within Latin1 are expanded out entirely, in
3058 * order to make the transliteration a simple table look-up.
3059 * Ranges that extend above Latin1 have to be done differently, so
3060 * there is no advantage to expanding them here, so they are
3061 * stored here as Min, RANGE_INDICATOR, Max. 'RANGE_INDICATOR' is
3062 * a byte that can't occur in legal UTF-8, and hence can signify a
3063 * hyphen without any possible ambiguity. On EBCDIC machines, if
3064 * the range is expressed as Unicode, the Latin1 portion is
3065 * expanded out even if the range extends above Latin1. This is
3066 * because each code point in it has to be processed here
3067 * individually to get its native translation */
3071 /* Here, we don't think we're in a range. If the new character
3072 * is not a hyphen; or if it is a hyphen, but it's too close to
3073 * either edge to indicate a range, or if we haven't output any
3074 * characters yet then it's a regular character. */
3075 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv))
3078 /* A regular character. Process like any other, but first
3079 * clear any flags */
3083 non_portable_endpoint = 0;
3086 /* The tests here for being above Latin1 and similar ones
3087 * in the following 'else' suffice to find all such
3088 * occurences in the constant, except those added by a
3089 * backslash escape sequence, like \x{100}. Mostly, those
3090 * set 'has_above_latin1' as appropriate */
3091 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3092 has_above_latin1 = TRUE;
3095 /* Drops down to generic code to process current byte */
3097 else { /* Is a '-' in the context where it means a range */
3098 if (didrange) { /* Something like y/A-C-Z// */
3099 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3105 s++; /* Skip past the hyphen */
3107 /* d now points to where the end-range character will be
3108 * placed. Drop down to get that character. We'll finish
3109 * processing the range the next time through the loop */
3111 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3112 has_above_latin1 = TRUE;
3115 /* Drops down to generic code to process current byte */
3117 } /* End of not a range */
3119 /* Here we have parsed a range. Now must handle it. At this
3121 * 'sv' is a SV* that contains the output string we are
3122 * constructing. The final two characters in that string
3123 * are the range start and range end, in order.
3124 * 'd' points to just beyond the range end in the 'sv' string,
3125 * where we would next place something
3130 IV range_max; /* last character in range */
3132 Size_t offset_to_min = 0;
3135 bool convert_unicode;
3136 IV real_range_max = 0;
3138 /* Get the code point values of the range ends. */
3139 max_ptr = (d_is_utf8) ? (char *) utf8_hop( (U8*) d, -1) : d - 1;
3140 offset_to_max = max_ptr - SvPVX_const(sv);
3142 /* We know the utf8 is valid, because we just constructed
3143 * it ourselves in previous loop iterations */
3144 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3145 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3146 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3148 /* This compensates for not all code setting
3149 * 'has_above_latin1', so that we don't skip stuff that
3150 * should be executed */
3151 if (range_max > 255) {
3152 has_above_latin1 = TRUE;
3156 min_ptr = max_ptr - 1;
3157 range_min = * (U8*) min_ptr;
3158 range_max = * (U8*) max_ptr;
3161 /* If the range is just a single code point, like tr/a-a/.../,
3162 * that code point is already in the output, twice. We can
3163 * just back up over the second instance and avoid all the rest
3164 * of the work. But if it is a variant character, it's been
3165 * counted twice, so decrement. (This unlikely scenario is
3166 * special cased, like the one for a range of 2 code points
3167 * below, only because the main-line code below needs a range
3168 * of 3 or more to work without special casing. Might as well
3169 * get it out of the way now.) */
3170 if (UNLIKELY(range_max == range_min)) {
3172 if (! d_is_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3173 utf8_variant_count--;
3179 /* On EBCDIC platforms, we may have to deal with portable
3180 * ranges. These happen if at least one range endpoint is a
3181 * Unicode value (\N{...}), or if the range is a subset of
3182 * [A-Z] or [a-z], and both ends are literal characters,
3183 * like 'A', and not like \x{C1} */
3185 cBOOL(backslash_N) /* \N{} forces Unicode,
3186 hence portable range */
3187 || ( ! non_portable_endpoint
3188 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3189 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3190 if (convert_unicode) {
3192 /* Special handling is needed for these portable ranges.
3193 * They are defined to be in Unicode terms, which includes
3194 * all the Unicode code points between the end points.
3195 * Convert to Unicode to get the Unicode range. Later we
3196 * will convert each code point in the range back to
3198 range_min = NATIVE_TO_UNI(range_min);
3199 range_max = NATIVE_TO_UNI(range_max);
3203 if (range_min > range_max) {
3205 if (convert_unicode) {
3206 /* Need to convert back to native for meaningful
3207 * messages for this platform */
3208 range_min = UNI_TO_NATIVE(range_min);
3209 range_max = UNI_TO_NATIVE(range_max);
3212 /* Use the characters themselves for the error message if
3213 * ASCII printables; otherwise some visible representation
3215 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3217 "Invalid range \"%c-%c\" in transliteration operator",
3218 (char)range_min, (char)range_max);
3221 else if (convert_unicode) {
3222 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3224 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3225 UVXf "}\" in transliteration operator",
3226 range_min, range_max);
3230 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3232 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3233 " in transliteration operator",
3234 range_min, range_max);
3238 /* If the range is exactly two code points long, they are
3239 * already both in the output */
3240 if (UNLIKELY(range_min + 1 == range_max)) {
3244 /* Here the range contains at least 3 code points */
3248 /* If everything in the transliteration is below 256, we
3249 * can avoid special handling later. A translation table
3250 * for each of those bytes is created by op.c. So we
3251 * expand out all ranges to their constituent code points.
3252 * But if we've encountered something above 255, the
3253 * expanding won't help, so skip doing that. But if it's
3254 * EBCDIC, we may have to look at each character below 256
3255 * if we have to convert to/from Unicode values */
3256 if ( has_above_latin1
3258 && (range_min > 255 || ! convert_unicode)
3261 const STRLEN off = d - SvPVX(sv);
3262 const STRLEN extra = 1 + (send - s) + 1;
3265 /* Move the high character one byte to the right; then
3266 * insert between it and the range begin, an illegal
3267 * byte which serves to indicate this is a range (using
3268 * a '-' would be ambiguous). */
3270 if (off + extra > SvLEN(sv)) {
3271 d = off + SvGROW(sv, off + extra);
3272 max_ptr = d - off + offset_to_max;
3276 while (e-- > max_ptr) {
3279 *(e + 1) = (char) RANGE_INDICATOR;
3283 /* Here, we're going to expand out the range. For EBCDIC
3284 * the range can extend above 255 (not so in ASCII), so
3285 * for EBCDIC, split it into the parts above and below
3288 if (range_max > 255) {
3289 real_range_max = range_max;
3295 /* Here we need to expand out the string to contain each
3296 * character in the range. Grow the output to handle this.
3297 * For non-UTF8, we need a byte for each code point in the
3298 * range, minus the three that we've already allocated for: the
3299 * hyphen, the min, and the max. For UTF-8, we need this
3300 * plus an extra byte for each code point that occupies two
3301 * bytes (is variant) when in UTF-8 (except we've already
3302 * allocated for the end points, including if they are
3303 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3304 * platforms, it's easy to calculate a precise number. To
3305 * start, we count the variants in the range, which we need
3306 * elsewhere in this function anyway. (For the case where it
3307 * isn't easy to calculate, 'extras' has been initialized to 0,
3308 * and the calculation is done in a loop further down.) */
3310 if (convert_unicode)
3313 /* This is executed unconditionally on ASCII, and for
3314 * Unicode ranges on EBCDIC. Under these conditions, all
3315 * code points above a certain value are variant; and none
3316 * under that value are. We just need to find out how much
3317 * of the range is above that value. We don't count the
3318 * end points here, as they will already have been counted
3319 * as they were parsed. */
3320 if (range_min >= UTF_CONTINUATION_MARK) {
3322 /* The whole range is made up of variants */
3323 extras = (range_max - 1) - (range_min + 1) + 1;
3325 else if (range_max >= UTF_CONTINUATION_MARK) {
3327 /* Only the higher portion of the range is variants */
3328 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3331 utf8_variant_count += extras;
3334 /* The base growth is the number of code points in the range,
3335 * not including the endpoints, which have already been sized
3336 * for (and output). We don't subtract for the hyphen, as it
3337 * has been parsed but not output, and the SvGROW below is
3338 * based only on what's been output plus what's left to parse.
3340 grow = (range_max - 1) - (range_min + 1) + 1;
3344 /* In some cases in EBCDIC, we haven't yet calculated a
3345 * precise amount needed for the UTF-8 variants. Just
3346 * assume the worst case, that everything will expand by a
3348 if (! convert_unicode) {
3354 /* Otherwise we know exactly how many variants there
3355 * are in the range. */
3360 /* Grow, but position the output to overwrite the range min end
3361 * point, because in some cases we overwrite that */
3362 SvCUR_set(sv, d - SvPVX_const(sv));
3363 offset_to_min = min_ptr - SvPVX_const(sv);
3365 /* See Note on sizing above. */
3366 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3369 + 1 /* Trailing NUL */ );
3371 /* Now, we can expand out the range. */
3373 if (convert_unicode) {
3376 /* Recall that the min and max are now in Unicode terms, so
3377 * we have to convert each character to its native
3380 for (i = range_min; i <= range_max; i++) {
3381 append_utf8_from_native_byte(
3382 LATIN1_TO_NATIVE((U8) i),
3387 for (i = range_min; i <= range_max; i++) {
3388 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3394 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3396 /* Here, no conversions are necessary, which means that the
3397 * first character in the range is already in 'd' and
3398 * valid, so we can skip overwriting it */
3402 for (i = range_min + 1; i <= range_max; i++) {
3403 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3409 assert(range_min + 1 <= range_max);
3410 for (i = range_min + 1; i < range_max; i++) {
3412 /* In this case on EBCDIC, we haven't calculated
3413 * the variants. Do it here, as we go along */
3414 if (! UVCHR_IS_INVARIANT(i)) {
3415 utf8_variant_count++;
3421 /* The range_max is done outside the loop so as to
3422 * avoid having to special case not incrementing
3423 * 'utf8_variant_count' on EBCDIC (it's already been
3424 * counted when originally parsed) */
3425 *d++ = (char) range_max;
3430 /* If the original range extended above 255, add in that
3432 if (real_range_max) {
3433 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3434 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3435 if (real_range_max > 0x100) {
3436 if (real_range_max > 0x101) {
3437 *d++ = (char) RANGE_INDICATOR;
3439 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3445 /* mark the range as done, and continue */
3449 non_portable_endpoint = 0;
3453 } /* End of is a range */
3454 } /* End of transliteration. Joins main code after these else's */
3455 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3458 while (s1 >= start && *s1-- == '\\')
3461 in_charclass = TRUE;
3463 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3466 while (s1 >= start && *s1-- == '\\')
3469 in_charclass = FALSE;
3471 /* skip for regexp comments /(?#comment)/, except for the last
3472 * char, which will be done separately. Stop on (?{..}) and
3474 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3477 PERL_UINT_FAST8_T len = UTF8SKIP(s);
3479 while (s + len < send && *s != ')') {
3480 Copy(s, d, len, U8);
3483 len = UTF8_SAFE_SKIP(s, send);
3486 else while (s+1 < send && *s != ')') {
3490 else if (!PL_lex_casemods
3491 && ( s[2] == '{' /* This should match regcomp.c */
3492 || (s[2] == '?' && s[3] == '{')))
3497 /* likewise skip #-initiated comments in //x patterns */
3501 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3503 while (s < send && *s != '\n')
3506 /* no further processing of single-quoted regex */
3507 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3508 goto default_action;
3510 /* check for embedded arrays
3511 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3513 else if (*s == '@' && s[1]) {
3515 ? isIDFIRST_utf8_safe(s+1, send)
3516 : isWORDCHAR_A(s[1]))
3520 if (memCHRs(":'{$", s[1]))
3522 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3523 break; /* in regexp, neither @+ nor @- are interpolated */
3525 /* check for embedded scalars. only stop if we're sure it's a
3527 else if (*s == '$') {
3528 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3530 if (s + 1 < send && !memCHRs("()| \r\n\t", s[1])) {
3532 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3533 "Possible unintended interpolation of $\\ in regex");
3535 break; /* in regexp, $ might be tail anchor */
3539 /* End of else if chain - OP_TRANS rejoin rest */
3541 if (UNLIKELY(s >= send)) {
3547 if (*s == '\\' && s+1 < send) {
3548 char* e; /* Can be used for ending '}', etc. */
3552 /* warn on \1 - \9 in substitution replacements, but note that \11
3553 * is an octal; and \19 is \1 followed by '9' */
3554 if (PL_lex_inwhat == OP_SUBST
3560 /* diag_listed_as: \%d better written as $%d */
3561 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3566 /* string-change backslash escapes */
3567 if (PL_lex_inwhat != OP_TRANS && *s && memCHRs("lLuUEQF", *s)) {
3571 /* In a pattern, process \N, but skip any other backslash escapes.
3572 * This is because we don't want to translate an escape sequence
3573 * into a meta symbol and have the regex compiler use the meta
3574 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3575 * in spite of this, we do have to process \N here while the proper
3576 * charnames handler is in scope. See bugs #56444 and #62056.
3578 * There is a complication because \N in a pattern may also stand
3579 * for 'match a non-nl', and not mean a charname, in which case its
3580 * processing should be deferred to the regex compiler. To be a
3581 * charname it must be followed immediately by a '{', and not look
3582 * like \N followed by a curly quantifier, i.e., not something like
3583 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3585 else if (PL_lex_inpat
3588 || regcurly(s + 1)))
3591 goto default_action;
3597 if ((isALPHANUMERIC(*s)))
3598 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3599 "Unrecognized escape \\%c passed through",
3601 /* default action is to copy the quoted character */
3602 goto default_action;
3605 /* eg. \132 indicates the octal constant 0132 */
3606 case '0': case '1': case '2': case '3':
3607 case '4': case '5': case '6': case '7':
3609 I32 flags = PERL_SCAN_SILENT_ILLDIGIT
3610 | PERL_SCAN_NOTIFY_ILLDIGIT;
3612 uv = grok_oct(s, &len, &flags, NULL);
3614 if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
3616 && isDIGIT(*s) /* like \08, \178 */
3617 && ckWARN(WARN_MISC))
3619 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
3620 form_alien_digit_msg(8, len, s, send, UTF, FALSE));
3623 goto NUM_ESCAPE_INSERT;
3625 /* eg. \o{24} indicates the octal constant \024 */
3630 if (! grok_bslash_o(&s, send,
3633 FALSE, /* Not strict */
3634 FALSE, /* No illegal cp's */
3638 uv = 0; /* drop through to ensure range ends are set */
3640 goto NUM_ESCAPE_INSERT;
3643 /* eg. \x24 indicates the hex constant 0x24 */
3648 if (! grok_bslash_x(&s, send,
3651 FALSE, /* Not strict */
3652 FALSE, /* No illegal cp's */
3656 uv = 0; /* drop through to ensure range ends are set */
3661 /* Insert oct or hex escaped character. */
3663 /* Here uv is the ordinal of the next character being added */
3664 if (UVCHR_IS_INVARIANT(uv)) {
3668 if (!d_is_utf8 && uv > 255) {
3670 /* Here, 'uv' won't fit unless we convert to UTF-8.
3671 * If we've only seen invariants so far, all we have to
3672 * do is turn on the flag */
3673 if (utf8_variant_count == 0) {
3677 SvCUR_set(sv, d - SvPVX_const(sv));
3681 sv_utf8_upgrade_flags_grow(
3683 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3685 /* Since we're having to grow here,
3686 * make sure we have enough room for
3687 * this escape and a NUL, so the
3688 * code immediately below won't have
3689 * to actually grow again */
3691 + (STRLEN)(send - s) + 1);
3692 d = SvPVX(sv) + SvCUR(sv);
3695 has_above_latin1 = TRUE;
3701 utf8_variant_count++;
3704 /* Usually, there will already be enough room in 'sv'
3705 * since such escapes are likely longer than any UTF-8
3706 * sequence they can end up as. This isn't the case on
3707 * EBCDIC where \x{40000000} contains 12 bytes, and the
3708 * UTF-8 for it contains 14. And, we have to allow for
3709 * a trailing NUL. It probably can't happen on ASCII
3710 * platforms, but be safe. See Note on sizing above. */
3711 const STRLEN needed = d - SvPVX(sv)
3715 if (UNLIKELY(needed > SvLEN(sv))) {
3716 SvCUR_set(sv, d - SvPVX_const(sv));
3717 d = SvCUR(sv) + SvGROW(sv, needed);
3720 d = (char*) uvchr_to_utf8_flags((U8*)d, uv,
3721 (ckWARN(WARN_PORTABLE))
3722 ? UNICODE_WARN_PERL_EXTENDED
3727 non_portable_endpoint++;
3732 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3733 * named character, like \N{LATIN SMALL LETTER A}, or a named
3734 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3735 * GRAVE} (except y/// can't handle the latter, croaking). For
3736 * convenience all three forms are referred to as "named
3737 * characters" below.
3739 * For patterns, \N also can mean to match a non-newline. Code
3740 * before this 'switch' statement should already have handled
3741 * this situation, and hence this code only has to deal with
3742 * the named character cases.
3744 * For non-patterns, the named characters are converted to
3745 * their string equivalents. In patterns, named characters are
3746 * not converted to their ultimate forms for the same reasons
3747 * that other escapes aren't (mainly that the ultimate
3748 * character could be considered a meta-symbol by the regex
3749 * compiler). Instead, they are converted to the \N{U+...}
3750 * form to get the value from the charnames that is in effect
3751 * right now, while preserving the fact that it was a named
3752 * character, so that the regex compiler knows this.
3754 * The structure of this section of code (besides checking for
3755 * errors and upgrading to utf8) is:
3756 * If the named character is of the form \N{U+...}, pass it
3757 * through if a pattern; otherwise convert the code point
3759 * Otherwise must be some \N{NAME}: convert to
3760 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3762 * Transliteration is an exception. The conversion to utf8 is
3763 * only done if the code point requires it to be representable.
3765 * Here, 's' points to the 'N'; the test below is guaranteed to
3766 * succeed if we are being called on a pattern, as we already
3767 * know from a test above that the next character is a '{'. A
3768 * non-pattern \N must mean 'named character', which requires
3772 yyerror("Missing braces on \\N{}");
3778 /* If there is no matching '}', it is an error. */
3779 if (! (e = (char *) memchr(s, '}', send - s))) {
3780 if (! PL_lex_inpat) {
3781 yyerror("Missing right brace on \\N{}");
3783 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3785 yyquit(); /* Have exhausted the input. */
3788 /* Here it looks like a named character */
3790 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3791 s += 2; /* Skip to next char after the 'U+' */
3794 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3795 /* Check the syntax. */
3798 if (!isXDIGIT(*s)) {
3801 "Invalid hexadecimal number in \\N{U+...}"
3810 else if ((*s == '.' || *s == '_')
3816 /* Pass everything through unchanged.
3817 * +1 is for the '}' */
3818 Copy(orig_s, d, e - orig_s + 1, char);
3819 d += e - orig_s + 1;
3821 else { /* Not a pattern: convert the hex to string */
3822 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3823 | PERL_SCAN_SILENT_ILLDIGIT
3824 | PERL_SCAN_SILENT_OVERFLOW
3825 | PERL_SCAN_DISALLOW_PREFIX;
3828 uv = grok_hex(s, &len, &flags, NULL);
3829 if (len == 0 || (len != (STRLEN)(e - s)))
3832 if ( uv > MAX_LEGAL_CP
3833 || (flags & PERL_SCAN_GREATER_THAN_UV_MAX))
3835 yyerror(form_cp_too_large_msg(16, s, len, 0));
3836 uv = 0; /* drop through to ensure range ends are
3840 /* For non-tr///, if the destination is not in utf8,
3841 * unconditionally recode it to be so. This is
3842 * because \N{} implies Unicode semantics, and scalars
3843 * have to be in utf8 to guarantee those semantics.
3844 * tr/// doesn't care about Unicode rules, so no need
3845 * there to upgrade to UTF-8 for small enough code
3847 if (! d_is_utf8 && ( uv > 0xFF
3848 || PL_lex_inwhat != OP_TRANS))
3850 /* See Note on sizing above. */
3851 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3853 SvCUR_set(sv, d - SvPVX_const(sv));
3857 if (utf8_variant_count == 0) {
3859 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3862 sv_utf8_upgrade_flags_grow(
3864 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3866 d = SvPVX(sv) + SvCUR(sv);
3870 has_above_latin1 = TRUE;
3873 /* Add the (Unicode) code point to the output. */
3874 if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3875 *d++ = (char) LATIN1_TO_NATIVE(uv);
3878 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv,
3879 (ckWARN(WARN_PORTABLE))
3880 ? UNICODE_WARN_PERL_EXTENDED
3885 else /* Here is \N{NAME} but not \N{U+...}. */
3886 if (! (res = get_and_check_backslash_N_name_wrapper(s, e)))
3887 { /* Failed. We should die eventually, but for now use a NUL
3891 else { /* Successfully evaluated the name */
3893 const char *str = SvPV_const(res, len);
3896 if (! len) { /* The name resolved to an empty string */
3897 const char empty_N[] = "\\N{_}";
3898 Copy(empty_N, d, sizeof(empty_N) - 1, char);
3899 d += sizeof(empty_N) - 1;
3902 /* In order to not lose information for the regex
3903 * compiler, pass the result in the specially made
3904 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3905 * the code points in hex of each character
3906 * returned by charnames */
3908 const char *str_end = str + len;
3909 const STRLEN off = d - SvPVX_const(sv);
3911 if (! SvUTF8(res)) {
3912 /* For the non-UTF-8 case, we can determine the
3913 * exact length needed without having to parse
3914 * through the string. Each character takes up
3915 * 2 hex digits plus either a trailing dot or
3917 const char initial_text[] = "\\N{U+";
3918 const STRLEN initial_len = sizeof(initial_text)
3920 d = off + SvGROW(sv, off
3923 /* +1 for trailing NUL */
3926 + (STRLEN)(send - e));
3927 Copy(initial_text, d, initial_len, char);
3929 while (str < str_end) {
3932 my_snprintf(hex_string,
3936 /* The regex compiler is
3937 * expecting Unicode, not
3939 NATIVE_TO_LATIN1(*str));
3940 PERL_MY_SNPRINTF_POST_GUARD(len,
3941 sizeof(hex_string));
3942 Copy(hex_string, d, 3, char);
3946 d--; /* Below, we will overwrite the final
3947 dot with a right brace */
3950 STRLEN char_length; /* cur char's byte length */
3952 /* and the number of bytes after this is
3953 * translated into hex digits */
3954 STRLEN output_length;
3956 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3957 * for max('U+', '.'); and 1 for NUL */
3958 char hex_string[2 * UTF8_MAXBYTES + 5];
3960 /* Get the first character of the result. */
3961 U32 uv = utf8n_to_uvchr((U8 *) str,
3965 /* Convert first code point to Unicode hex,
3966 * including the boiler plate before it. */
3968 my_snprintf(hex_string, sizeof(hex_string),
3970 (unsigned int) NATIVE_TO_UNI(uv));
3972 /* Make sure there is enough space to hold it */
3973 d = off + SvGROW(sv, off
3975 + (STRLEN)(send - e)
3976 + 2); /* '}' + NUL */
3978 Copy(hex_string, d, output_length, char);
3981 /* For each subsequent character, append dot and
3982 * its Unicode code point in hex */
3983 while ((str += char_length) < str_end) {
3984 const STRLEN off = d - SvPVX_const(sv);
3985 U32 uv = utf8n_to_uvchr((U8 *) str,
3990 my_snprintf(hex_string,
3993 (unsigned int) NATIVE_TO_UNI(uv));
3995 d = off + SvGROW(sv, off
3997 + (STRLEN)(send - e)
3998 + 2); /* '}' + NUL */
3999 Copy(hex_string, d, output_length, char);
4004 *d++ = '}'; /* Done. Add the trailing brace */
4007 else { /* Here, not in a pattern. Convert the name to a
4010 if (PL_lex_inwhat == OP_TRANS) {
4011 str = SvPV_const(res, len);
4012 if (len > ((SvUTF8(res))
4016 yyerror(Perl_form(aTHX_
4017 "%.*s must not be a named sequence"
4018 " in transliteration operator",
4019 /* +1 to include the "}" */
4020 (int) (e + 1 - start), start));
4022 goto end_backslash_N;
4025 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
4026 has_above_latin1 = TRUE;
4030 else if (! SvUTF8(res)) {
4031 /* Make sure \N{} return is UTF-8. This is because
4032 * \N{} implies Unicode semantics, and scalars have
4033 * to be in utf8 to guarantee those semantics; but
4034 * not needed in tr/// */
4035 sv_utf8_upgrade_flags(res, 0);
4036 str = SvPV_const(res, len);
4039 /* Upgrade destination to be utf8 if this new
4041 if (! d_is_utf8 && SvUTF8(res)) {
4042 /* See Note on sizing above. */
4043 const STRLEN extra = len + (send - s) + 1;
4045 SvCUR_set(sv, d - SvPVX_const(sv));
4049 if (utf8_variant_count == 0) {
4051 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
4054 sv_utf8_upgrade_flags_grow(sv,
4055 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4057 d = SvPVX(sv) + SvCUR(sv);
4060 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
4062 /* See Note on sizing above. (NOTE: SvCUR() is not
4063 * set correctly here). */
4064 const STRLEN extra = len + (send - e) + 1;
4065 const STRLEN off = d - SvPVX_const(sv);
4066 d = off + SvGROW(sv, off + extra);
4068 Copy(str, d, len, char);
4074 } /* End \N{NAME} */
4078 backslash_N++; /* \N{} is defined to be Unicode */
4080 s = e + 1; /* Point to just after the '}' */
4083 /* \c is a control character */
4087 const char * message;
4089 if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) {
4091 yyquit(); /* Have always immediately croaked on
4097 yyerror("Missing control char name in \\c");
4098 yyquit(); /* Are at end of input, no sense continuing */
4101 non_portable_endpoint++;
4105 /* printf-style backslashes, formfeeds, newlines, etc */
4131 } /* end if (backslash) */
4134 /* Just copy the input to the output, though we may have to convert
4137 * If the input has the same representation in UTF-8 as not, it will be
4138 * a single byte, and we don't care about UTF8ness; just copy the byte */
4139 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4142 else if (! s_is_utf8 && ! d_is_utf8) {
4143 /* If neither source nor output is UTF-8, is also a single byte,
4144 * just copy it; but this byte counts should we later have to
4145 * convert to UTF-8 */
4147 utf8_variant_count++;
4149 else if (s_is_utf8 && d_is_utf8) { /* Both UTF-8, can just copy */
4150 const STRLEN len = UTF8SKIP(s);
4152 /* We expect the source to have already been checked for
4154 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4156 Copy(s, d, len, U8);
4160 else if (s_is_utf8) { /* UTF8ness matters: convert output to utf8 */
4161 STRLEN need = send - s + 1; /* See Note on sizing above. */
4163 SvCUR_set(sv, d - SvPVX_const(sv));
4167 if (utf8_variant_count == 0) {
4169 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4172 sv_utf8_upgrade_flags_grow(sv,
4173 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4175 d = SvPVX(sv) + SvCUR(sv);
4178 goto default_action; /* Redo, having upgraded so both are UTF-8 */
4180 else { /* UTF8ness matters: convert this non-UTF8 source char to
4181 UTF-8 for output. It will occupy 2 bytes, but don't include
4182 the input byte since we haven't incremented 's' yet. See
4183 Note on sizing above. */
4184 const STRLEN off = d - SvPVX(sv);
4185 const STRLEN extra = 2 + (send - s - 1) + 1;
4186 if (off + extra > SvLEN(sv)) {
4187 d = off + SvGROW(sv, off + extra);
4189 *d++ = UTF8_EIGHT_BIT_HI(*s);
4190 *d++ = UTF8_EIGHT_BIT_LO(*s);
4193 } /* while loop to process each character */
4196 const STRLEN off = d - SvPVX(sv);
4198 /* See if room for the terminating NUL */
4199 if (UNLIKELY(off >= SvLEN(sv))) {
4203 if (off > SvLEN(sv))
4205 Perl_croak(aTHX_ "panic: constant overflowed allocated space,"
4206 " %" UVuf " >= %" UVuf, (UV)off, (UV)SvLEN(sv));
4208 /* Whew! Here we don't have room for the terminating NUL, but
4209 * everything else so far has fit. It's not too late to grow
4210 * to fit the NUL and continue on. But it is a bug, as the code
4211 * above was supposed to have made room for this, so under
4212 * DEBUGGING builds, we panic anyway. */
4213 d = off + SvGROW(sv, off + 1);
4217 /* terminate the string and set up the sv */
4219 SvCUR_set(sv, d - SvPVX_const(sv));
4226 /* shrink the sv if we allocated more than we used */
4227 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4228 SvPV_shrink_to_cur(sv);
4231 /* return the substring (via pl_yylval) only if we parsed anything */
4234 for (; s2 < s; s2++) {
4236 COPLINE_INC_WITH_HERELINES;
4238 SvREFCNT_inc_simple_void_NN(sv);
4239 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4240 && ! PL_parser->lex_re_reparsing)
4242 const char *const key = PL_lex_inpat ? "qr" : "q";
4243 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4247 if (PL_lex_inwhat == OP_TRANS) {
4250 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4253 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4261 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4262 type, typelen, NULL);
4264 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4266 LEAVE_with_name("scan_const");
4271 * Returns TRUE if there's more to the expression (e.g., a subscript),
4274 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4276 * ->[ and ->{ return TRUE
4277 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4278 * { and [ outside a pattern are always subscripts, so return TRUE
4279 * if we're outside a pattern and it's not { or [, then return FALSE
4280 * if we're in a pattern and the first char is a {
4281 * {4,5} (any digits around the comma) returns FALSE
4282 * if we're in a pattern and the first char is a [
4284 * [SOMETHING] has a funky algorithm to decide whether it's a
4285 * character class or not. It has to deal with things like
4286 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4287 * anything else returns TRUE
4290 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4293 S_intuit_more(pTHX_ char *s, char *e)
4295 PERL_ARGS_ASSERT_INTUIT_MORE;
4297 if (PL_lex_brackets)
4299 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4301 if (*s == '-' && s[1] == '>'
4302 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4303 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4304 ||(s[2] == '@' && memCHRs("*[{",s[3])) ))
4306 if (*s != '{' && *s != '[')
4308 PL_parser->sub_no_recover = TRUE;
4312 /* In a pattern, so maybe we have {n,m}. */
4320 /* On the other hand, maybe we have a character class */
4323 if (*s == ']' || *s == '^')
4326 /* this is terrifying, and it works */
4329 const char * const send = (char *) memchr(s, ']', e - s);
4330 unsigned char un_char, last_un_char;
4331 char tmpbuf[sizeof PL_tokenbuf * 4];
4333 if (!send) /* has to be an expression */
4335 weight = 2; /* let's weigh the evidence */
4339 else if (isDIGIT(*s)) {
4341 if (isDIGIT(s[1]) && s[2] == ']')
4347 Zero(seen,256,char);
4349 for (; s < send; s++) {
4350 last_un_char = un_char;
4351 un_char = (unsigned char)*s;
4356 weight -= seen[un_char] * 10;
4357 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4359 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4360 len = (int)strlen(tmpbuf);
4361 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4362 UTF ? SVf_UTF8 : 0, SVt_PV))
4369 && memCHRs("[#!%*<>()-=",s[1]))
4371 if (/*{*/ memCHRs("])} =",s[2]))
4380 if (memCHRs("wds]",s[1]))
4382 else if (seen[(U8)'\''] || seen[(U8)'"'])
4384 else if (memCHRs("rnftbxcav",s[1]))
4386 else if (isDIGIT(s[1])) {
4388 while (s[1] && isDIGIT(s[1]))
4398 if (memCHRs("aA01! ",last_un_char))
4400 if (memCHRs("zZ79~",s[1]))
4402 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4403 weight -= 5; /* cope with negative subscript */
4406 if (!isWORDCHAR(last_un_char)
4407 && !(last_un_char == '$' || last_un_char == '@'
4408 || last_un_char == '&')
4409 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4413 if (keyword(d, s - d, 0))
4416 if (un_char == last_un_char + 1)
4418 weight -= seen[un_char];
4423 if (weight >= 0) /* probably a character class */
4433 * Does all the checking to disambiguate
4435 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4436 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4438 * First argument is the stuff after the first token, e.g. "bar".
4440 * Not a method if foo is a filehandle.
4441 * Not a method if foo is a subroutine prototyped to take a filehandle.
4442 * Not a method if it's really "Foo $bar"
4443 * Method if it's "foo $bar"
4444 * Not a method if it's really "print foo $bar"
4445 * Method if it's really "foo package::" (interpreted as package->foo)
4446 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4447 * Not a method if bar is a filehandle or package, but is quoted with
4452 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4454 char *s = start + (*start == '$');
4455 char tmpbuf[sizeof PL_tokenbuf];
4458 /* Mustn't actually add anything to a symbol table.
4459 But also don't want to "initialise" any placeholder
4460 constants that might already be there into full
4461 blown PVGVs with attached PVCV. */
4463 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4465 PERL_ARGS_ASSERT_INTUIT_METHOD;
4467 if (!FEATURE_INDIRECT_IS_ENABLED)
4470 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4472 if (cv && SvPOK(cv)) {
4473 const char *proto = CvPROTO(cv);
4475 while (*proto && (isSPACE(*proto) || *proto == ';'))
4482 if (*start == '$') {
4483 SSize_t start_off = start - SvPVX(PL_linestr);
4484 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4485 || isUPPER(*PL_tokenbuf))
4487 /* this could be $# */
4490 PL_bufptr = SvPVX(PL_linestr) + start_off;
4492 return *s == '(' ? FUNCMETH : METHOD;
4495 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4496 /* start is the beginning of the possible filehandle/object,
4497 * and s is the end of it
4498 * tmpbuf is a copy of it (but with single quotes as double colons)
4501 if (!keyword(tmpbuf, len, 0)) {
4502 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4507 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4508 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4510 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4511 && (!isGV(indirgv) || GvCVu(indirgv)))
4513 /* filehandle or package name makes it a method */
4514 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4516 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4517 return 0; /* no assumptions -- "=>" quotes bareword */
4519 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4520 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4521 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4523 force_next(BAREWORD);
4525 return *s == '(' ? FUNCMETH : METHOD;
4531 /* Encoded script support. filter_add() effectively inserts a
4532 * 'pre-processing' function into the current source input stream.
4533 * Note that the filter function only applies to the current source file
4534 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4536 * The datasv parameter (which may be NULL) can be used to pass
4537 * private data to this instance of the filter. The filter function
4538 * can recover the SV using the FILTER_DATA macro and use it to
4539 * store private buffers and state information.
4541 * The supplied datasv parameter is upgraded to a PVIO type
4542 * and the IoDIRP/IoANY field is used to store the function pointer,
4543 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4544 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4545 * private use must be set using malloc'd pointers.
4549 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4557 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4558 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4560 if (!PL_rsfp_filters)
4561 PL_rsfp_filters = newAV();
4564 SvUPGRADE(datasv, SVt_PVIO);
4565 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4566 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4567 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4568 FPTR2DPTR(void *, IoANY(datasv)),
4569 SvPV_nolen(datasv)));
4570 av_unshift(PL_rsfp_filters, 1);
4571 av_store(PL_rsfp_filters, 0, datasv) ;
4573 !PL_parser->filtered
4574 && PL_parser->lex_flags & LEX_EVALBYTES
4575 && PL_bufptr < PL_bufend
4577 const char *s = PL_bufptr;
4578 while (s < PL_bufend) {
4580 SV *linestr = PL_parser->linestr;
4581 char *buf = SvPVX(linestr);
4582 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4583 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4584 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4585 STRLEN const linestart_pos = PL_parser->linestart - buf;
4586 STRLEN const last_uni_pos =
4587 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4588 STRLEN const last_lop_pos =
4589 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4590 av_push(PL_rsfp_filters, linestr);
4591 PL_parser->linestr =
4592 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4593 buf = SvPVX(PL_parser->linestr);
4594 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4595 PL_parser->bufptr = buf + bufptr_pos;
4596 PL_parser->oldbufptr = buf + oldbufptr_pos;
4597 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4598 PL_parser->linestart = buf + linestart_pos;
4599 if (PL_parser->last_uni)
4600 PL_parser->last_uni = buf + last_uni_pos;
4601 if (PL_parser->last_lop)
4602 PL_parser->last_lop = buf + last_lop_pos;
4603 SvLEN_set(linestr, SvCUR(linestr));
4604 SvCUR_set(linestr, s - SvPVX(linestr));
4605 PL_parser->filtered = 1;
4615 /* Delete most recently added instance of this filter function. */
4617 Perl_filter_del(pTHX_ filter_t funcp)
4621 PERL_ARGS_ASSERT_FILTER_DEL;
4624 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4625 FPTR2DPTR(void*, funcp)));
4627 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4629 /* if filter is on top of stack (usual case) just pop it off */
4630 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4631 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4632 sv_free(av_pop(PL_rsfp_filters));
4636 /* we need to search for the correct entry and clear it */
4637 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4641 /* Invoke the idxth filter function for the current rsfp. */
4642 /* maxlen 0 = read one text line */
4644 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4649 /* This API is bad. It should have been using unsigned int for maxlen.
4650 Not sure if we want to change the API, but if not we should sanity
4651 check the value here. */
4652 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4654 PERL_ARGS_ASSERT_FILTER_READ;
4656 if (!PL_parser || !PL_rsfp_filters)
4658 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4659 /* Provide a default input filter to make life easy. */
4660 /* Note that we append to the line. This is handy. */
4661 DEBUG_P(PerlIO_printf(Perl_debug_log,
4662 "filter_read %d: from rsfp\n", idx));
4663 if (correct_length) {
4666 const int old_len = SvCUR(buf_sv);
4668 /* ensure buf_sv is large enough */
4669 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4670 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4671 correct_length)) <= 0) {
4672 if (PerlIO_error(PL_rsfp))
4673 return -1; /* error */
4675 return 0 ; /* end of file */
4677 SvCUR_set(buf_sv, old_len + len) ;
4678 SvPVX(buf_sv)[old_len + len] = '\0';
4681 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4682 if (PerlIO_error(PL_rsfp))
4683 return -1; /* error */
4685 return 0 ; /* end of file */
4688 return SvCUR(buf_sv);
4690 /* Skip this filter slot if filter has been deleted */
4691 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4692 DEBUG_P(PerlIO_printf(Perl_debug_log,
4693 "filter_read %d: skipped (filter deleted)\n",
4695 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4697 if (SvTYPE(datasv) != SVt_PVIO) {
4698 if (correct_length) {
4700 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4701 if (!remainder) return 0; /* eof */
4702 if (correct_length > remainder) correct_length = remainder;
4703 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4704 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4707 const char *s = SvEND(datasv);
4708 const char *send = SvPVX(datasv) + SvLEN(datasv);
4716 if (s == send) return 0; /* eof */
4717 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4718 SvCUR_set(datasv, s-SvPVX(datasv));
4720 return SvCUR(buf_sv);
4722 /* Get function pointer hidden within datasv */
4723 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4724 DEBUG_P(PerlIO_printf(Perl_debug_log,
4725 "filter_read %d: via function %p (%s)\n",
4726 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4727 /* Call function. The function is expected to */
4728 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4729 /* Return: <0:error, =0:eof, >0:not eof */
4731 save_scalar(PL_errgv);
4732 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4738 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4740 PERL_ARGS_ASSERT_FILTER_GETS;
4742 #ifdef PERL_CR_FILTER
4743 if (!PL_rsfp_filters) {
4744 filter_add(S_cr_textfilter,NULL);
4747 if (PL_rsfp_filters) {
4749 SvCUR_set(sv, 0); /* start with empty line */
4750 if (FILTER_READ(0, sv, 0) > 0)
4751 return ( SvPVX(sv) ) ;
4756 return (sv_gets(sv, PL_rsfp, append));
4760 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4764 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4766 if (memEQs(pkgname, len, "__PACKAGE__"))
4770 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4771 && (gv = gv_fetchpvn_flags(pkgname,
4773 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4775 return GvHV(gv); /* Foo:: */
4778 /* use constant CLASS => 'MyClass' */
4779 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4780 if (gv && GvCV(gv)) {
4781 SV * const sv = cv_const_sv(GvCV(gv));
4783 return gv_stashsv(sv, 0);
4786 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4791 S_tokenize_use(pTHX_ int is_use, char *s) {
4792 PERL_ARGS_ASSERT_TOKENIZE_USE;
4794 if (PL_expect != XSTATE)
4795 /* diag_listed_as: "use" not allowed in expression */
4796 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4797 is_use ? "use" : "no"));
4800 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4801 s = force_version(s, TRUE);
4802 if (*s == ';' || *s == '}'
4803 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4804 NEXTVAL_NEXTTOKE.opval = NULL;
4805 force_next(BAREWORD);
4807 else if (*s == 'v') {
4808 s = force_word(s,BAREWORD,FALSE,TRUE);
4809 s = force_version(s, FALSE);
4813 s = force_word(s,BAREWORD,FALSE,TRUE);
4814 s = force_version(s, FALSE);
4816 pl_yylval.ival = is_use;
4820 static const char* const exp_name[] =
4821 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4822 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4823 "SIGVAR", "TERMORDORDOR"
4827 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4829 S_word_takes_any_delimiter(char *p, STRLEN len)
4831 return (len == 1 && memCHRs("msyq", p[0]))
4833 && ((p[0] == 't' && p[1] == 'r')
4834 || (p[0] == 'q' && memCHRs("qwxr", p[1]))));
4838 S_check_scalar_slice(pTHX_ char *s)
4841 while (SPACE_OR_TAB(*s)) s++;
4842 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4848 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4849 || (*s && memCHRs(" \t$#+-'\"", *s)))
4851 s += UTF ? UTF8SKIP(s) : 1;
4853 if (*s == '}' || *s == ']')
4854 pl_yylval.ival = OPpSLICEWARNING;
4857 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4859 S_lex_token_boundary(pTHX)
4861 PL_oldoldbufptr = PL_oldbufptr;
4862 PL_oldbufptr = PL_bufptr;
4865 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4867 S_vcs_conflict_marker(pTHX_ char *s)
4869 lex_token_boundary();
4871 yyerror("Version control conflict marker");
4872 while (s < PL_bufend && *s != '\n')
4878 yyl_sigvar(pTHX_ char *s)
4880 /* we expect the sigil and optional var name part of a
4881 * signature element here. Since a '$' is not necessarily
4882 * followed by a var name, handle it specially here; the general
4883 * yylex code would otherwise try to interpret whatever follows
4884 * as a var; e.g. ($, ...) would be seen as the var '$,'
4891 PL_bufptr = s; /* for error reporting */
4896 /* spot stuff that looks like an prototype */
4897 if (memCHRs("$:@%&*;\\[]", *s)) {
4898 yyerror("Illegal character following sigil in a subroutine signature");
4901 /* '$#' is banned, while '$ # comment' isn't */
4903 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
4907 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
4908 char *dest = PL_tokenbuf + 1;
4909 /* read var name, including sigil, into PL_tokenbuf */
4910 PL_tokenbuf[0] = sigil;
4911 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
4912 0, cBOOL(UTF), FALSE, FALSE);
4914 assert(PL_tokenbuf[1]); /* we have a variable name */
4922 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
4923 * as the ASSIGNOP, and exclude other tokens that start with =
4925 if (*s == '=' && (!s[1] || memCHRs("=~>", s[1]) == 0)) {
4926 /* save now to report with the same context as we did when
4927 * all ASSIGNOPS were accepted */
4931 NEXTVAL_NEXTTOKE.ival = 0;
4932 force_next(ASSIGNOP);
4935 else if (*s == ',' || *s == ')') {
4936 PL_expect = XOPERATOR;
4939 /* make sure the context shows the unexpected character and
4940 * hopefully a bit more */
4942 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
4944 PL_bufptr = s; /* for error reporting */
4945 yyerror("Illegal operator following parameter in a subroutine signature");
4949 NEXTVAL_NEXTTOKE.ival = sigil;
4950 force_next('p'); /* force a signature pending identifier */
4957 case ',': /* handle ($a,,$b) */
4962 yyerror("A signature parameter must start with '$', '@' or '%'");
4963 /* very crude error recovery: skip to likely next signature
4965 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
4974 yyl_dollar(pTHX_ char *s)
4978 if (PL_expect == XPOSTDEREF) {
4981 POSTDEREF(DOLSHARP);
4987 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
4988 || memCHRs("{$:+-@", s[2])))
4990 PL_tokenbuf[0] = '@';
4991 s = scan_ident(s + 1, PL_tokenbuf + 1,
4992 sizeof PL_tokenbuf - 1, FALSE);
4993 if (PL_expect == XOPERATOR) {
4995 if (PL_bufptr > s) {
4997 PL_bufptr = PL_oldbufptr;
4999 no_op("Array length", d);
5001 if (!PL_tokenbuf[1])
5003 PL_expect = XOPERATOR;
5004 force_ident_maybe_lex('#');
5008 PL_tokenbuf[0] = '$';
5009 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5010 if (PL_expect == XOPERATOR) {
5012 if (PL_bufptr > s) {
5014 PL_bufptr = PL_oldbufptr;
5018 if (!PL_tokenbuf[1]) {
5020 yyerror("Final $ should be \\$ or $name");
5025 const char tmp = *s;
5026 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5029 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5030 && intuit_more(s, PL_bufend)) {
5032 PL_tokenbuf[0] = '@';
5033 if (ckWARN(WARN_SYNTAX)) {
5036 while ( t < PL_bufend ) {
5038 do { t += UTF ? UTF8SKIP(t) : 1; } while (t < PL_bufend && isSPACE(*t));
5039 /* consumed one or more space chars */
5040 } else if (*t == '$' || *t == '@') {
5041 /* could be more than one '$' like $$ref or @$ref */
5042 do { t++; } while (t < PL_bufend && *t == '$');
5044 /* could be an abigail style identifier like $ foo */
5045 while (t < PL_bufend && *t == ' ') t++;
5047 /* strip off the name of the var */
5048 while (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
5049 t += UTF ? UTF8SKIP(t) : 1;
5050 /* consumed a varname */
5051 } else if (isDIGIT(*t)) {
5052 /* deal with hex constants like 0x11 */
5053 if (t[0] == '0' && t[1] == 'x') {
5055 while (t < PL_bufend && isXDIGIT(*t)) t++;
5057 /* deal with decimal/octal constants like 1 and 0123 */
5058 do { t++; } while (isDIGIT(*t));
5059 if (t<PL_bufend && *t == '.') {
5060 do { t++; } while (isDIGIT(*t));
5063 /* consumed a number */
5065 /* not a var nor a space nor a number */
5069 if (t < PL_bufend && *t++ == ',') {
5070 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
5071 while (t < PL_bufend && *t != ']')
5073 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5074 "Multidimensional syntax %" UTF8f " not supported",
5075 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
5079 else if (*s == '{') {
5081 PL_tokenbuf[0] = '%';
5082 if ( strEQ(PL_tokenbuf+1, "SIG")
5083 && ckWARN(WARN_SYNTAX)
5084 && (t = (char *) memchr(s, '}', PL_bufend - s))
5085 && (t = (char *) memchr(t, '=', PL_bufend - t)))
5087 char tmpbuf[sizeof PL_tokenbuf];
5090 } while (isSPACE(*t));
5091 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
5093 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5098 && get_cvn_flags(tmpbuf, len, UTF
5102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5103 "You need to quote \"%" UTF8f "\"",
5104 UTF8fARG(UTF, len, tmpbuf));
5111 PL_expect = XOPERATOR;
5112 if ((PL_lex_state == LEX_NORMAL || PL_lex_brackets) && isSPACE((char)tmp)) {
5113 const bool islop = (PL_last_lop == PL_oldoldbufptr);
5114 if (!islop || PL_last_lop_op == OP_GREPSTART)
5115 PL_expect = XOPERATOR;
5116 else if (memCHRs("$@\"'`q", *s))
5117 PL_expect = XTERM; /* e.g. print $fh "foo" */
5118 else if ( memCHRs("&*<%", *s)
5119 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
5121 PL_expect = XTERM; /* e.g. print $fh &sub */
5123 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5124 char tmpbuf[sizeof PL_tokenbuf];
5127 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5128 if ((t2 = keyword(tmpbuf, len, 0))) {
5129 /* binary operators exclude handle interpretations */
5141 PL_expect = XTERM; /* e.g. print $fh length() */
5146 PL_expect = XTERM; /* e.g. print $fh subr() */
5149 else if (isDIGIT(*s))
5150 PL_expect = XTERM; /* e.g. print $fh 3 */
5151 else if (*s == '.' && isDIGIT(s[1]))
5152 PL_expect = XTERM; /* e.g. print $fh .3 */
5153 else if ((*s == '?' || *s == '-' || *s == '+')
5154 && !isSPACE(s[1]) && s[1] != '=')
5155 PL_expect = XTERM; /* e.g. print $fh -1 */
5156 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5158 PL_expect = XTERM; /* e.g. print $fh /.../
5159 XXX except DORDOR operator
5161 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5163 PL_expect = XTERM; /* print $fh <<"EOF" */
5166 force_ident_maybe_lex('$');
5171 yyl_sub(pTHX_ char *s, const int key)
5173 char * const tmpbuf = PL_tokenbuf + 1;
5174 bool have_name, have_proto;
5176 SV *format_name = NULL;
5177 bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
5179 SSize_t off = s-SvPVX(PL_linestr);
5182 s = skipspace(s); /* can move PL_linestr */
5184 d = SvPVX(PL_linestr)+off;
5186 SAVEBOOL(PL_parser->sig_seen);
5187 PL_parser->sig_seen = FALSE;
5189 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
5191 || (*s == ':' && s[1] == ':'))
5194 PL_expect = XATTRBLOCK;
5195 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
5197 if (key == KEY_format)
5198 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
5200 if (memchr(tmpbuf, ':', len) || key != KEY_sub
5202 PL_tokenbuf, len + 1, 0
5204 sv_setpvn(PL_subname, tmpbuf, len);
5206 sv_setsv(PL_subname,PL_curstname);
5207 sv_catpvs(PL_subname,"::");
5208 sv_catpvn(PL_subname,tmpbuf,len);
5210 if (SvUTF8(PL_linestr))
5211 SvUTF8_on(PL_subname);
5217 if (key == KEY_my || key == KEY_our || key==KEY_state) {
5219 /* diag_listed_as: Missing name in "%s sub" */
5221 "Missing name in \"%s\"", PL_bufptr);
5223 PL_expect = XATTRTERM;
5224 sv_setpvs(PL_subname,"?");
5228 if (key == KEY_format) {
5230 NEXTVAL_NEXTTOKE.opval
5231 = newSVOP(OP_CONST,0, format_name);
5232 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
5233 force_next(BAREWORD);
5238 /* Look for a prototype */
5239 if (*s == '(' && !is_sigsub) {
5240 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
5242 Perl_croak(aTHX_ "Prototype not terminated");
5243 COPLINE_SET_FROM_MULTI_END;
5244 (void)validate_proto(PL_subname, PL_lex_stuff,
5245 ckWARN(WARN_ILLEGALPROTO), 0);
5253 if ( !(*s == ':' && s[1] != ':')
5254 && (*s != '{' && *s != '(') && key != KEY_format)
5256 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
5257 key == KEY_DESTROY || key == KEY_BEGIN ||
5258 key == KEY_UNITCHECK || key == KEY_CHECK ||
5259 key == KEY_INIT || key == KEY_END ||
5260 key == KEY_my || key == KEY_state ||
5263 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5264 else if (*s != ';' && *s != '}')
5265 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
5269 NEXTVAL_NEXTTOKE.opval =
5270 newSVOP(OP_CONST, 0, PL_lex_stuff);
5271 PL_lex_stuff = NULL;
5276 sv_setpvs(PL_subname, "__ANON__");
5278 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5284 force_ident_maybe_lex('&');
5292 yyl_interpcasemod(pTHX_ char *s)
5295 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
5297 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
5298 PL_bufptr, PL_bufend, *PL_bufptr);
5301 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
5303 if (PL_lex_casemods) {
5304 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
5305 PL_lex_casestack[PL_lex_casemods] = '\0';
5307 if (PL_bufptr != PL_bufend
5308 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
5309 || oldmod == 'F')) {
5311 PL_lex_state = LEX_INTERPCONCAT;
5313 PL_lex_allbrackets--;
5316 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
5317 /* Got an unpaired \E */
5318 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5319 "Useless use of \\E");
5321 if (PL_bufptr != PL_bufend)
5323 PL_lex_state = LEX_INTERPCONCAT;
5328 PerlIO_printf(Perl_debug_log, "### Saw case modifier\n");
5331 if (s[1] == '\\' && s[2] == 'E') {
5333 PL_lex_state = LEX_INTERPCONCAT;
5338 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
5339 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
5341 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
5343 if ((*s == 'L' || *s == 'U' || *s == 'F')
5344 && (strpbrk(PL_lex_casestack, "LUF")))
5346 PL_lex_casestack[--PL_lex_casemods] = '\0';
5347 PL_lex_allbrackets--;
5350 if (PL_lex_casemods > 10)
5351 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
5352 PL_lex_casestack[PL_lex_casemods++] = *s;
5353 PL_lex_casestack[PL_lex_casemods] = '\0';
5354 PL_lex_state = LEX_INTERPCONCAT;
5355 NEXTVAL_NEXTTOKE.ival = 0;
5356 force_next((2<<24)|'(');
5358 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
5360 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
5362 NEXTVAL_NEXTTOKE.ival = OP_LC;
5364 NEXTVAL_NEXTTOKE.ival = OP_UC;
5366 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
5368 NEXTVAL_NEXTTOKE.ival = OP_FC;
5370 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
5374 if (PL_lex_starts) {
5377 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5378 if (PL_lex_casemods == 1 && PL_lex_inpat)
5381 AopNOASSIGN(OP_CONCAT);
5389 yyl_secondclass_keyword(pTHX_ char *s, STRLEN len, int key, I32 *orig_keyword,
5390 GV **pgv, GV ***pgvp)
5392 GV *ogv = NULL; /* override (winner) */
5393 GV *hgv = NULL; /* hidden (loser) */
5396 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5398 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5399 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
5401 && (cv = GvCVu(gv)))
5403 if (GvIMPORTED_CV(gv))
5405 else if (! CvMETHOD(cv))
5409 && (*pgvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf, len, FALSE))
5411 && (isGV_with_GP(gv)
5412 ? GvCVu(gv) && GvIMPORTED_CV(gv)
5413 : SvPCS_IMPORTED(gv)
5414 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
5424 *orig_keyword = key;
5425 return 0; /* overridden by import or by GLOBAL */
5427 else if (gv && !*pgvp
5428 && -key==KEY_lock /* XXX generalizable kludge */
5431 return 0; /* any sub overrides "weak" keyword */
5433 else { /* no override */
5435 if (key == KEY_dump) {
5436 Perl_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
5440 if (hgv && key != KEY_x) /* never ambiguous */
5441 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5442 "Ambiguous call resolved as CORE::%s(), "
5443 "qualify as such or use &",
5450 yyl_qw(pTHX_ char *s, STRLEN len)
5454 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
5456 missingterm(NULL, 0);
5458 COPLINE_SET_FROM_MULTI_END;
5459 PL_expect = XOPERATOR;
5460 if (SvCUR(PL_lex_stuff)) {
5461 int warned_comma = !ckWARN(WARN_QW);
5462 int warned_comment = warned_comma;
5463 char *d = SvPV_force(PL_lex_stuff, len);
5465 for (; isSPACE(*d) && len; --len, ++d)
5470 if (!warned_comma || !warned_comment) {
5471 for (; !isSPACE(*d) && len; --len, ++d) {
5472 if (!warned_comma && *d == ',') {
5473 Perl_warner(aTHX_ packWARN(WARN_QW),
5474 "Possible attempt to separate words with commas");
5477 else if (!warned_comment && *d == '#') {
5478 Perl_warner(aTHX_ packWARN(WARN_QW),
5479 "Possible attempt to put comments in qw() list");
5485 for (; !isSPACE(*d) && len; --len, ++d)
5488 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
5489 words = op_append_elem(OP_LIST, words,
5490 newSVOP(OP_CONST, 0, tokeq(sv)));
5495 words = newNULLLIST();
5496 SvREFCNT_dec_NN(PL_lex_stuff);
5497 PL_lex_stuff = NULL;
5498 PL_expect = XOPERATOR;
5499 pl_yylval.opval = sawparens(words);
5504 yyl_hyphen(pTHX_ char *s)
5506 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5514 while (s < PL_bufend && SPACE_OR_TAB(*s))
5517 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5518 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5519 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5520 OPERATOR('-'); /* unary minus */
5523 case 'r': ftst = OP_FTEREAD; break;
5524 case 'w': ftst = OP_FTEWRITE; break;
5525 case 'x': ftst = OP_FTEEXEC; break;
5526 case 'o': ftst = OP_FTEOWNED; break;
5527 case 'R': ftst = OP_FTRREAD; break;
5528 case 'W': ftst = OP_FTRWRITE; break;
5529 case 'X': ftst = OP_FTREXEC; break;
5530 case 'O': ftst = OP_FTROWNED; break;
5531 case 'e': ftst = OP_FTIS; break;
5532 case 'z': ftst = OP_FTZERO; break;
5533 case 's': ftst = OP_FTSIZE; break;
5534 case 'f': ftst = OP_FTFILE; break;
5535 case 'd': ftst = OP_FTDIR; break;
5536 case 'l': ftst = OP_FTLINK; break;
5537 case 'p': ftst = OP_FTPIPE; break;
5538 case 'S': ftst = OP_FTSOCK; break;
5539 case 'u': ftst = OP_FTSUID; break;
5540 case 'g': ftst = OP_FTSGID; break;
5541 case 'k': ftst = OP_FTSVTX; break;
5542 case 'b': ftst = OP_FTBLK; break;
5543 case 'c': ftst = OP_FTCHR; break;
5544 case 't': ftst = OP_FTTTY; break;
5545 case 'T': ftst = OP_FTTEXT; break;
5546 case 'B': ftst = OP_FTBINARY; break;
5547 case 'M': case 'A': case 'C':
5548 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5550 case 'M': ftst = OP_FTMTIME; break;
5551 case 'A': ftst = OP_FTATIME; break;
5552 case 'C': ftst = OP_FTCTIME; break;
5560 PL_last_uni = PL_oldbufptr;
5561 PL_last_lop_op = (OPCODE)ftst;
5563 PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)tmp);
5568 /* Assume it was a minus followed by a one-letter named
5569 * subroutine call (or a -bareword), then. */
5571 PerlIO_printf(Perl_debug_log,
5572 "### '-%c' looked like a file test but was not\n",
5579 const char tmp = *s++;
5582 if (PL_expect == XOPERATOR)
5587 else if (*s == '>') {
5590 if (((*s == '$' || *s == '&') && s[1] == '*')
5591 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5592 ||((*s == '@' || *s == '%') && memCHRs("*[{", s[1]))
5593 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5596 PL_expect = XPOSTDEREF;
5599 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5600 s = force_word(s,METHOD,FALSE,TRUE);
5608 if (PL_expect == XOPERATOR) {
5610 && !PL_lex_allbrackets
5611 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5619 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5621 OPERATOR('-'); /* unary minus */
5627 yyl_plus(pTHX_ char *s)
5629 const char tmp = *s++;
5632 if (PL_expect == XOPERATOR)
5637 if (PL_expect == XOPERATOR) {
5639 && !PL_lex_allbrackets
5640 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5648 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5655 yyl_star(pTHX_ char *s)
5657 if (PL_expect == XPOSTDEREF)
5660 if (PL_expect != XOPERATOR) {
5661 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5662 PL_expect = XOPERATOR;
5663 force_ident(PL_tokenbuf, '*');
5672 if (*s == '=' && !PL_lex_allbrackets
5673 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5682 && !PL_lex_allbrackets
5683 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5693 yyl_percent(pTHX_ char *s)
5695 if (PL_expect == XOPERATOR) {
5697 && !PL_lex_allbrackets
5698 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5705 else if (PL_expect == XPOSTDEREF)
5708 PL_tokenbuf[0] = '%';
5709 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5711 if (!PL_tokenbuf[1]) {
5714 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5715 && intuit_more(s, PL_bufend)) {
5717 PL_tokenbuf[0] = '@';
5719 PL_expect = XOPERATOR;
5720 force_ident_maybe_lex('%');
5725 yyl_caret(pTHX_ char *s)
5728 const bool bof = cBOOL(FEATURE_BITWISE_IS_ENABLED);
5729 if (bof && s[1] == '.')
5731 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5732 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5738 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5742 yyl_colon(pTHX_ char *s)
5746 switch (PL_expect) {
5748 if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
5750 PL_bufptr = s; /* update in case we back off */
5753 "Use of := for an empty attribute list is not allowed");
5760 PL_expect = XTERMBLOCK;
5762 /* NB: as well as parsing normal attributes, we also end up
5763 * here if there is something looking like attributes
5764 * following a signature (which is illegal, but used to be
5765 * legal in 5.20..5.26). If the latter, we still parse the
5766 * attributes so that error messages(s) are less confusing,
5767 * but ignore them (parser->sig_seen).
5771 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5772 bool sig = PL_parser->sig_seen;
5776 char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5777 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5778 if (tmp < 0) tmp = -tmp;
5793 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5795 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5800 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5802 COPLINE_SET_FROM_MULTI_END;
5805 sv_catsv(sv, PL_lex_stuff);
5806 attrs = op_append_elem(OP_LIST, attrs,
5807 newSVOP(OP_CONST, 0, sv));
5808 SvREFCNT_dec_NN(PL_lex_stuff);
5809 PL_lex_stuff = NULL;
5812 /* NOTE: any CV attrs applied here need to be part of
5813 the CVf_BUILTIN_ATTRS define in cv.h! */
5814 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
5817 CvLVALUE_on(PL_compcv);
5819 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
5822 CvMETHOD_on(PL_compcv);
5824 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const")) {
5827 Perl_ck_warner_d(aTHX_
5828 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5829 ":const is experimental"
5831 CvANONCONST_on(PL_compcv);
5832 if (!CvANON(PL_compcv))
5833 yyerror(":const is not permitted on named "
5837 /* After we've set the flags, it could be argued that
5838 we don't need to do the attributes.pm-based setting
5839 process, and shouldn't bother appending recognized
5840 flags. To experiment with that, uncomment the
5841 following "else". (Note that's already been
5842 uncommented. That keeps the above-applied built-in
5843 attributes from being intercepted (and possibly
5844 rejected) by a package's attribute routines, but is
5845 justified by the performance win for the common case
5846 of applying only built-in attributes.) */
5848 attrs = op_append_elem(OP_LIST, attrs,
5849 newSVOP(OP_CONST, 0,
5853 if (*s == ':' && s[1] != ':')
5856 break; /* require real whitespace or :'s */
5857 /* XXX losing whitespace on sequential attributes here */
5862 && !(PL_expect == XOPERATOR
5863 ? (*s == '=' || *s == ')')
5864 : (*s == '{' || *s == '(')))
5866 const char q = ((*s == '\'') ? '"' : '\'');
5867 /* If here for an expression, and parsed no attrs, back off. */
5868 if (PL_expect == XOPERATOR && !attrs) {
5872 /* MUST advance bufptr here to avoid bogus "at end of line"
5873 context messages from yyerror().
5876 yyerror( (const char *)
5878 ? Perl_form(aTHX_ "Invalid separator character "
5879 "%c%c%c in attribute list", q, *s, q)
5880 : "Unterminated attribute list" ) );
5887 if (PL_parser->sig_seen) {
5888 /* see comment about about sig_seen and parser error
5892 Perl_croak(aTHX_ "Subroutine attributes must come "
5893 "before the signature");
5896 NEXTVAL_NEXTTOKE.opval = attrs;
5902 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5907 PL_lex_allbrackets--;
5912 yyl_subproto(pTHX_ char *s, CV *cv)
5914 STRLEN protolen = CvPROTOLEN(cv);
5915 const char *proto = CvPROTO(cv);
5918 proto = S_strip_spaces(aTHX_ proto, &protolen);
5921 if ((optional = *proto == ';')) {
5924 } while (*proto == ';');
5930 *proto == '$' || *proto == '_'
5931 || *proto == '*' || *proto == '+'
5936 *proto == '\\' && proto[1] && proto[2] == '\0'
5939 UNIPROTO(UNIOPSUB,optional);
5942 if (*proto == '\\' && proto[1] == '[') {
5943 const char *p = proto + 2;
5944 while(*p && *p != ']')
5946 if(*p == ']' && !p[1])
5947 UNIPROTO(UNIOPSUB,optional);
5950 if (*proto == '&' && *s == '{') {
5952 sv_setpvs(PL_subname, "__ANON__");
5954 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5955 if (!PL_lex_allbrackets
5956 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
5958 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
5967 yyl_leftcurly(pTHX_ char *s, const U8 formbrack)
5970 if (PL_lex_brackets > 100) {
5971 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5974 switch (PL_expect) {
5977 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5978 PL_lex_allbrackets++;
5979 OPERATOR(HASHBRACK);
5981 while (s < PL_bufend && SPACE_OR_TAB(*s))
5984 PL_tokenbuf[0] = '\0';
5985 if (d < PL_bufend && *d == '-') {
5986 PL_tokenbuf[0] = '-';
5988 while (d < PL_bufend && SPACE_OR_TAB(*d))
5991 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
5993 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5995 while (d < PL_bufend && SPACE_OR_TAB(*d))
5998 const char minus = (PL_tokenbuf[0] == '-');
5999 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6007 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6008 PL_lex_allbrackets++;
6013 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6014 PL_lex_allbrackets++;
6018 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6019 PL_lex_allbrackets++;
6024 if (PL_oldoldbufptr == PL_last_lop)
6025 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6027 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6028 PL_lex_allbrackets++;
6031 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6033 /* This hack is to get the ${} in the message. */
6035 yyerror("syntax error");
6038 OPERATOR(HASHBRACK);
6040 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6041 /* ${...} or @{...} etc., but not print {...}
6042 * Skip the disambiguation and treat this as a block.
6044 goto block_expectation;
6046 /* This hack serves to disambiguate a pair of curlies
6047 * as being a block or an anon hash. Normally, expectation
6048 * determines that, but in cases where we're not in a
6049 * position to expect anything in particular (like inside
6050 * eval"") we have to resolve the ambiguity. This code
6051 * covers the case where the first term in the curlies is a
6052 * quoted string. Most other cases need to be explicitly
6053 * disambiguated by prepending a "+" before the opening
6054 * curly in order to force resolution as an anon hash.
6056 * XXX should probably propagate the outer expectation
6057 * into eval"" to rely less on this hack, but that could
6058 * potentially break current behavior of eval"".
6062 if (*s == '\'' || *s == '"' || *s == '`') {
6063 /* common case: get past first string, handling escapes */
6064 for (t++; t < PL_bufend && *t != *s;)
6069 else if (*s == 'q') {
6072 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6073 && !isWORDCHAR(*t))))
6075 /* skip q//-like construct */
6077 char open, close, term;
6080 while (t < PL_bufend && isSPACE(*t))
6082 /* check for q => */
6083 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6084 OPERATOR(HASHBRACK);
6088 if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
6092 for (t++; t < PL_bufend; t++) {
6093 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6095 else if (*t == open)
6099 for (t++; t < PL_bufend; t++) {
6100 if (*t == '\\' && t+1 < PL_bufend)
6102 else if (*t == close && --brackets <= 0)
6104 else if (*t == open)
6111 /* skip plain q word */
6112 while ( t < PL_bufend
6113 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6115 t += UTF ? UTF8SKIP(t) : 1;
6118 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6119 t += UTF ? UTF8SKIP(t) : 1;
6120 while ( t < PL_bufend
6121 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6123 t += UTF ? UTF8SKIP(t) : 1;
6126 while (t < PL_bufend && isSPACE(*t))
6128 /* if comma follows first term, call it an anon hash */
6129 /* XXX it could be a comma expression with loop modifiers */
6130 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6131 || (*t == '=' && t[1] == '>')))
6132 OPERATOR(HASHBRACK);
6133 if (PL_expect == XREF) {
6135 /* If there is an opening brace or 'sub:', treat it
6136 as a term to make ${{...}}{k} and &{sub:attr...}
6137 dwim. Otherwise, treat it as a statement, so
6138 map {no strict; ...} works.
6145 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6158 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6165 pl_yylval.ival = CopLINE(PL_curcop);
6166 PL_copline = NOLINE; /* invalidate current command line number */
6167 TOKEN(formbrack ? '=' : '{');
6171 yyl_rightcurly(pTHX_ char *s, const U8 formbrack)
6173 assert(s != PL_bufend);
6176 if (PL_lex_brackets <= 0)
6177 /* diag_listed_as: Unmatched right %s bracket */
6178 yyerror("Unmatched right curly bracket");
6180 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6182 PL_lex_allbrackets--;
6184 if (PL_lex_state == LEX_INTERPNORMAL) {
6185 if (PL_lex_brackets == 0) {
6186 if (PL_expect & XFAKEBRACK) {
6187 PL_expect &= XENUMMASK;
6188 PL_lex_state = LEX_INTERPEND;
6190 return yylex(); /* ignore fake brackets */
6192 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6193 && SvEVALED(PL_lex_repl))
6194 PL_lex_state = LEX_INTERPEND;
6195 else if (*s == '-' && s[1] == '>')
6196 PL_lex_state = LEX_INTERPENDMAYBE;
6197 else if (*s != '[' && *s != '{')
6198 PL_lex_state = LEX_INTERPEND;
6202 if (PL_expect & XFAKEBRACK) {
6203 PL_expect &= XENUMMASK;
6205 return yylex(); /* ignore fake brackets */
6208 force_next(formbrack ? '.' : '}');
6209 if (formbrack) LEAVE_with_name("lex_format");
6210 if (formbrack == 2) { /* means . where arguments were expected */
6219 yyl_ampersand(pTHX_ char *s)
6221 if (PL_expect == XPOSTDEREF)
6226 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6227 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6235 if (PL_expect == XOPERATOR) {
6238 if ( PL_bufptr == PL_linestart
6239 && ckWARN(WARN_SEMICOLON)
6240 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6242 CopLINE_dec(PL_curcop);
6243 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6244 CopLINE_inc(PL_curcop);
6247 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6249 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6250 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6256 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6261 PL_tokenbuf[0] = '&';
6262 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6263 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6266 force_ident_maybe_lex('&');
6274 yyl_verticalbar(pTHX_ char *s)
6281 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6282 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6291 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6294 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6295 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6300 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6304 yyl_bang(pTHX_ char *s)
6306 const char tmp = *s++;
6308 /* was this !=~ where !~ was meant?
6309 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6311 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6312 const char *t = s+1;
6314 while (t < PL_bufend && isSPACE(*t))
6317 if (*t == '/' || *t == '?'
6318 || ((*t == 'm' || *t == 's' || *t == 'y')
6319 && !isWORDCHAR(t[1]))
6320 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6321 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6322 "!=~ should be !~");
6325 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6341 yyl_snail(pTHX_ char *s)
6343 if (PL_expect == XPOSTDEREF)
6345 PL_tokenbuf[0] = '@';
6346 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6347 if (PL_expect == XOPERATOR) {
6349 if (PL_bufptr > s) {
6351 PL_bufptr = PL_oldbufptr;
6356 if (!PL_tokenbuf[1]) {
6359 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6361 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6362 && intuit_more(s, PL_bufend))
6365 PL_tokenbuf[0] = '%';
6367 /* Warn about @ where they meant $. */
6368 if (*s == '[' || *s == '{') {
6369 if (ckWARN(WARN_SYNTAX)) {
6370 S_check_scalar_slice(aTHX_ s);
6374 PL_expect = XOPERATOR;
6375 force_ident_maybe_lex('@');
6380 yyl_slash(pTHX_ char *s)
6382 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6383 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6384 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6389 else if (PL_expect == XOPERATOR) {
6391 if (*s == '=' && !PL_lex_allbrackets
6392 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6400 /* Disable warning on "study /blah/" */
6401 if ( PL_oldoldbufptr == PL_last_uni
6402 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6403 || memNE(PL_last_uni, "study", 5)
6404 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6407 s = scan_pat(s,OP_MATCH);
6408 TERM(sublex_start());
6413 yyl_leftsquare(pTHX_ char *s)
6417 if (PL_lex_brackets > 100)
6418 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6419 PL_lex_brackstack[PL_lex_brackets++] = 0;
6420 PL_lex_allbrackets++;
6426 yyl_rightsquare(pTHX_ char *s)
6428 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6431 if (PL_lex_brackets <= 0)
6432 /* diag_listed_as: Unmatched right %s bracket */
6433 yyerror("Unmatched right square bracket");
6436 PL_lex_allbrackets--;
6437 if (PL_lex_state == LEX_INTERPNORMAL) {
6438 if (PL_lex_brackets == 0) {
6439 if (*s == '-' && s[1] == '>')
6440 PL_lex_state = LEX_INTERPENDMAYBE;
6441 else if (*s != '[' && *s != '{')
6442 PL_lex_state = LEX_INTERPEND;
6449 yyl_tilde(pTHX_ char *s)
6452 if (s[1] == '~' && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) {
6453 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6456 Perl_ck_warner_d(aTHX_
6457 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
6458 "Smartmatch is experimental");
6462 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
6464 BCop(OP_SCOMPLEMENT);
6466 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
6470 yyl_leftparen(pTHX_ char *s)
6472 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6473 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6477 PL_lex_allbrackets++;
6482 yyl_rightparen(pTHX_ char *s)
6484 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6487 PL_lex_allbrackets--;
6495 yyl_leftpointy(pTHX_ char *s)
6499 if (PL_expect != XOPERATOR) {
6500 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6502 if (s[1] == '<' && s[2] != '>')
6503 s = scan_heredoc(s);
6505 s = scan_inputsymbol(s);
6506 PL_expect = XOPERATOR;
6507 TOKEN(sublex_start());
6514 if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6518 SHop(OP_LEFT_SHIFT);
6523 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6530 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6538 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6547 yyl_rightpointy(pTHX_ char *s)
6549 const char tmp = *s++;
6552 if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6556 SHop(OP_RIGHT_SHIFT);
6558 else if (tmp == '=') {
6559 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6567 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6576 yyl_sglquote(pTHX_ char *s)
6578 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6580 missingterm(NULL, 0);
6581 COPLINE_SET_FROM_MULTI_END;
6582 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6583 if (PL_expect == XOPERATOR) {
6586 pl_yylval.ival = OP_CONST;
6587 TERM(sublex_start());
6591 yyl_dblquote(pTHX_ char *s, STRLEN len)
6594 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6597 printbuf("### Saw string before %s\n", s);
6599 PerlIO_printf(Perl_debug_log,
6600 "### Saw unterminated string\n");
6602 if (PL_expect == XOPERATOR) {
6606 missingterm(NULL, 0);
6607 pl_yylval.ival = OP_CONST;
6608 /* FIXME. I think that this can be const if char *d is replaced by
6609 more localised variables. */
6610 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6611 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6612 pl_yylval.ival = OP_STRINGIFY;
6616 if (pl_yylval.ival == OP_CONST)
6617 COPLINE_SET_FROM_MULTI_END;
6618 TERM(sublex_start());
6622 yyl_backtick(pTHX_ char *s)
6624 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6627 printbuf("### Saw backtick string before %s\n", s);
6629 PerlIO_printf(Perl_debug_log,
6630 "### Saw unterminated backtick string\n");
6632 if (PL_expect == XOPERATOR)
6633 no_op("Backticks",s);
6635 missingterm(NULL, 0);
6636 pl_yylval.ival = OP_BACKTICK;
6637 TERM(sublex_start());
6641 yyl_backslash(pTHX_ char *s)
6643 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr && isDIGIT(*s))
6644 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6646 if (PL_expect == XOPERATOR)
6647 no_op("Backslash",s);
6652 yyl_data_handle(pTHX)
6654 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6657 GV *gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6660 gv_init(gv,stash,"DATA",4,0);
6664 GvIOp(gv) = newIO();
6665 IoIFP(GvIOp(gv)) = PL_rsfp;
6667 /* Mark this internal pseudo-handle as clean */
6668 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6669 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6670 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6672 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6674 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6675 /* if the script was opened in binmode, we need to revert
6676 * it to text mode for compatibility; but only iff it has CRs
6677 * XXX this is a questionable hack at best. */
6678 if (PL_bufend-PL_bufptr > 2
6679 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6682 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6683 loc = PerlIO_tell(PL_rsfp);
6684 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6686 if (PerlLIO_setmode(RSFP_FILENO, O_TEXT) != -1) {
6688 PerlIO_seek(PL_rsfp, loc, 0);
6693 #ifdef PERLIO_LAYERS
6696 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6703 PERL_STATIC_NO_RET void yyl_croak_unrecognised(pTHX_ char*)
6704 __attribute__noreturn__;
6706 PERL_STATIC_NO_RET void
6707 yyl_croak_unrecognised(pTHX_ char *s)
6709 SV *dsv = newSVpvs_flags("", SVs_TEMP);
6715 STRLEN skiplen = UTF8SKIP(s);
6716 STRLEN stravail = PL_bufend - s;
6717 c = sv_uni_display(dsv, newSVpvn_flags(s,
6718 skiplen > stravail ? stravail : skiplen,
6719 SVs_TEMP | SVf_UTF8),
6720 10, UNI_DISPLAY_ISPRINT);
6723 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
6726 if (s >= PL_linestart) {
6730 /* somehow (probably due to a parse failure), PL_linestart has advanced
6731 * pass PL_bufptr, get a reasonable beginning of line
6734 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
6737 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
6738 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
6739 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
6742 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
6743 UTF8fARG(UTF, (s - d), d),
6748 yyl_require(pTHX_ char *s, I32 orig_keyword)
6752 s = force_version(s, FALSE);
6754 else if (*s != 'v' || !isDIGIT(s[1])
6755 || (s = force_version(s, TRUE), *s == 'v'))
6757 *PL_tokenbuf = '\0';
6758 s = force_word(s,BAREWORD,TRUE,TRUE);
6759 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
6760 PL_tokenbuf + sizeof(PL_tokenbuf),
6763 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
6764 GV_ADD | (UTF ? SVf_UTF8 : 0));
6767 yyerror("<> at require-statement should be quotes");
6770 if (orig_keyword == KEY_require)
6775 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
6777 PL_last_uni = PL_oldbufptr;
6778 PL_last_lop_op = OP_REQUIRE;
6780 return REPORT( (int)REQUIRE );
6784 yyl_foreach(pTHX_ char *s)
6786 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6788 pl_yylval.ival = CopLINE(PL_curcop);
6790 if (PL_expect == XSTATE && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6792 SSize_t s_off = s - SvPVX(PL_linestr);
6795 if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "my") && isSPACE(p[2])) {
6798 else if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "our") && isSPACE(p[3])) {
6803 /* skip optional package name, as in "for my abc $x (..)" */
6804 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
6805 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6808 if (*p != '$' && *p != '\\')
6809 Perl_croak(aTHX_ "Missing $ on loop variable");
6811 /* The buffer may have been reallocated, update s */
6812 s = SvPVX(PL_linestr) + s_off;
6818 yyl_do(pTHX_ char *s, I32 orig_keyword)
6827 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6829 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
6830 && !keyword(PL_tokenbuf + 1, len, 0)) {
6831 SSize_t off = s-SvPVX(PL_linestr);
6833 s = SvPVX(PL_linestr)+off;
6835 force_ident_maybe_lex('&');
6840 if (orig_keyword == KEY_do)
6848 yyl_my(pTHX_ char *s, I32 my)
6852 yyerror(Perl_form(aTHX_
6853 "Can't redeclare \"%s\" in \"%s\"",
6854 my == KEY_my ? "my" :
6855 my == KEY_state ? "state" : "our",
6856 PL_in_my == KEY_my ? "my" :
6857 PL_in_my == KEY_state ? "state" : "our"));
6861 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6863 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6864 if (memEQs(PL_tokenbuf, len, "sub"))
6865 return yyl_sub(aTHX_ s, my);
6866 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6867 if (!PL_in_my_stash) {
6871 i = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6872 PERL_MY_SNPRINTF_POST_GUARD(i, sizeof(tmpbuf));
6873 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
6876 else if (*s == '\\') {
6877 if (!FEATURE_MYREF_IS_ENABLED)
6878 Perl_croak(aTHX_ "The experimental declared_refs "
6879 "feature is not enabled");
6880 Perl_ck_warner_d(aTHX_
6881 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
6882 "Declaring references is experimental");
6887 static int yyl_try(pTHX_ char*, STRLEN);
6890 yyl_eol_needs_semicolon(pTHX_ char **ps)
6893 if (PL_lex_state != LEX_NORMAL
6894 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
6896 const bool in_comment = *s == '#';
6898 if (*s == '#' && s == PL_linestart && PL_in_eval
6899 && !PL_rsfp && !PL_parser->filtered) {
6900 /* handle eval qq[#line 1 "foo"\n ...] */
6901 CopLINE_dec(PL_curcop);
6902 incline(s, PL_bufend);
6905 while (d < PL_bufend && *d != '\n')
6910 if (in_comment && d == PL_bufend
6911 && PL_lex_state == LEX_INTERPNORMAL
6912 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6913 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
6915 incline(s, PL_bufend);
6916 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
6917 PL_lex_state = LEX_FORMLINE;
6918 force_next(FORMRBRACK);
6924 while (s < PL_bufend && *s != '\n')
6926 if (s < PL_bufend) {
6929 incline(s, PL_bufend);
6937 yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len)
6945 bof = cBOOL(PL_rsfp);
6948 PL_bufptr = PL_bufend;
6949 COPLINE_INC_WITH_HERELINES;
6950 if (!lex_next_chunk(fake_eof)) {
6951 CopLINE_dec(PL_curcop);
6953 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
6955 CopLINE_dec(PL_curcop);
6957 /* If it looks like the start of a BOM or raw UTF-16,
6958 * check if it in fact is. */
6961 || *(U8*)s == BOM_UTF8_FIRST_BYTE
6965 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
6966 bof = (offset == (Off_t)SvCUR(PL_linestr));
6967 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
6968 /* offset may include swallowed CR */
6970 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
6973 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6974 s = swallow_bom((U8*)s);
6977 if (PL_parser->in_pod) {
6978 /* Incest with pod. */
6979 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
6982 SvPVCLEAR(PL_linestr);
6983 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
6984 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6985 PL_last_lop = PL_last_uni = NULL;
6986 PL_parser->in_pod = 0;
6989 if (PL_rsfp || PL_parser->filtered)
6990 incline(s, PL_bufend);
6991 } while (PL_parser->in_pod);
6993 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
6994 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6995 PL_last_lop = PL_last_uni = NULL;
6996 if (CopLINE(PL_curcop) == 1) {
6997 while (s < PL_bufend && isSPACE(*s))
6999 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
7003 if (*s == '#' && *(s+1) == '!')
7005 #ifdef ALTERNATE_SHEBANG
7007 static char const as[] = ALTERNATE_SHEBANG;
7008 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
7009 d = s + (sizeof(as) - 1);
7011 #endif /* ALTERNATE_SHEBANG */
7020 while (*d && !isSPACE(*d))
7024 #ifdef ARG_ZERO_IS_SCRIPT
7025 if (ipathend > ipath) {
7027 * HP-UX (at least) sets argv[0] to the script name,
7028 * which makes $^X incorrect. And Digital UNIX and Linux,
7029 * at least, set argv[0] to the basename of the Perl
7030 * interpreter. So, having found "#!", we'll set it right.
7032 SV* copfilesv = CopFILESV(PL_curcop);
7035 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
7037 assert(SvPOK(x) || SvGMAGICAL(x));
7038 if (sv_eq(x, copfilesv)) {
7039 sv_setpvn(x, ipath, ipathend - ipath);
7045 const char *bstart = SvPV_const(copfilesv, blen);
7046 const char * const lstart = SvPV_const(x, llen);
7048 bstart += blen - llen;
7049 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
7050 sv_setpvn(x, ipath, ipathend - ipath);
7057 /* Anything to do if no copfilesv? */
7059 TAINT_NOT; /* $^X is always tainted, but that's OK */
7061 #endif /* ARG_ZERO_IS_SCRIPT */
7066 d = instr(s,"perl -");
7068 d = instr(s,"perl");
7070 /* avoid getting into infinite loops when shebang
7071 * line contains "Perl" rather than "perl" */
7073 for (d = ipathend-4; d >= ipath; --d) {
7074 if (isALPHA_FOLD_EQ(*d, 'p')
7075 && !ibcmp(d, "perl", 4))
7085 #ifdef ALTERNATE_SHEBANG
7087 * If the ALTERNATE_SHEBANG on this system starts with a
7088 * character that can be part of a Perl expression, then if
7089 * we see it but not "perl", we're probably looking at the
7090 * start of Perl code, not a request to hand off to some
7091 * other interpreter. Similarly, if "perl" is there, but
7092 * not in the first 'word' of the line, we assume the line
7093 * contains the start of the Perl program.
7095 if (d && *s != '#') {
7096 const char *c = ipath;
7097 while (*c && !memCHRs("; \t\r\n\f\v#", *c))
7100 d = NULL; /* "perl" not in first word; ignore */
7102 *s = '#'; /* Don't try to parse shebang line */
7104 #endif /* ALTERNATE_SHEBANG */
7109 && !instr(s,"indir")
7110 && instr(PL_origargv[0],"perl"))
7117 while (s < PL_bufend && isSPACE(*s))
7119 if (s < PL_bufend) {
7120 Newx(newargv,PL_origargc+3,char*);
7122 while (s < PL_bufend && !isSPACE(*s))
7125 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
7128 newargv = PL_origargv;
7131 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
7133 Perl_croak(aTHX_ "Can't exec %s", ipath);
7136 while (*d && !isSPACE(*d))
7138 while (SPACE_OR_TAB(*d))
7142 const bool switches_done = PL_doswitches;
7143 const U32 oldpdb = PL_perldb;
7144 const bool oldn = PL_minus_n;
7145 const bool oldp = PL_minus_p;
7149 bool baduni = FALSE;
7151 const char *d2 = d1 + 1;
7152 if (parse_unicode_opts((const char **)&d2)
7156 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
7157 const char * const m = d1;
7158 while (*d1 && !isSPACE(*d1))
7160 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
7163 d1 = moreswitches(d1);
7165 if (PL_doswitches && !switches_done) {
7166 int argc = PL_origargc;
7167 char **argv = PL_origargv;
7170 } while (argc && argv[0][0] == '-' && argv[0][1]);
7171 init_argv_symbols(argc,argv);
7173 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
7174 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
7175 /* if we have already added "LINE: while (<>) {",
7176 we must not do it again */
7178 SvPVCLEAR(PL_linestr);
7179 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
7180 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7181 PL_last_lop = PL_last_uni = NULL;
7182 PL_preambled = FALSE;
7183 if (PERLDB_LINE_OR_SAVESRC)
7184 (void)gv_fetchfile(PL_origfilename);
7185 return yyl_try(aTHX_ s, len);
7192 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
7193 PL_lex_state = LEX_FORMLINE;
7194 force_next(FORMRBRACK);
7198 return yyl_try(aTHX_ s, len);
7202 yyl_fatcomma(pTHX_ char *s, STRLEN len)
7206 = newSVOP(OP_CONST, 0,
7207 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7208 pl_yylval.opval->op_private = OPpCONST_BARE;
7213 yyl_safe_bareword(pTHX_ char *s, const char lastchar)
7215 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7216 && PL_parser->saw_infix_sigil)
7218 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7219 "Operator or semicolon missing before %c%" UTF8f,
7221 UTF8fARG(UTF, strlen(PL_tokenbuf),
7223 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7224 "Ambiguous use of %c resolved as operator %c",
7225 lastchar, lastchar);
7231 yyl_constant_op(pTHX_ char *s, SV *sv, CV *cv, OP *rv2cv_op, PADOFFSET off)
7235 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7236 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7237 if (SvTYPE(sv) == SVt_PVAV)
7238 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7241 pl_yylval.opval->op_private = 0;
7242 pl_yylval.opval->op_folded = 1;
7243 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7248 op_free(pl_yylval.opval);
7250 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7251 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7252 PL_last_lop = PL_oldbufptr;
7253 PL_last_lop_op = OP_ENTERSUB;
7255 /* Is there a prototype? */
7257 int k = yyl_subproto(aTHX_ s, cv);
7262 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7264 force_next(off ? PRIVATEREF : BAREWORD);
7265 if (!PL_lex_allbrackets
7266 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7268 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7274 /* Honour "reserved word" warnings, and enforce strict subs */
7276 yyl_strictwarn_bareword(pTHX_ const char lastchar)
7278 /* after "print" and similar functions (corresponding to
7279 * "F? L" in opcode.pl), whatever wasn't already parsed as
7280 * a filehandle should be subject to "strict subs".
7281 * Likewise for the optional indirect-object argument to system
7282 * or exec, which can't be a bareword */
7283 if ((PL_last_lop_op == OP_PRINT
7284 || PL_last_lop_op == OP_PRTF
7285 || PL_last_lop_op == OP_SAY
7286 || PL_last_lop_op == OP_SYSTEM
7287 || PL_last_lop_op == OP_EXEC)
7288 && (PL_hints & HINT_STRICT_SUBS))
7290 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7293 if (lastchar != '-' && ckWARN(WARN_RESERVED)) {
7294 char *d = PL_tokenbuf;
7297 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) {
7298 /* PL_warn_reserved is constant */
7299 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7300 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7302 GCC_DIAG_RESTORE_STMT;
7308 yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c)
7311 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7313 bool no_op_error = FALSE;
7314 /* Use this var to track whether intuit_method has been
7315 called. intuit_method returns 0 or > 255. */
7318 if (PL_expect == XOPERATOR) {
7319 if (PL_bufptr == PL_linestart) {
7320 CopLINE_dec(PL_curcop);
7321 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7322 CopLINE_inc(PL_curcop);
7325 /* We want to call no_op with s pointing after the
7326 bareword, so defer it. But we want it to come
7327 before the Bad name croak. */
7331 /* Get the rest if it looks like a package qualifier */
7333 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7335 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7338 no_op("Bareword",s);
7339 no_op_error = FALSE;
7342 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7343 UTF8fARG(UTF, len, PL_tokenbuf),
7344 *s == '\'' ? "'" : "::");
7350 no_op("Bareword",s);
7352 /* See if the name is "Foo::",
7353 in which case Foo is a bareword
7354 (and a package name). */
7356 if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') {
7357 if (ckWARN(WARN_BAREWORD)
7358 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7359 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7360 "Bareword \"%" UTF8f
7361 "\" refers to nonexistent package",
7362 UTF8fARG(UTF, len, PL_tokenbuf));
7364 PL_tokenbuf[len] = '\0';
7373 /* if we saw a global override before, get the right name */
7376 c.sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len);
7378 SV *sv = newSVpvs("CORE::GLOBAL::");
7384 /* Presume this is going to be a bareword of some sort. */
7386 pl_yylval.opval = newSVOP(OP_CONST, 0, c.sv);
7387 pl_yylval.opval->op_private = OPpCONST_BARE;
7389 /* And if "Foo::", then that's what it certainly is. */
7391 return yyl_safe_bareword(aTHX_ s, lastchar);
7394 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(c.sv));
7395 const_op->op_private = OPpCONST_BARE;
7396 c.rv2cv_op = newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7400 : SvROK(c.gv) && SvTYPE(SvRV(c.gv)) == SVt_PVCV
7403 : rv2cv_op_cv(c.rv2cv_op, RV2CVOPCV_RETURN_STUB);
7406 /* See if it's the indirect object for a list operator. */
7409 && PL_oldoldbufptr < PL_bufptr
7410 && (PL_oldoldbufptr == PL_last_lop
7411 || PL_oldoldbufptr == PL_last_uni)
7412 && /* NO SKIPSPACE BEFORE HERE! */
7414 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7417 bool immediate_paren = *s == '(';
7420 /* (Now we can afford to cross potential line boundary.) */
7423 /* intuit_method() can indirectly call lex_next_chunk(),
7426 s_off = s - SvPVX(PL_linestr);
7427 /* Two barewords in a row may indicate method call. */
7428 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7430 && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
7432 /* the code at method: doesn't use s */
7435 s = SvPVX(PL_linestr) + s_off;
7437 /* If not a declared subroutine, it's an indirect object. */
7438 /* (But it's an indir obj regardless for sort.) */
7439 /* Also, if "_" follows a filetest operator, it's a bareword */
7442 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7444 && (PL_last_lop_op != OP_MAPSTART
7445 && PL_last_lop_op != OP_GREPSTART))))
7446 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7447 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7451 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7452 yyl_strictwarn_bareword(aTHX_ lastchar);
7453 op_free(c.rv2cv_op);
7454 return yyl_safe_bareword(aTHX_ s, lastchar);
7458 PL_expect = XOPERATOR;
7461 /* Is this a word before a => operator? */
7462 if (*s == '=' && s[1] == '>' && !pkgname) {
7463 op_free(c.rv2cv_op);
7465 if (c.gvp || (c.lex && !c.off)) {
7466 assert (cSVOPx(pl_yylval.opval)->op_sv == c.sv);
7467 /* This is our own scalar, created a few lines
7468 above, so this is safe. */
7469 SvREADONLY_off(c.sv);
7470 sv_setpv(c.sv, PL_tokenbuf);
7471 if (UTF && !IN_BYTES
7472 && is_utf8_string((U8*)PL_tokenbuf, len))
7474 SvREADONLY_on(c.sv);
7479 /* If followed by a paren, it's certainly a subroutine. */
7484 while (SPACE_OR_TAB(*d))
7486 if (*d == ')' && (c.sv = cv_const_sv_or_av(c.cv)))
7487 return yyl_constant_op(aTHX_ d + 1, c.sv, c.cv, c.rv2cv_op, c.off);
7489 NEXTVAL_NEXTTOKE.opval =
7490 c.off ? c.rv2cv_op : pl_yylval.opval;
7492 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7493 else op_free(c.rv2cv_op), force_next(BAREWORD);
7498 /* If followed by var or block, call it a method (unless sub) */
7500 if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) {
7501 op_free(c.rv2cv_op);
7502 PL_last_lop = PL_oldbufptr;
7503 PL_last_lop_op = OP_METHOD;
7504 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7505 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7506 PL_expect = XBLOCKTERM;
7508 return REPORT(METHOD);
7511 /* If followed by a bareword, see if it looks like indir obj. */
7515 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7516 && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
7519 if (c.lex && !c.off) {
7520 assert(cSVOPx(pl_yylval.opval)->op_sv == c.sv);
7521 SvREADONLY_off(c.sv);
7522 sv_setpvn(c.sv, PL_tokenbuf, len);
7523 if (UTF && !IN_BYTES
7524 && is_utf8_string((U8*)PL_tokenbuf, len))
7526 else SvUTF8_off(c.sv);
7528 op_free(c.rv2cv_op);
7529 if (key == METHOD && !PL_lex_allbrackets
7530 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7532 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7537 /* Not a method, so call it a subroutine (if defined) */
7540 /* Check for a constant sub */
7541 c.sv = cv_const_sv_or_av(c.cv);
7542 return yyl_constant_op(aTHX_ s, c.sv, c.cv, c.rv2cv_op, c.off);
7545 /* Call it a bare word */
7547 if (PL_hints & HINT_STRICT_SUBS)
7548 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7550 yyl_strictwarn_bareword(aTHX_ lastchar);
7552 op_free(c.rv2cv_op);
7554 return yyl_safe_bareword(aTHX_ s, lastchar);
7558 yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct code c)
7561 default: /* not a keyword */
7562 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
7565 FUN0OP( newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)) );
7569 newSVOP(OP_CONST, 0,
7570 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7573 case KEY___PACKAGE__:
7575 newSVOP(OP_CONST, 0, (PL_curstash
7576 ? newSVhek(HvNAME_HEK(PL_curstash))
7582 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D'))
7583 yyl_data_handle(aTHX);
7584 return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len);
7587 FUN0OP(CvCLONE(PL_compcv)
7588 ? newOP(OP_RUNCV, 0)
7589 : newPVOP(OP_RUNCV,0,NULL));
7598 if (PL_expect == XSTATE)
7599 return yyl_sub(aTHX_ PL_bufptr, key);
7600 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
7609 LOP(OP_ACCEPT,XTERM);
7612 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7617 LOP(OP_ATAN2,XTERM);
7623 LOP(OP_BINMODE,XTERM);
7626 LOP(OP_BLESS,XTERM);
7635 /* We have to disambiguate the two senses of
7636 "continue". If the next token is a '{' then
7637 treat it as the start of a continue block;
7638 otherwise treat it as a control operator.
7648 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7658 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7667 if (!PL_cryptseen) {
7668 PL_cryptseen = TRUE;
7672 LOP(OP_CRYPT,XTERM);
7675 LOP(OP_CHMOD,XTERM);
7678 LOP(OP_CHOWN,XTERM);
7681 LOP(OP_CONNECT,XTERM);
7696 return yyl_do(aTHX_ s, orig_keyword);
7699 PL_hints |= HINT_BLOCK_SCOPE;
7709 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7710 STR_WITH_LEN("NDBM_File::"),
7711 STR_WITH_LEN("DB_File::"),
7712 STR_WITH_LEN("GDBM_File::"),
7713 STR_WITH_LEN("SDBM_File::"),
7714 STR_WITH_LEN("ODBM_File::"),
7716 LOP(OP_DBMOPEN,XTERM);
7728 pl_yylval.ival = CopLINE(PL_curcop);
7732 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7744 if (*s == '{') { /* block eval */
7745 PL_expect = XTERMBLOCK;
7746 UNIBRACK(OP_ENTERTRY);
7748 else { /* string eval */
7750 UNIBRACK(OP_ENTEREVAL);
7755 UNIBRACK(-OP_ENTEREVAL);
7769 case KEY_endhostent:
7775 case KEY_endservent:
7778 case KEY_endprotoent:
7789 return yyl_foreach(aTHX_ s);
7792 LOP(OP_FORMLINE,XTERM);
7801 LOP(OP_FCNTL,XTERM);
7807 LOP(OP_FLOCK,XTERM);
7810 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7815 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7820 LOP(OP_GREPSTART, XREF);
7837 case KEY_getpriority:
7838 LOP(OP_GETPRIORITY,XTERM);
7840 case KEY_getprotobyname:
7843 case KEY_getprotobynumber:
7844 LOP(OP_GPBYNUMBER,XTERM);
7846 case KEY_getprotoent:
7858 case KEY_getpeername:
7859 UNI(OP_GETPEERNAME);
7861 case KEY_gethostbyname:
7864 case KEY_gethostbyaddr:
7865 LOP(OP_GHBYADDR,XTERM);
7867 case KEY_gethostent:
7870 case KEY_getnetbyname:
7873 case KEY_getnetbyaddr:
7874 LOP(OP_GNBYADDR,XTERM);
7879 case KEY_getservbyname:
7880 LOP(OP_GSBYNAME,XTERM);
7882 case KEY_getservbyport:
7883 LOP(OP_GSBYPORT,XTERM);
7885 case KEY_getservent:
7888 case KEY_getsockname:
7889 UNI(OP_GETSOCKNAME);
7891 case KEY_getsockopt:
7892 LOP(OP_GSOCKOPT,XTERM);
7907 pl_yylval.ival = CopLINE(PL_curcop);
7908 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7909 "given is experimental");
7913 LOP( orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM );
7919 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7921 pl_yylval.ival = CopLINE(PL_curcop);
7925 LOP(OP_INDEX,XTERM);
7931 LOP(OP_IOCTL,XTERM);
7934 Perl_ck_warner_d(aTHX_
7935 packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
7963 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7968 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7982 LOP(OP_LISTEN,XTERM);
7991 s = scan_pat(s,OP_MATCH);
7992 TERM(sublex_start());
7995 LOP(OP_MAPSTART, XREF);
7998 LOP(OP_MKDIR,XTERM);
8001 LOP(OP_MSGCTL,XTERM);
8004 LOP(OP_MSGGET,XTERM);
8007 LOP(OP_MSGRCV,XTERM);
8010 LOP(OP_MSGSND,XTERM);
8015 return yyl_my(aTHX_ s, key);
8021 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8026 s = tokenize_use(0, s);
8030 if (*s == '(' || (s = skipspace(s), *s == '('))
8033 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8034 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8040 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8042 char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8043 for (t=d; isSPACE(*t);)
8045 if ( *t && memCHRs("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8047 && !(t[0] == '=' && t[1] == '>')
8048 && !(t[0] == ':' && t[1] == ':')
8049 && !keyword(s, d-s, 0)
8051 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8052 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8053 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8059 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8061 pl_yylval.ival = OP_OR;
8071 LOP(OP_OPEN_DIR,XTERM);
8074 checkcomma(s,PL_tokenbuf,"filehandle");
8078 checkcomma(s,PL_tokenbuf,"filehandle");
8097 s = force_word(s,BAREWORD,FALSE,TRUE);
8099 s = force_strict_version(s);
8103 LOP(OP_PIPE_OP,XTERM);
8106 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8108 missingterm(NULL, 0);
8109 COPLINE_SET_FROM_MULTI_END;
8110 pl_yylval.ival = OP_CONST;
8111 TERM(sublex_start());
8117 return yyl_qw(aTHX_ s, len);
8120 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8122 missingterm(NULL, 0);
8123 pl_yylval.ival = OP_STRINGIFY;
8124 if (SvIVX(PL_lex_stuff) == '\'')
8125 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8126 TERM(sublex_start());
8129 s = scan_pat(s,OP_QR);
8130 TERM(sublex_start());
8133 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8135 missingterm(NULL, 0);
8136 pl_yylval.ival = OP_BACKTICK;
8137 TERM(sublex_start());
8143 return yyl_require(aTHX_ s, orig_keyword);
8152 LOP(OP_RENAME,XTERM);
8161 LOP(OP_RINDEX,XTERM);
8170 UNIDOR(OP_READLINE);
8173 UNIDOR(OP_BACKTICK);
8182 LOP(OP_REVERSE,XTERM);
8185 UNIDOR(OP_READLINK);
8192 if (pl_yylval.opval)
8193 TERM(sublex_start());
8195 TOKEN(1); /* force error */
8198 checkcomma(s,PL_tokenbuf,"filehandle");
8208 LOP(OP_SELECT,XTERM);
8214 LOP(OP_SEMCTL,XTERM);
8217 LOP(OP_SEMGET,XTERM);
8220 LOP(OP_SEMOP,XTERM);
8226 LOP(OP_SETPGRP,XTERM);
8228 case KEY_setpriority:
8229 LOP(OP_SETPRIORITY,XTERM);
8231 case KEY_sethostent:
8237 case KEY_setservent:
8240 case KEY_setprotoent:
8250 LOP(OP_SEEKDIR,XTERM);
8252 case KEY_setsockopt:
8253 LOP(OP_SSOCKOPT,XTERM);
8259 LOP(OP_SHMCTL,XTERM);
8262 LOP(OP_SHMGET,XTERM);
8265 LOP(OP_SHMREAD,XTERM);
8268 LOP(OP_SHMWRITE,XTERM);
8271 LOP(OP_SHUTDOWN,XTERM);
8280 LOP(OP_SOCKET,XTERM);
8282 case KEY_socketpair:
8283 LOP(OP_SOCKPAIR,XTERM);
8286 checkcomma(s,PL_tokenbuf,"subroutine name");
8289 s = force_word(s,BAREWORD,TRUE,TRUE);
8293 LOP(OP_SPLIT,XTERM);
8296 LOP(OP_SPRINTF,XTERM);
8299 LOP(OP_SPLICE,XTERM);
8314 LOP(OP_SUBSTR,XTERM);
8318 return yyl_sub(aTHX_ s, key);
8321 LOP(OP_SYSTEM,XREF);
8324 LOP(OP_SYMLINK,XTERM);
8327 LOP(OP_SYSCALL,XTERM);
8330 LOP(OP_SYSOPEN,XTERM);
8333 LOP(OP_SYSSEEK,XTERM);
8336 LOP(OP_SYSREAD,XTERM);
8339 LOP(OP_SYSWRITE,XTERM);
8344 TERM(sublex_start());
8365 LOP(OP_TRUNCATE,XTERM);
8377 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8379 pl_yylval.ival = CopLINE(PL_curcop);
8383 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8385 pl_yylval.ival = CopLINE(PL_curcop);
8389 LOP(OP_UNLINK,XTERM);
8395 LOP(OP_UNPACK,XTERM);
8398 LOP(OP_UTIME,XTERM);
8404 LOP(OP_UNSHIFT,XTERM);
8407 s = tokenize_use(1, s);
8417 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8419 pl_yylval.ival = CopLINE(PL_curcop);
8420 Perl_ck_warner_d(aTHX_
8421 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8422 "when is experimental");
8426 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8428 pl_yylval.ival = CopLINE(PL_curcop);
8432 PL_hints |= HINT_BLOCK_SCOPE;
8439 LOP(OP_WAITPID,XTERM);
8445 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8446 * we use the same number on EBCDIC */
8447 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8451 if (PL_expect == XOPERATOR) {
8452 if (*s == '=' && !PL_lex_allbrackets
8453 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8460 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
8463 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8465 pl_yylval.ival = OP_XOR;
8471 yyl_key_core(pTHX_ char *s, STRLEN len, struct code c)
8474 I32 orig_keyword = 0;
8478 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8479 if ((*s == ':' && s[1] == ':')
8480 || (!(key = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
8482 Copy(PL_bufptr, PL_tokenbuf, olen, char);
8483 return yyl_just_a_word(aTHX_ d, olen, 0, c);
8486 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
8487 UTF8fARG(UTF, len, PL_tokenbuf));
8490 else if (key == KEY_require || key == KEY_do
8492 /* that's a way to remember we saw "CORE::" */
8495 /* Known to be a reserved word at this point */
8496 return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
8500 yyl_keylookup(pTHX_ char *s, GV *gv)
8506 struct code c = no_code;
8507 I32 orig_keyword = 0;
8513 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8515 /* Some keywords can be followed by any delimiter, including ':' */
8516 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
8518 /* x::* is just a word, unless x is "CORE" */
8519 if (!anydelim && *s == ':' && s[1] == ':') {
8520 if (memEQs(PL_tokenbuf, len, "CORE"))
8521 return yyl_key_core(aTHX_ s, len, c);
8522 return yyl_just_a_word(aTHX_ s, len, 0, c);
8526 while (d < PL_bufend && isSPACE(*d))
8527 d++; /* no comments skipped here, or s### is misparsed */
8529 /* Is this a word before a => operator? */
8530 if (*d == '=' && d[1] == '>') {
8531 return yyl_fatcomma(aTHX_ s, len);
8534 /* Check for plugged-in keyword */
8538 char *saved_bufptr = PL_bufptr;
8540 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
8542 if (result == KEYWORD_PLUGIN_DECLINE) {
8543 /* not a plugged-in keyword */
8544 PL_bufptr = saved_bufptr;
8545 } else if (result == KEYWORD_PLUGIN_STMT) {
8546 pl_yylval.opval = o;
8548 if (!PL_nexttoke) PL_expect = XSTATE;
8549 return REPORT(PLUGSTMT);
8550 } else if (result == KEYWORD_PLUGIN_EXPR) {
8551 pl_yylval.opval = o;
8553 if (!PL_nexttoke) PL_expect = XOPERATOR;
8554 return REPORT(PLUGEXPR);
8556 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", PL_tokenbuf);
8560 /* Is this a label? */
8561 if (!anydelim && PL_expect == XSTATE
8562 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
8565 newSVOP(OP_CONST, 0,
8566 newSVpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0));
8571 /* Check for lexical sub */
8572 if (PL_expect != XOPERATOR) {
8573 char tmpbuf[sizeof PL_tokenbuf + 1];
8575 Copy(PL_tokenbuf, tmpbuf+1, len, char);
8576 c.off = pad_findmy_pvn(tmpbuf, len+1, 0);
8577 if (c.off != NOT_IN_PAD) {
8578 assert(c.off); /* we assume this is boolean-true below */
8579 if (PAD_COMPNAME_FLAGS_isOUR(c.off)) {
8580 HV * const stash = PAD_COMPNAME_OURSTASH(c.off);
8581 HEK * const stashname = HvNAME_HEK(stash);
8582 c.sv = newSVhek(stashname);
8583 sv_catpvs(c.sv, "::");
8584 sv_catpvn_flags(c.sv, PL_tokenbuf, len,
8585 (UTF ? SV_CATUTF8 : SV_CATBYTES));
8586 c.gv = gv_fetchsv(c.sv, GV_NOADD_NOINIT | SvUTF8(c.sv),
8592 return yyl_just_a_word(aTHX_ s, len, 0, c);
8596 c.rv2cv_op = newOP(OP_PADANY, 0);
8597 c.rv2cv_op->op_targ = c.off;
8598 c.cv = find_lexical_cv(c.off);
8601 return yyl_just_a_word(aTHX_ s, len, 0, c);
8606 /* Check for built-in keyword */
8607 key = keyword(PL_tokenbuf, len, 0);
8610 key = yyl_secondclass_keyword(aTHX_ s, len, key, &orig_keyword, &c.gv, &c.gvp);
8612 if (key && key != KEY___DATA__ && key != KEY___END__
8613 && (!anydelim || *s != '#')) {
8614 /* no override, and not s### either; skipspace is safe here
8615 * check for => on following line */
8617 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
8618 STRLEN soff = s - SvPVX(PL_linestr);
8620 arrow = *s == '=' && s[1] == '>';
8621 PL_bufptr = SvPVX(PL_linestr) + bufoff;
8622 s = SvPVX(PL_linestr) + soff;
8624 return yyl_fatcomma(aTHX_ s, len);
8627 return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
8631 yyl_try(pTHX_ char *s, STRLEN len)
8639 if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s))
8640 return yyl_keylookup(aTHX_ s, gv);
8641 yyl_croak_unrecognised(aTHX_ s);
8645 /* emulate EOF on ^D or ^Z */
8646 return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len);
8649 if ((!PL_rsfp || PL_lex_inwhat)
8650 && (!PL_parser->filtered || s+1 < PL_bufend)) {
8654 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
8656 yyerror((const char *)
8658 ? "Format not terminated"
8659 : "Missing right curly or square bracket"));
8662 PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n");
8666 if (s++ < PL_bufend)
8667 goto retry; /* ignore stray nulls */
8670 if (!PL_in_eval && !PL_preambled) {
8671 PL_preambled = TRUE;
8673 /* Generate a string of Perl code to load the debugger.
8674 * If PERL5DB is set, it will return the contents of that,
8675 * otherwise a compile-time require of perl5db.pl. */
8677 const char * const pdb = PerlEnv_getenv("PERL5DB");
8680 sv_setpv(PL_linestr, pdb);
8681 sv_catpvs(PL_linestr,";");
8683 SETERRNO(0,SS_NORMAL);
8684 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
8686 PL_parser->preambling = CopLINE(PL_curcop);
8688 SvPVCLEAR(PL_linestr);
8689 if (PL_preambleav) {
8690 SV **svp = AvARRAY(PL_preambleav);
8691 SV **const end = svp + AvFILLp(PL_preambleav);
8693 sv_catsv(PL_linestr, *svp);
8695 sv_catpvs(PL_linestr, ";");
8697 sv_free(MUTABLE_SV(PL_preambleav));
8698 PL_preambleav = NULL;
8701 sv_catpvs(PL_linestr,
8702 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
8703 if (PL_minus_n || PL_minus_p) {
8704 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
8706 sv_catpvs(PL_linestr,"chomp;");
8709 if ( ( *PL_splitstr == '/'
8710 || *PL_splitstr == '\''
8711 || *PL_splitstr == '"')
8712 && strchr(PL_splitstr + 1, *PL_splitstr))
8714 /* strchr is ok, because -F pattern can't contain
8716 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
8719 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
8720 bytes can be used as quoting characters. :-) */
8721 const char *splits = PL_splitstr;
8722 sv_catpvs(PL_linestr, "our @F=split(q\0");
8725 if (*splits == '\\')
8726 sv_catpvn(PL_linestr, splits, 1);
8727 sv_catpvn(PL_linestr, splits, 1);
8728 } while (*splits++);
8729 /* This loop will embed the trailing NUL of
8730 PL_linestr as the last thing it does before
8732 sv_catpvs(PL_linestr, ");");
8736 sv_catpvs(PL_linestr,"our @F=split(' ');");
8739 sv_catpvs(PL_linestr, "\n");
8740 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
8741 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8742 PL_last_lop = PL_last_uni = NULL;
8743 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
8744 update_debugger_info(PL_linestr, NULL, 0);
8747 return yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s, len);
8750 #ifdef PERL_STRICT_CR
8751 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
8753 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
8755 case ' ': case '\t': case '\f': case '\v':
8761 const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
8762 if (needs_semicolon)
8769 return yyl_hyphen(aTHX_ s);
8772 return yyl_plus(aTHX_ s);
8775 return yyl_star(aTHX_ s);
8778 return yyl_percent(aTHX_ s);
8781 return yyl_caret(aTHX_ s);
8784 return yyl_leftsquare(aTHX_ s);
8787 return yyl_tilde(aTHX_ s);
8790 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
8796 return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
8797 return yyl_colon(aTHX_ s + 1);
8800 return yyl_leftparen(aTHX_ s + 1);
8803 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8811 return yyl_rightparen(aTHX_ s);
8814 return yyl_rightsquare(aTHX_ s);
8817 return yyl_leftcurly(aTHX_ s + 1, 0);
8820 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
8822 return yyl_rightcurly(aTHX_ s, 0);
8825 return yyl_ampersand(aTHX_ s);
8828 return yyl_verticalbar(aTHX_ s);
8831 if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n')
8832 && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), "====="))
8834 s = vcs_conflict_marker(s + 7);
8840 const char tmp = *s++;
8842 if (!PL_lex_allbrackets
8843 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8851 if (!PL_lex_allbrackets
8852 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
8861 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
8862 && memCHRs("+-*/%.^&|<",tmp))
8863 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8864 "Reversed %c= operator",(int)tmp);
8866 if (PL_expect == XSTATE
8868 && (s == PL_linestart+1 || s[-2] == '\n') )
8870 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
8871 || PL_lex_state != LEX_NORMAL)
8876 incline(s, PL_bufend);
8877 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
8879 s = (char *) memchr(s,'\n', d - s);
8884 incline(s, PL_bufend);
8892 PL_parser->in_pod = 1;
8896 if (PL_expect == XBLOCK) {
8898 #ifdef PERL_STRICT_CR
8899 while (SPACE_OR_TAB(*t))
8901 while (SPACE_OR_TAB(*t) || *t == '\r')
8904 if (*t == '\n' || *t == '#') {
8905 ENTER_with_name("lex_format");
8906 SAVEI8(PL_parser->form_lex_state);
8907 SAVEI32(PL_lex_formbrack);
8908 PL_parser->form_lex_state = PL_lex_state;
8909 PL_lex_formbrack = PL_lex_brackets + 1;
8910 PL_parser->sub_error_count = PL_error_count;
8911 return yyl_leftcurly(aTHX_ s, 1);
8914 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
8922 return yyl_bang(aTHX_ s + 1);
8925 if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n')
8926 && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
8928 s = vcs_conflict_marker(s + 7);
8931 return yyl_leftpointy(aTHX_ s);
8934 if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n')
8935 && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), ">>>>>"))
8937 s = vcs_conflict_marker(s + 7);
8940 return yyl_rightpointy(aTHX_ s + 1);
8943 return yyl_dollar(aTHX_ s);
8946 return yyl_snail(aTHX_ s);
8948 case '/': /* may be division, defined-or, or pattern */
8949 return yyl_slash(aTHX_ s);
8951 case '?': /* conditional */
8953 if (!PL_lex_allbrackets
8954 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
8959 PL_lex_allbrackets++;
8963 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
8964 #ifdef PERL_STRICT_CR
8967 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
8969 && (s == PL_linestart || s[-1] == '\n') )
8972 /* formbrack==2 means dot seen where arguments expected */
8973 return yyl_rightcurly(aTHX_ s, 2);
8975 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
8979 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
8982 if (!PL_lex_allbrackets
8983 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
8991 pl_yylval.ival = OPf_SPECIAL;
8997 if (*s == '=' && !PL_lex_allbrackets
8998 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
9006 case '0': case '1': case '2': case '3': case '4':
9007 case '5': case '6': case '7': case '8': case '9':
9008 s = scan_num(s, &pl_yylval);
9009 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
9010 if (PL_expect == XOPERATOR)
9015 return yyl_sglquote(aTHX_ s);
9018 return yyl_dblquote(aTHX_ s, len);
9021 return yyl_backtick(aTHX_ s);
9024 return yyl_backslash(aTHX_ s + 1);
9027 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
9028 char *start = s + 2;
9029 while (isDIGIT(*start) || *start == '_')
9031 if (*start == '.' && isDIGIT(start[1])) {
9032 s = scan_num(s, &pl_yylval);
9035 else if ((*start == ':' && start[1] == ':')
9036 || (PL_expect == XSTATE && *start == ':'))
9037 return yyl_keylookup(aTHX_ s, gv);
9038 else if (PL_expect == XSTATE) {
9040 while (d < PL_bufend && isSPACE(*d)) d++;
9042 return yyl_keylookup(aTHX_ s, gv);
9044 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
9045 if (!isALPHA(*start) && (PL_expect == XTERM
9046 || PL_expect == XREF || PL_expect == XSTATE
9047 || PL_expect == XTERMORDORDOR)) {
9048 GV *const gv = gv_fetchpvn_flags(s, start - s,
9049 UTF ? SVf_UTF8 : 0, SVt_PVCV);
9051 s = scan_num(s, &pl_yylval);
9056 return yyl_keylookup(aTHX_ s, gv);
9059 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
9063 return yyl_keylookup(aTHX_ s, gv);
9092 return yyl_keylookup(aTHX_ s, gv);
9100 Works out what to call the token just pulled out of the input
9101 stream. The yacc parser takes care of taking the ops we return and
9102 stitching them into a tree.
9105 The type of the next token
9108 Check if we have already built the token; if so, use it.
9109 Switch based on the current state:
9110 - if we have a case modifier in a string, deal with that
9111 - handle other cases of interpolation inside a string
9112 - scan the next line if we are inside a format
9113 In the normal state, switch on the next character:
9115 if alphabetic, go to key lookup
9116 unrecognized character - croak
9117 - 0/4/26: handle end-of-line or EOF
9118 - cases for whitespace
9119 - \n and #: handle comments and line numbers
9120 - various operators, brackets and sigils
9123 - 'v': vstrings (or go to key lookup)
9124 - 'x' repetition operator (or go to key lookup)
9125 - other ASCII alphanumerics (key lookup begins here):
9128 scan built-in keyword (but do nothing with it yet)
9129 check for statement label
9130 check for lexical subs
9131 return yyl_just_a_word if there is one
9132 see whether built-in keyword is overridden
9133 switch on keyword number:
9134 - default: return yyl_just_a_word:
9135 not a built-in keyword; handle bareword lookup
9136 disambiguate between method and sub call
9137 fall back to bareword
9138 - cases for built-in keywords
9142 #define RSFP_FILENO (PL_rsfp)
9144 #define RSFP_FILENO (PerlIO_fileno(PL_rsfp))
9152 char *s = PL_bufptr;
9154 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
9155 const U8* first_bad_char_loc;
9156 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
9157 PL_bufend - PL_bufptr,
9158 &first_bad_char_loc)))
9160 _force_out_malformed_utf8_message(first_bad_char_loc,
9163 1 /* 1 means die */ );
9164 NOT_REACHED; /* NOTREACHED */
9166 PL_parser->recheck_utf8_validity = FALSE;
9169 SV* tmp = newSVpvs("");
9170 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
9171 (IV)CopLINE(PL_curcop),
9172 lex_state_names[PL_lex_state],
9173 exp_name[PL_expect],
9174 pv_display(tmp, s, strlen(s), 0, 60));
9178 /* when we've already built the next token, just pull it out of the queue */
9181 pl_yylval = PL_nextval[PL_nexttoke];
9184 next_type = PL_nexttype[PL_nexttoke];
9185 if (next_type & (7<<24)) {
9186 if (next_type & (1<<24)) {
9187 if (PL_lex_brackets > 100)
9188 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
9189 PL_lex_brackstack[PL_lex_brackets++] =
9190 (char) ((next_type >> 16) & 0xff);
9192 if (next_type & (2<<24))
9193 PL_lex_allbrackets++;
9194 if (next_type & (4<<24))
9195 PL_lex_allbrackets--;
9196 next_type &= 0xffff;
9198 return REPORT(next_type == 'p' ? pending_ident() : next_type);
9202 switch (PL_lex_state) {
9204 case LEX_INTERPNORMAL:
9207 /* interpolated case modifiers like \L \U, including \Q and \E.
9208 when we get here, PL_bufptr is at the \
9210 case LEX_INTERPCASEMOD:
9211 /* handle \E or end of string */
9212 return yyl_interpcasemod(aTHX_ s);
9214 case LEX_INTERPPUSH:
9215 return REPORT(sublex_push());
9217 case LEX_INTERPSTART:
9218 if (PL_bufptr == PL_bufend)
9219 return REPORT(sublex_done());
9221 if(*PL_bufptr != '(')
9222 PerlIO_printf(Perl_debug_log, "### Interpolated variable\n");
9225 /* for /@a/, we leave the joining for the regex engine to do
9226 * (unless we're within \Q etc) */
9227 PL_lex_dojoin = (*PL_bufptr == '@'
9228 && (!PL_lex_inpat || PL_lex_casemods));
9229 PL_lex_state = LEX_INTERPNORMAL;
9230 if (PL_lex_dojoin) {
9231 NEXTVAL_NEXTTOKE.ival = 0;
9233 force_ident("\"", '$');
9234 NEXTVAL_NEXTTOKE.ival = 0;
9236 NEXTVAL_NEXTTOKE.ival = 0;
9237 force_next((2<<24)|'(');
9238 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
9241 /* Convert (?{...}) and friends to 'do {...}' */
9242 if (PL_lex_inpat && *PL_bufptr == '(') {
9243 PL_parser->lex_shared->re_eval_start = PL_bufptr;
9245 if (*PL_bufptr != '{')
9247 PL_expect = XTERMBLOCK;
9251 if (PL_lex_starts++) {
9253 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
9254 if (!PL_lex_casemods && PL_lex_inpat)
9257 AopNOASSIGN(OP_CONCAT);
9261 case LEX_INTERPENDMAYBE:
9262 if (intuit_more(PL_bufptr, PL_bufend)) {
9263 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
9269 if (PL_lex_dojoin) {
9270 const U8 dojoin_was = PL_lex_dojoin;
9271 PL_lex_dojoin = FALSE;
9272 PL_lex_state = LEX_INTERPCONCAT;
9273 PL_lex_allbrackets--;
9274 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
9276 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
9277 && SvEVALED(PL_lex_repl))
9279 if (PL_bufptr != PL_bufend)
9280 Perl_croak(aTHX_ "Bad evalled substitution pattern");
9283 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
9284 re_eval_str. If the here-doc body’s length equals the previous
9285 value of re_eval_start, re_eval_start will now be null. So
9286 check re_eval_str as well. */
9287 if (PL_parser->lex_shared->re_eval_start
9288 || PL_parser->lex_shared->re_eval_str) {
9290 if (*PL_bufptr != ')')
9291 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
9293 /* having compiled a (?{..}) expression, return the original
9294 * text too, as a const */
9295 if (PL_parser->lex_shared->re_eval_str) {
9296 sv = PL_parser->lex_shared->re_eval_str;
9297 PL_parser->lex_shared->re_eval_str = NULL;
9299 PL_bufptr - PL_parser->lex_shared->re_eval_start);
9300 SvPV_shrink_to_cur(sv);
9302 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
9303 PL_bufptr - PL_parser->lex_shared->re_eval_start);
9304 NEXTVAL_NEXTTOKE.opval =
9305 newSVOP(OP_CONST, 0,
9308 PL_parser->lex_shared->re_eval_start = NULL;
9314 case LEX_INTERPCONCAT:
9316 if (PL_lex_brackets)
9317 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
9318 (long) PL_lex_brackets);
9320 if (PL_bufptr == PL_bufend)
9321 return REPORT(sublex_done());
9323 /* m'foo' still needs to be parsed for possible (?{...}) */
9324 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
9325 SV *sv = newSVsv(PL_linestr);
9327 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
9331 int save_error_count = PL_error_count;
9333 s = scan_const(PL_bufptr);
9335 /* Set flag if this was a pattern and there were errors. op.c will
9336 * refuse to compile a pattern with this flag set. Otherwise, we
9337 * could get segfaults, etc. */
9338 if (PL_lex_inpat && PL_error_count > save_error_count) {
9339 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
9342 PL_lex_state = LEX_INTERPCASEMOD;
9344 PL_lex_state = LEX_INTERPSTART;
9347 if (s != PL_bufptr) {
9348 NEXTVAL_NEXTTOKE = pl_yylval;
9351 if (PL_lex_starts++) {
9352 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
9353 if (!PL_lex_casemods && PL_lex_inpat)
9356 AopNOASSIGN(OP_CONCAT);
9366 if (PL_parser->sub_error_count != PL_error_count) {
9367 /* There was an error parsing a formline, which tends to
9369 Unlike interpolated sub-parsing, we can't treat any of
9370 these as recoverable, so no need to check sub_no_recover.
9374 assert(PL_lex_formbrack);
9375 s = scan_formline(PL_bufptr);
9376 if (!PL_lex_formbrack)
9377 return yyl_rightcurly(aTHX_ s, 1);
9382 /* We really do *not* want PL_linestr ever becoming a COW. */
9383 assert (!SvIsCOW(PL_linestr));
9385 PL_oldoldbufptr = PL_oldbufptr;
9388 if (PL_in_my == KEY_sigvar) {
9389 PL_parser->saw_infix_sigil = 0;
9390 return yyl_sigvar(aTHX_ s);
9394 /* yyl_try() and its callees might consult PL_parser->saw_infix_sigil.
9395 On its return, we then need to set it to indicate whether the token
9396 we just encountered was an infix operator that (if we hadn't been
9397 expecting an operator) have been a sigil.
9399 bool expected_operator = (PL_expect == XOPERATOR);
9400 int ret = yyl_try(aTHX_ s, 0);
9401 switch (pl_yylval.ival) {
9406 if (expected_operator) {
9407 PL_parser->saw_infix_sigil = 1;
9412 PL_parser->saw_infix_sigil = 0;
9422 Looks up an identifier in the pad or in a package
9424 PL_in_my == KEY_sigvar indicates that this is a subroutine signature variable
9425 rather than a plain pad var.
9428 PRIVATEREF if this is a lexical name.
9429 BAREWORD if this belongs to a package.
9432 if we're in a my declaration
9433 croak if they tried to say my($foo::bar)
9434 build the ops for a my() declaration
9435 if it's an access to a my() variable
9436 build ops for access to a my() variable
9437 if in a dq string, and they've said @foo and we can't find @foo
9439 build ops for a bareword
9443 S_pending_ident(pTHX)
9446 const char pit = (char)pl_yylval.ival;
9447 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
9448 /* All routes through this function want to know if there is a colon. */
9449 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
9451 DEBUG_T({ PerlIO_printf(Perl_debug_log,
9452 "### Pending identifier '%s'\n", PL_tokenbuf); });
9453 assert(tokenbuf_len >= 2);
9455 /* if we're in a my(), we can't allow dynamics here.
9456 $foo'bar has already been turned into $foo::bar, so
9457 just check for colons.
9459 if it's a legal name, the OP is a PADANY.
9462 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
9464 /* diag_listed_as: No package name allowed for variable %s
9466 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
9468 *PL_tokenbuf=='&' ? "subroutine" : "variable",
9469 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
9470 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
9475 /* "my" variable %s can't be in a package */
9476 /* PL_no_myglob is constant */
9477 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
9478 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
9479 PL_in_my == KEY_my ? "my" : "state",
9480 *PL_tokenbuf == '&' ? "subroutine" : "variable",
9482 UTF ? SVf_UTF8 : 0);
9483 GCC_DIAG_RESTORE_STMT;
9486 if (PL_in_my == KEY_sigvar) {
9487 /* A signature 'padop' needs in addition, an op_first to
9488 * point to a child sigdefelem, and an extra field to hold
9489 * the signature index. We can achieve both by using an
9490 * UNOP_AUX and (ab)using the op_aux field to hold the
9491 * index. If we ever need more fields, use a real malloced
9492 * aux strut instead.
9494 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
9495 INT2PTR(UNOP_AUX_item *,
9496 (PL_parser->sig_elems)));
9497 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9498 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9502 o = newOP(OP_PADANY, 0);
9503 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9504 UTF ? SVf_UTF8 : 0);
9505 if (PL_in_my == KEY_sigvar)
9508 pl_yylval.opval = o;
9514 build the ops for accesses to a my() variable.
9519 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9521 if (tmp != NOT_IN_PAD) {
9522 /* might be an "our" variable" */
9523 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9524 /* build ops for a bareword */
9525 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9526 HEK * const stashname = HvNAME_HEK(stash);
9527 SV * const sym = newSVhek(stashname);
9528 sv_catpvs(sym, "::");
9529 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9530 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9531 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9535 ((PL_tokenbuf[0] == '$') ? SVt_PV
9536 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9541 pl_yylval.opval = newOP(OP_PADANY, 0);
9542 pl_yylval.opval->op_targ = tmp;
9548 Whine if they've said @foo or @foo{key} in a doublequoted string,
9549 and @foo (or %foo) isn't a variable we can find in the symbol
9552 if (ckWARN(WARN_AMBIGUOUS)
9554 && PL_lex_state != LEX_NORMAL
9555 && !PL_lex_brackets)
9557 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9558 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9560 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9563 /* Downgraded from fatal to warning 20000522 mjd */
9564 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9565 "Possible unintended interpolation of %" UTF8f
9567 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9571 /* build ops for a bareword */
9572 pl_yylval.opval = newSVOP(OP_CONST, 0,
9573 newSVpvn_flags(PL_tokenbuf + 1,
9574 tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9575 UTF ? SVf_UTF8 : 0 ));
9576 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9578 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9579 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9580 | ( UTF ? SVf_UTF8 : 0 ),
9581 ((PL_tokenbuf[0] == '$') ? SVt_PV
9582 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9588 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9590 PERL_ARGS_ASSERT_CHECKCOMMA;
9592 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9593 if (ckWARN(WARN_SYNTAX)) {
9596 for (w = s+2; *w && level; w++) {
9604 /* the list of chars below is for end of statements or
9605 * block / parens, boolean operators (&&, ||, //) and branch
9606 * constructs (or, and, if, until, unless, while, err, for).
9607 * Not a very solid hack... */
9608 if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w))
9609 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9610 "%s (...) interpreted as function",name);
9613 while (s < PL_bufend && isSPACE(*s))
9617 while (s < PL_bufend && isSPACE(*s))
9619 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9620 const char * const w = s;
9621 s += UTF ? UTF8SKIP(s) : 1;
9622 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9623 s += UTF ? UTF8SKIP(s) : 1;
9624 while (s < PL_bufend && isSPACE(*s))
9628 if (keyword(w, s - w, 0))
9631 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9632 if (gv && GvCVu(gv))
9637 Copy(w, tmpbuf+1, s - w, char);
9639 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9640 if (off != NOT_IN_PAD) return;
9642 Perl_croak(aTHX_ "No comma allowed after %s", what);
9647 /* S_new_constant(): do any overload::constant lookup.
9649 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9650 Best used as sv=new_constant(..., sv, ...).
9651 If s, pv are NULL, calls subroutine with one argument,
9652 and <type> is used with error messages only.
9653 <type> is assumed to be well formed UTF-8.
9655 If error_msg is not NULL, *error_msg will be set to any error encountered.
9656 Otherwise yyerror() will be used to output it */
9659 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9660 SV *sv, SV *pv, const char *type, STRLEN typelen,
9661 const char ** error_msg)
9664 HV * table = GvHV(PL_hintgv); /* ^H */
9669 const char *why1 = "", *why2 = "", *why3 = "";
9670 const char * optional_colon = ":"; /* Only some messages have a colon */
9673 PERL_ARGS_ASSERT_NEW_CONSTANT;
9674 /* We assume that this is true: */
9677 sv_2mortal(sv); /* Parent created it permanently */
9680 || ! (PL_hints & HINT_LOCALIZE_HH))
9683 optional_colon = "";
9687 cvp = hv_fetch(table, key, keylen, FALSE);
9688 if (!cvp || !SvOK(*cvp)) {
9691 why3 = "} is not defined";
9697 pv = newSVpvn_flags(s, len, SVs_TEMP);
9699 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9701 typesv = &PL_sv_undef;
9703 PUSHSTACKi(PERLSI_OVERLOAD);
9715 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9719 /* Check the eval first */
9720 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9722 const char * errstr;
9723 sv_catpvs(errsv, "Propagated");
9724 errstr = SvPV_const(errsv, errlen);
9725 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9727 res = SvREFCNT_inc_simple_NN(sv);
9731 SvREFCNT_inc_simple_void_NN(res);
9744 (void)sv_2mortal(sv);
9746 why1 = "Call to &{$^H{";
9748 why3 = "}} did not return a defined value";
9752 msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s",
9753 (int)(type ? typelen : len),
9761 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9763 return SvREFCNT_inc_simple_NN(sv);
9766 PERL_STATIC_INLINE void
9767 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9768 bool is_utf8, bool check_dollar, bool tick_warn)
9771 const char *olds = *s;
9772 PERL_ARGS_ASSERT_PARSE_IDENT;
9774 while (*s < PL_bufend) {
9776 Perl_croak(aTHX_ "%s", ident_too_long);
9777 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9778 /* The UTF-8 case must come first, otherwise things
9779 * like c\N{COMBINING TILDE} would start failing, as the
9780 * isWORDCHAR_A case below would gobble the 'c' up.
9783 char *t = *s + UTF8SKIP(*s);
9784 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9787 if (*d + (t - *s) > e)
9788 Perl_croak(aTHX_ "%s", ident_too_long);
9789 Copy(*s, *d, t - *s, char);
9793 else if ( isWORDCHAR_A(**s) ) {
9796 } while (isWORDCHAR_A(**s) && *d < e);
9798 else if ( allow_package
9800 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9807 else if (allow_package && **s == ':' && (*s)[1] == ':'
9808 /* Disallow things like Foo::$bar. For the curious, this is
9809 * the code path that triggers the "Bad name after" warning
9810 * when looking for barewords.
9812 && !(check_dollar && (*s)[2] == '$')) {
9819 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9820 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9823 Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9826 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9827 "Old package separator used in string");
9828 if (olds[-1] == '#')
9832 if (*olds == '\'') {
9839 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9840 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9841 UTF8fARG(is_utf8, d2-this_d, this_d));
9846 /* Returns a NUL terminated string, with the length of the string written to
9850 Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9853 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9854 bool is_utf8 = cBOOL(UTF);
9856 PERL_ARGS_ASSERT_SCAN_WORD;
9858 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9864 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9865 * iff Unicode semantics are to be used. The legal ones are any of:
9866 * a) all ASCII characters except:
9867 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9869 * The final case currently doesn't get this far in the program, so we
9870 * don't test for it. If that were to change, it would be ok to allow it.
9871 * b) When not under Unicode rules, any upper Latin1 character
9872 * c) Otherwise, when unicode rules are used, all XIDS characters.
9874 * Because all ASCII characters have the same representation whether
9875 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9876 * '{' without knowing if is UTF-8 or not. */
9877 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9878 (isGRAPH_A(*(s)) || ((is_utf8) \
9879 ? isIDFIRST_utf8_safe(s, e) \
9881 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9884 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9886 I32 herelines = PL_parser->herelines;
9887 SSize_t bracket = -1;
9890 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9891 bool is_utf8 = cBOOL(UTF);
9892 I32 orig_copline = 0, tmp_copline = 0;
9894 PERL_ARGS_ASSERT_SCAN_IDENT;
9896 if (isSPACE(*s) || !*s)
9898 if (isDIGIT(*s)) { /* handle $0 and $1 $2 and $10 and etc */
9899 bool is_zero= *s == '0' ? TRUE : FALSE;
9900 char *digit_start= d;
9902 while (s < PL_bufend && isDIGIT(*s)) {
9904 Perl_croak(aTHX_ "%s", ident_too_long);
9907 if (is_zero && d - digit_start > 1)
9908 Perl_croak(aTHX_ ident_var_zero_multi_digit);
9910 else { /* See if it is a "normal" identifier */
9911 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9916 /* Either a digit variable, or parse_ident() found an identifier
9917 (anything valid as a bareword), so job done and return. */
9918 if (PL_lex_state != LEX_NORMAL)
9919 PL_lex_state = LEX_INTERPENDMAYBE;
9923 /* Here, it is not a run-of-the-mill identifier name */
9925 if (*s == '$' && s[1]
9926 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9927 || isDIGIT_A((U8)s[1])
9930 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9932 /* Dereferencing a value in a scalar variable.
9933 The alternatives are different syntaxes for a scalar variable.
9934 Using ' as a leading package separator isn't allowed. :: is. */
9937 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9939 bracket = s - SvPVX(PL_linestr);
9941 orig_copline = CopLINE(PL_curcop);
9942 if (s < PL_bufend && isSPACE(*s)) {
9946 if ((s <= PL_bufend - ((is_utf8)
9949 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9952 const STRLEN skip = UTF8SKIP(s);
9955 for ( i = 0; i < skip; i++ )
9960 /* special case to handle ${10}, ${11} the same way we handle ${1} etc */
9962 bool is_zero= *d == '0' ? TRUE : FALSE;
9963 char *digit_start= d;
9964 while (s < PL_bufend && isDIGIT(*s)) {
9967 Perl_croak(aTHX_ "%s", ident_too_long);
9970 if (is_zero && d - digit_start > 1)
9971 Perl_croak(aTHX_ ident_var_zero_multi_digit);
9976 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9977 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9981 /* Warn about ambiguous code after unary operators if {...} notation isn't
9982 used. There's no difference in ambiguity; it's merely a heuristic
9983 about when not to warn. */
9984 else if (ck_uni && bracket == -1)
9986 if (bracket != -1) {
9989 /* If we were processing {...} notation then... */
9990 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9991 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9994 /* note we have to check for a normal identifier first,
9995 * as it handles utf8 symbols, and only after that has
9996 * been ruled out can we look at the caret words */
9997 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9998 /* if it starts as a valid identifier, assume that it is one.
9999 (the later check for } being at the expected point will trap
10000 cases where this doesn't pan out.) */
10001 d += is_utf8 ? UTF8SKIP(d) : 1;
10002 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
10005 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
10007 while (isWORDCHAR(*s) && d < e) {
10011 Perl_croak(aTHX_ "%s", ident_too_long);
10014 tmp_copline = CopLINE(PL_curcop);
10015 if (s < PL_bufend && isSPACE(*s)) {
10018 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10019 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
10020 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10021 const char * const brack =
10023 ((*s == '[') ? "[...]" : "{...}");
10024 orig_copline = CopLINE(PL_curcop);
10025 CopLINE_set(PL_curcop, tmp_copline);
10026 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
10027 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10028 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10029 funny, dest, brack, funny, dest, brack);
10030 CopLINE_set(PL_curcop, orig_copline);
10033 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10034 PL_lex_allbrackets++;
10039 if ( !tmp_copline )
10040 tmp_copline = CopLINE(PL_curcop);
10041 if ((skip = s < PL_bufend && isSPACE(*s))) {
10042 /* Avoid incrementing line numbers or resetting PL_linestart,
10043 in case we have to back up. */
10044 STRLEN s_off = s - SvPVX(PL_linestr);
10046 s = SvPVX(PL_linestr) + s_off;
10051 /* Expect to find a closing } after consuming any trailing whitespace.
10054 /* Now increment line numbers if applicable. */
10058 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10059 PL_lex_state = LEX_INTERPEND;
10062 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) {
10063 if (ckWARN(WARN_AMBIGUOUS)
10064 && (keyword(dest, d - dest, 0)
10065 || get_cvn_flags(dest, d - dest, is_utf8
10069 SV *tmp = newSVpvn_flags( dest, d - dest,
10070 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
10073 orig_copline = CopLINE(PL_curcop);
10074 CopLINE_set(PL_curcop, tmp_copline);
10075 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10076 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
10077 funny, SVfARG(tmp), funny, SVfARG(tmp));
10078 CopLINE_set(PL_curcop, orig_copline);
10083 /* Didn't find the closing } at the point we expected, so restore
10084 state such that the next thing to process is the opening { and */
10085 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
10086 CopLINE_set(PL_curcop, orig_copline);
10087 PL_parser->herelines = herelines;
10089 PL_parser->sub_no_recover = TRUE;
10092 else if ( PL_lex_state == LEX_INTERPNORMAL
10093 && !PL_lex_brackets
10094 && !intuit_more(s, PL_bufend))
10095 PL_lex_state = LEX_INTERPEND;
10100 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
10102 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
10103 * found in the parse starting at 's', based on the subset that are valid
10104 * in this context input to this routine in 'valid_flags'. Advances s.
10105 * Returns TRUE if the input should be treated as a valid flag, so the next
10106 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
10107 * upon first call on the current regex. This routine will set it to any
10108 * charset modifier found. The caller shouldn't change it. This way,
10109 * another charset modifier encountered in the parse can be detected as an
10110 * error, as we have decided to allow only one */
10112 const char c = **s;
10113 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
10115 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
10116 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
10117 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
10118 UTF ? SVf_UTF8 : 0);
10120 /* Pretend that it worked, so will continue processing before
10129 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
10130 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10131 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10132 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10133 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
10134 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
10135 case LOCALE_PAT_MOD:
10137 goto multiple_charsets;
10139 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
10142 case UNICODE_PAT_MOD:
10144 goto multiple_charsets;
10146 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
10149 case ASCII_RESTRICT_PAT_MOD:
10151 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
10155 /* Error if previous modifier wasn't an 'a', but if it was, see
10156 * if, and accept, a second occurrence (only) */
10157 if (*charset != 'a'
10158 || get_regex_charset(*pmfl)
10159 != REGEX_ASCII_RESTRICTED_CHARSET)
10161 goto multiple_charsets;
10163 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
10167 case DEPENDS_PAT_MOD:
10169 goto multiple_charsets;
10171 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
10180 if (*charset != c) {
10181 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
10183 else if (c == 'a') {
10184 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
10185 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
10188 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
10191 /* Pretend that it worked, so will continue processing before dieing */
10197 S_scan_pat(pTHX_ char *start, I32 type)
10201 const char * const valid_flags =
10202 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10203 char charset = '\0'; /* character set modifier */
10204 unsigned int x_mod_count = 0;
10206 PERL_ARGS_ASSERT_SCAN_PAT;
10208 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
10210 Perl_croak(aTHX_ "Search pattern not terminated");
10212 pm = (PMOP*)newPMOP(type, 0);
10213 if (PL_multi_open == '?') {
10214 /* This is the only point in the code that sets PMf_ONCE: */
10215 pm->op_pmflags |= PMf_ONCE;
10217 /* Hence it's safe to do this bit of PMOP book-keeping here, which
10218 allows us to restrict the list needed by reset to just the ??
10220 assert(type != OP_TRANS);
10222 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
10225 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
10228 elements = mg->mg_len / sizeof(PMOP**);
10229 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
10230 ((PMOP**)mg->mg_ptr) [elements++] = pm;
10231 mg->mg_len = elements * sizeof(PMOP**);
10232 PmopSTASH_set(pm,PL_curstash);
10236 /* if qr/...(?{..}).../, then need to parse the pattern within a new
10237 * anon CV. False positives like qr/[(?{]/ are harmless */
10239 if (type == OP_QR) {
10241 char *e, *p = SvPV(PL_lex_stuff, len);
10243 for (; p < e; p++) {
10244 if (p[0] == '(' && p[1] == '?'
10245 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
10247 pm->op_pmflags |= PMf_HAS_CV;
10251 pm->op_pmflags |= PMf_IS_QR;
10254 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
10255 &s, &charset, &x_mod_count))
10257 /* issue a warning if /c is specified,but /g is not */
10258 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
10260 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10261 "Use of /c modifier is meaningless without /g" );
10264 PL_lex_op = (OP*)pm;
10265 pl_yylval.ival = OP_MATCH;
10270 S_scan_subst(pTHX_ char *start)
10276 line_t linediff = 0;
10278 char charset = '\0'; /* character set modifier */
10279 unsigned int x_mod_count = 0;
10282 PERL_ARGS_ASSERT_SCAN_SUBST;
10284 pl_yylval.ival = OP_NULL;
10286 s = scan_str(start, TRUE, FALSE, FALSE, &t);
10289 Perl_croak(aTHX_ "Substitution pattern not terminated");
10293 first_start = PL_multi_start;
10294 first_line = CopLINE(PL_curcop);
10295 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
10297 SvREFCNT_dec_NN(PL_lex_stuff);
10298 PL_lex_stuff = NULL;
10299 Perl_croak(aTHX_ "Substitution replacement not terminated");
10301 PL_multi_start = first_start; /* so whole substitution is taken together */
10303 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10307 if (*s == EXEC_PAT_MOD) {
10311 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
10312 &s, &charset, &x_mod_count))
10318 if ((pm->op_pmflags & PMf_CONTINUE)) {
10319 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10323 SV * const repl = newSVpvs("");
10326 pm->op_pmflags |= PMf_EVAL;
10327 for (; es > 1; es--) {
10328 sv_catpvs(repl, "eval ");
10330 sv_catpvs(repl, "do {");
10331 sv_catsv(repl, PL_parser->lex_sub_repl);
10332 sv_catpvs(repl, "}");
10333 SvREFCNT_dec(PL_parser->lex_sub_repl);
10334 PL_parser->lex_sub_repl = repl;
10338 linediff = CopLINE(PL_curcop) - first_line;
10340 CopLINE_set(PL_curcop, first_line);
10342 if (linediff || es) {
10343 /* the IVX field indicates that the replacement string is a s///e;
10344 * the NVX field indicates how many src code lines the replacement
10346 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
10347 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
10348 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
10352 PL_lex_op = (OP*)pm;
10353 pl_yylval.ival = OP_SUBST;
10358 S_scan_trans(pTHX_ char *start)
10365 bool nondestruct = 0;
10368 PERL_ARGS_ASSERT_SCAN_TRANS;
10370 pl_yylval.ival = OP_NULL;
10372 s = scan_str(start,FALSE,FALSE,FALSE,&t);
10374 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10378 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
10380 SvREFCNT_dec_NN(PL_lex_stuff);
10381 PL_lex_stuff = NULL;
10382 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10385 complement = del = squash = 0;
10389 complement = OPpTRANS_COMPLEMENT;
10392 del = OPpTRANS_DELETE;
10395 squash = OPpTRANS_SQUASH;
10407 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
10408 o->op_private &= ~OPpTRANS_ALL;
10409 o->op_private |= del|squash|complement;
10412 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
10419 Takes a pointer to the first < in <<FOO.
10420 Returns a pointer to the byte following <<FOO.
10422 This function scans a heredoc, which involves different methods
10423 depending on whether we are in a string eval, quoted construct, etc.
10424 This is because PL_linestr could containing a single line of input, or
10425 a whole string being evalled, or the contents of the current quote-
10428 The two basic methods are:
10429 - Steal lines from the input stream
10430 - Scan the heredoc in PL_linestr and remove it therefrom
10432 In a file scope or filtered eval, the first method is used; in a
10433 string eval, the second.
10435 In a quote-like operator, we have to choose between the two,
10436 depending on where we can find a newline. We peek into outer lex-
10437 ing scopes until we find one with a newline in it. If we reach the
10438 outermost lexing scope and it is a file, we use the stream method.
10439 Otherwise it is treated as an eval.
10443 S_scan_heredoc(pTHX_ char *s)
10445 I32 op_type = OP_SCALAR;
10453 I32 indent_len = 0;
10454 bool indented = FALSE;
10455 const bool infile = PL_rsfp || PL_parser->filtered;
10456 const line_t origline = CopLINE(PL_curcop);
10457 LEXSHARED *shared = PL_parser->lex_shared;
10459 PERL_ARGS_ASSERT_SCAN_HEREDOC;
10462 d = PL_tokenbuf + 1;
10463 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10464 *PL_tokenbuf = '\n';
10467 if (*peek == '~') {
10472 while (SPACE_OR_TAB(*peek))
10475 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10478 s = delimcpy(d, e, s, PL_bufend, term, &len);
10479 if (s == PL_bufend)
10480 Perl_croak(aTHX_ "Unterminated delimiter for here document");
10486 /* <<\FOO is equivalent to <<'FOO' */
10491 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10492 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10496 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10497 peek += UTF ? UTF8SKIP(peek) : 1;
10500 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10501 Copy(s, d, len, char);
10506 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10507 Perl_croak(aTHX_ "Delimiter for here document is too long");
10511 len = d - PL_tokenbuf;
10513 #ifndef PERL_STRICT_CR
10514 d = (char *) memchr(s, '\r', PL_bufend - s);
10516 char * const olds = s;
10518 while (s < PL_bufend) {
10524 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10533 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10538 tmpstr = newSV_type(SVt_PVIV);
10539 SvGROW(tmpstr, 80);
10540 if (term == '\'') {
10541 op_type = OP_CONST;
10542 SvIV_set(tmpstr, -1);
10544 else if (term == '`') {
10545 op_type = OP_BACKTICK;
10546 SvIV_set(tmpstr, '\\');
10549 PL_multi_start = origline + 1 + PL_parser->herelines;
10550 PL_multi_open = PL_multi_close = '<';
10552 /* inside a string eval or quote-like operator */
10553 if (!infile || PL_lex_inwhat) {
10556 char * const olds = s;
10557 PERL_CONTEXT * const cx = CX_CUR();
10558 /* These two fields are not set until an inner lexing scope is
10559 entered. But we need them set here. */
10560 shared->ls_bufptr = s;
10561 shared->ls_linestr = PL_linestr;
10563 if (PL_lex_inwhat) {
10564 /* Look for a newline. If the current buffer does not have one,
10565 peek into the line buffer of the parent lexing scope, going
10566 up as many levels as necessary to find one with a newline
10569 while (!(s = (char *)memchr(
10570 (void *)shared->ls_bufptr, '\n',
10571 SvEND(shared->ls_linestr)-shared->ls_bufptr
10574 shared = shared->ls_prev;
10575 /* shared is only null if we have gone beyond the outermost
10576 lexing scope. In a file, we will have broken out of the
10577 loop in the previous iteration. In an eval, the string buf-
10578 fer ends with "\n;", so the while condition above will have
10579 evaluated to false. So shared can never be null. Or so you
10580 might think. Odd syntax errors like s;@{<<; can gobble up
10581 the implicit semicolon at the end of a flie, causing the
10582 file handle to be closed even when we are not in a string
10583 eval. So shared may be null in that case.
10584 (Closing '>>}' here to balance the earlier open brace for
10585 editors that look for matched pairs.) */
10586 if (UNLIKELY(!shared))
10588 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10589 most lexing scope. In a file, shared->ls_linestr at that
10590 level is just one line, so there is no body to steal. */
10591 if (infile && !shared->ls_prev) {
10597 else { /* eval or we've already hit EOF */
10598 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10603 linestr = shared->ls_linestr;
10604 bufend = SvEND(linestr);
10609 while (s < bufend - len + 1) {
10611 ++PL_parser->herelines;
10613 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10617 /* Only valid if it's preceded by whitespace only */
10618 while (backup != myolds && --backup >= myolds) {
10619 if (! SPACE_OR_TAB(*backup)) {
10625 /* No whitespace or all! */
10626 if (backup == s || *backup == '\n') {
10627 Newx(indent, indent_len + 1, char);
10628 memcpy(indent, backup + 1, indent_len);
10629 indent[indent_len] = 0;
10630 s--; /* before our delimiter */
10631 PL_parser->herelines--; /* this line doesn't count */
10638 while (s < bufend - len + 1
10639 && memNE(s,PL_tokenbuf,len) )
10642 ++PL_parser->herelines;
10646 if (s >= bufend - len + 1) {
10650 sv_setpvn(tmpstr,d+1,s-d);
10652 /* the preceding stmt passes a newline */
10653 PL_parser->herelines++;
10655 /* s now points to the newline after the heredoc terminator.
10656 d points to the newline before the body of the heredoc.
10659 /* We are going to modify linestr in place here, so set
10660 aside copies of the string if necessary for re-evals or
10662 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10663 check shared->re_eval_str. */
10664 if (shared->re_eval_start || shared->re_eval_str) {
10665 /* Set aside the rest of the regexp */
10666 if (!shared->re_eval_str)
10667 shared->re_eval_str =
10668 newSVpvn(shared->re_eval_start,
10669 bufend - shared->re_eval_start);
10670 shared->re_eval_start -= s-d;
10673 if (cxstack_ix >= 0
10674 && CxTYPE(cx) == CXt_EVAL
10675 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10676 && cx->blk_eval.cur_text == linestr)
10678 cx->blk_eval.cur_text = newSVsv(linestr);
10679 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10682 /* Copy everything from s onwards back to d. */
10683 Move(s,d,bufend-s + 1,char);
10684 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10685 /* Setting PL_bufend only applies when we have not dug deeper
10686 into other scopes, because sublex_done sets PL_bufend to
10687 SvEND(PL_linestr). */
10688 if (shared == PL_parser->lex_shared)
10689 PL_bufend = SvEND(linestr);
10694 char *oldbufptr_save;
10695 char *oldoldbufptr_save;
10697 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10698 term = PL_tokenbuf[1];
10700 linestr_save = PL_linestr; /* must restore this afterwards */
10701 d = s; /* and this */
10702 oldbufptr_save = PL_oldbufptr;
10703 oldoldbufptr_save = PL_oldoldbufptr;
10704 PL_linestr = newSVpvs("");
10705 PL_bufend = SvPVX(PL_linestr);
10708 PL_bufptr = PL_bufend;
10709 CopLINE_set(PL_curcop,
10710 origline + 1 + PL_parser->herelines);
10712 if ( !lex_next_chunk(LEX_NO_TERM)
10713 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n'))
10715 /* Simply freeing linestr_save might seem simpler here, as it
10716 does not matter what PL_linestr points to, since we are
10717 about to croak; but in a quote-like op, linestr_save
10718 will have been prospectively freed already, via
10719 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10720 restore PL_linestr. */
10721 SvREFCNT_dec_NN(PL_linestr);
10722 PL_linestr = linestr_save;
10723 PL_oldbufptr = oldbufptr_save;
10724 PL_oldoldbufptr = oldoldbufptr_save;
10728 CopLINE_set(PL_curcop, origline);
10730 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10731 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10732 /* ^That should be enough to avoid this needing to grow: */
10733 sv_catpvs(PL_linestr, "\n\0");
10734 assert(s == SvPVX(PL_linestr));
10735 PL_bufend = SvEND(PL_linestr);
10739 PL_parser->herelines++;
10740 PL_last_lop = PL_last_uni = NULL;
10742 #ifndef PERL_STRICT_CR
10743 if (PL_bufend - PL_linestart >= 2) {
10744 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10745 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10747 PL_bufend[-2] = '\n';
10749 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10751 else if (PL_bufend[-1] == '\r')
10752 PL_bufend[-1] = '\n';
10754 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10755 PL_bufend[-1] = '\n';
10758 if (indented && (PL_bufend-s) >= len) {
10759 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10762 char *backup = found;
10765 /* Only valid if it's preceded by whitespace only */
10766 while (backup != s && --backup >= s) {
10767 if (! SPACE_OR_TAB(*backup)) {
10773 /* All whitespace or none! */
10774 if (backup == found || SPACE_OR_TAB(*backup)) {
10775 Newx(indent, indent_len + 1, char);
10776 memcpy(indent, backup, indent_len);
10777 indent[indent_len] = 0;
10778 SvREFCNT_dec(PL_linestr);
10779 PL_linestr = linestr_save;
10780 PL_linestart = SvPVX(linestr_save);
10781 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10782 PL_oldbufptr = oldbufptr_save;
10783 PL_oldoldbufptr = oldoldbufptr_save;
10789 /* Didn't find it */
10790 sv_catsv(tmpstr,PL_linestr);
10793 if (*s == term && PL_bufend-s >= len
10794 && memEQ(s,PL_tokenbuf + 1,len))
10796 SvREFCNT_dec(PL_linestr);
10797 PL_linestr = linestr_save;
10798 PL_linestart = SvPVX(linestr_save);
10799 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10800 PL_oldbufptr = oldbufptr_save;
10801 PL_oldoldbufptr = oldoldbufptr_save;
10806 sv_catsv(tmpstr,PL_linestr);
10812 PL_multi_end = origline + PL_parser->herelines;
10814 if (indented && indent) {
10815 STRLEN linecount = 1;
10816 STRLEN herelen = SvCUR(tmpstr);
10817 char *ss = SvPVX(tmpstr);
10818 char *se = ss + herelen;
10819 SV *newstr = newSV(herelen+1);
10822 /* Trim leading whitespace */
10824 /* newline only? Copy and move on */
10826 sv_catpvs(newstr,"\n");
10830 /* Found our indentation? Strip it */
10832 else if (se - ss >= indent_len
10833 && memEQ(ss, indent, indent_len))
10838 while ((ss + le) < se && *(ss + le) != '\n')
10841 sv_catpvn(newstr, ss, le);
10844 /* Line doesn't begin with our indentation? Croak */
10849 "Indentation on line %d of here-doc doesn't match delimiter",
10855 /* avoid sv_setsv() as we dont wan't to COW here */
10856 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10858 SvREFCNT_dec_NN(newstr);
10861 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10862 SvPV_shrink_to_cur(tmpstr);
10866 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10870 PL_lex_stuff = tmpstr;
10871 pl_yylval.ival = op_type;
10877 SvREFCNT_dec(tmpstr);
10878 CopLINE_set(PL_curcop, origline);
10879 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10883 /* scan_inputsymbol
10884 takes: position of first '<' in input buffer
10885 returns: position of first char following the matching '>' in
10887 side-effects: pl_yylval and lex_op are set.
10892 <<>> read from ARGV without magic open
10893 <FH> read from filehandle
10894 <pkg::FH> read from package qualified filehandle
10895 <pkg'FH> read from package qualified filehandle
10896 <$fh> read from filehandle in $fh
10897 <*.h> filename glob
10902 S_scan_inputsymbol(pTHX_ char *start)
10904 char *s = start; /* current position in buffer */
10907 bool nomagicopen = FALSE;
10908 char *d = PL_tokenbuf; /* start of temp holding space */
10909 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10911 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10913 end = (char *) memchr(s, '\n', PL_bufend - s);
10916 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10917 nomagicopen = TRUE;
10923 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10925 /* die if we didn't have space for the contents of the <>,
10926 or if it didn't end, or if we see a newline
10929 if (len >= (I32)sizeof PL_tokenbuf)
10930 Perl_croak(aTHX_ "Excessively long <> operator");
10932 Perl_croak(aTHX_ "Unterminated <> operator");
10937 Remember, only scalar variables are interpreted as filehandles by
10938 this code. Anything more complex (e.g., <$fh{$num}>) will be
10939 treated as a glob() call.
10940 This code makes use of the fact that except for the $ at the front,
10941 a scalar variable and a filehandle look the same.
10943 if (*d == '$' && d[1]) d++;
10945 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10946 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10947 d += UTF ? UTF8SKIP(d) : 1;
10950 /* If we've tried to read what we allow filehandles to look like, and
10951 there's still text left, then it must be a glob() and not a getline.
10952 Use scan_str to pull out the stuff between the <> and treat it
10953 as nothing more than a string.
10956 if (d - PL_tokenbuf != len) {
10957 pl_yylval.ival = OP_GLOB;
10958 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10960 Perl_croak(aTHX_ "Glob not terminated");
10964 bool readline_overriden = FALSE;
10966 /* we're in a filehandle read situation */
10969 /* turn <> into <ARGV> */
10971 Copy("ARGV",d,5,char);
10973 /* Check whether readline() is overriden */
10974 if ((gv_readline = gv_override("readline",8)))
10975 readline_overriden = TRUE;
10977 /* if <$fh>, create the ops to turn the variable into a
10981 /* try to find it in the pad for this block, otherwise find
10982 add symbol table ops
10984 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10985 if (tmp != NOT_IN_PAD) {
10986 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10987 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10988 HEK * const stashname = HvNAME_HEK(stash);
10989 SV * const sym = sv_2mortal(newSVhek(stashname));
10990 sv_catpvs(sym, "::");
10991 sv_catpv(sym, d+1);
10996 OP * const o = newOP(OP_PADSV, 0);
10998 PL_lex_op = readline_overriden
10999 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11000 op_append_elem(OP_LIST, o,
11001 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11002 : newUNOP(OP_READLINE, 0, o);
11010 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
11012 PL_lex_op = readline_overriden
11013 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11014 op_append_elem(OP_LIST,
11015 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11016 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11017 : newUNOP(OP_READLINE, 0,
11018 newUNOP(OP_RV2SV, 0,
11019 newGVOP(OP_GV, 0, gv)));
11021 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11022 pl_yylval.ival = OP_NULL;
11025 /* If it's none of the above, it must be a literal filehandle
11026 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11028 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
11029 PL_lex_op = readline_overriden
11030 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11031 op_append_elem(OP_LIST,
11032 newGVOP(OP_GV, 0, gv),
11033 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11034 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
11035 pl_yylval.ival = OP_NULL;
11045 start position in buffer
11046 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
11047 only if they are of the open/close form
11048 keep_delims preserve the delimiters around the string
11049 re_reparse compiling a run-time /(?{})/:
11050 collapse // to /, and skip encoding src
11051 delimp if non-null, this is set to the position of
11052 the closing delimiter, or just after it if
11053 the closing and opening delimiters differ
11054 (i.e., the opening delimiter of a substitu-
11056 returns: position to continue reading from buffer
11057 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11058 updates the read buffer.
11060 This subroutine pulls a string out of the input. It is called for:
11061 q single quotes q(literal text)
11062 ' single quotes 'literal text'
11063 qq double quotes qq(interpolate $here please)
11064 " double quotes "interpolate $here please"
11065 qx backticks qx(/bin/ls -l)
11066 ` backticks `/bin/ls -l`
11067 qw quote words @EXPORT_OK = qw( func() $spam )
11068 m// regexp match m/this/
11069 s/// regexp substitute s/this/that/
11070 tr/// string transliterate tr/this/that/
11071 y/// string transliterate y/this/that/
11072 ($*@) sub prototypes sub foo ($)
11073 (stuff) sub attr parameters sub foo : attr(stuff)
11074 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11076 In most of these cases (all but <>, patterns and transliterate)
11077 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11078 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11079 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11082 It skips whitespace before the string starts, and treats the first
11083 character as the delimiter. If the delimiter is one of ([{< then
11084 the corresponding "close" character )]}> is used as the closing
11085 delimiter. It allows quoting of delimiters, and if the string has
11086 balanced delimiters ([{<>}]) it allows nesting.
11088 On success, the SV with the resulting string is put into lex_stuff or,
11089 if that is already non-NULL, into lex_repl. The second case occurs only
11090 when parsing the RHS of the special constructs s/// and tr/// (y///).
11091 For convenience, the terminating delimiter character is stuffed into
11096 Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
11100 SV *sv; /* scalar value: string */
11101 const char *tmps; /* temp string, used for delimiter matching */
11102 char *s = start; /* current position in the buffer */
11103 char term; /* terminating character */
11104 char *to; /* current position in the sv's data */
11105 I32 brackets = 1; /* bracket nesting level */
11106 bool d_is_utf8 = FALSE; /* is there any utf8 content? */
11107 IV termcode; /* terminating char. code */
11108 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
11109 STRLEN termlen; /* length of terminating string */
11112 /* The delimiters that have a mirror-image closing one */
11113 const char * opening_delims = "([{<";
11114 const char * closing_delims = ")]}>";
11116 /* The only non-UTF character that isn't a stand alone grapheme is
11117 * white-space, hence can't be a delimiter. */
11118 const char * non_grapheme_msg = "Use of unassigned code point or"
11119 " non-standalone grapheme for a delimiter"
11121 PERL_ARGS_ASSERT_SCAN_STR;
11123 /* skip space before the delimiter */
11128 /* mark where we are, in case we need to report errors */
11131 /* after skipping whitespace, the next character is the terminator */
11133 if (!UTF || UTF8_IS_INVARIANT(term)) {
11134 termcode = termstr[0] = term;
11138 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
11139 if (UTF && UNLIKELY(! is_grapheme((U8 *) start,
11144 yyerror(non_grapheme_msg);
11147 Copy(s, termstr, termlen, U8);
11150 /* mark where we are */
11151 PL_multi_start = CopLINE(PL_curcop);
11152 PL_multi_open = termcode;
11153 herelines = PL_parser->herelines;
11155 /* If the delimiter has a mirror-image closing one, get it */
11156 if (term && (tmps = strchr(opening_delims, term))) {
11157 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
11160 PL_multi_close = termcode;
11162 if (PL_multi_open == PL_multi_close) {
11163 keep_bracketed_quoted = FALSE;
11166 /* create a new SV to hold the contents. 79 is the SV's initial length.
11167 What a random number. */
11168 sv = newSV_type(SVt_PVIV);
11170 SvIV_set(sv, termcode);
11171 (void)SvPOK_only(sv); /* validate pointer */
11173 /* move past delimiter and try to read a complete string */
11175 sv_catpvn(sv, s, termlen);
11178 /* extend sv if need be */
11179 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11180 /* set 'to' to the next character in the sv's string */
11181 to = SvPVX(sv)+SvCUR(sv);
11183 /* if open delimiter is the close delimiter read unbridle */
11184 if (PL_multi_open == PL_multi_close) {
11185 for (; s < PL_bufend; s++,to++) {
11186 /* embedded newlines increment the current line number */
11187 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
11188 COPLINE_INC_WITH_HERELINES;
11189 /* handle quoted delimiters */
11190 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11191 if (!keep_bracketed_quoted
11193 || (re_reparse && s[1] == '\\'))
11196 else /* any other quotes are simply copied straight through */
11199 /* terminate when run out of buffer (the for() condition), or
11200 have found the terminator */
11201 else if (*s == term) { /* First byte of terminator matches */
11202 if (termlen == 1) /* If is the only byte, are done */
11205 /* If the remainder of the terminator matches, also are
11206 * done, after checking that is a separate grapheme */
11207 if ( s + termlen <= PL_bufend
11208 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
11211 && UNLIKELY(! is_grapheme((U8 *) start,
11216 yyerror(non_grapheme_msg);
11221 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
11229 /* if the terminator isn't the same as the start character (e.g.,
11230 matched brackets), we have to allow more in the quoting, and
11231 be prepared for nested brackets.
11234 /* read until we run out of string, or we find the terminator */
11235 for (; s < PL_bufend; s++,to++) {
11236 /* embedded newlines increment the line count */
11237 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
11238 COPLINE_INC_WITH_HERELINES;
11239 /* backslashes can escape the open or closing characters */
11240 if (*s == '\\' && s+1 < PL_bufend) {
11241 if (!keep_bracketed_quoted
11242 && ( ((UV)s[1] == PL_multi_open)
11243 || ((UV)s[1] == PL_multi_close) ))
11250 /* allow nested opens and closes */
11251 else if ((UV)*s == PL_multi_close && --brackets <= 0)
11253 else if ((UV)*s == PL_multi_open)
11255 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11260 /* terminate the copied string and update the sv's end-of-string */
11262 SvCUR_set(sv, to - SvPVX_const(sv));
11265 * this next chunk reads more into the buffer if we're not done yet
11269 break; /* handle case where we are done yet :-) */
11271 #ifndef PERL_STRICT_CR
11272 if (to - SvPVX_const(sv) >= 2) {
11273 if ( (to[-2] == '\r' && to[-1] == '\n')
11274 || (to[-2] == '\n' && to[-1] == '\r'))
11278 SvCUR_set(sv, to - SvPVX_const(sv));
11280 else if (to[-1] == '\r')
11283 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11287 /* if we're out of file, or a read fails, bail and reset the current
11288 line marker so we can report where the unterminated string began
11290 COPLINE_INC_WITH_HERELINES;
11291 PL_bufptr = PL_bufend;
11292 if (!lex_next_chunk(0)) {
11294 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11297 s = start = PL_bufptr;
11300 /* at this point, we have successfully read the delimited string */
11303 sv_catpvn(sv, s, termlen);
11309 PL_multi_end = CopLINE(PL_curcop);
11310 CopLINE_set(PL_curcop, PL_multi_start);
11311 PL_parser->herelines = herelines;
11313 /* if we allocated too much space, give some back */
11314 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11315 SvLEN_set(sv, SvCUR(sv) + 1);
11316 SvPV_renew(sv, SvLEN(sv));
11319 /* decide whether this is the first or second quoted string we've read
11324 PL_parser->lex_sub_repl = sv;
11327 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
11333 takes: pointer to position in buffer
11334 returns: pointer to new position in buffer
11335 side-effects: builds ops for the constant in pl_yylval.op
11337 Read a number in any of the formats that Perl accepts:
11339 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11340 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11341 0b[01](_?[01])* binary integers
11342 0[0-7](_?[0-7])* octal integers
11343 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
11344 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
11346 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11349 If it reads a number without a decimal point or an exponent, it will
11350 try converting the number to an integer and see if it can do so
11351 without loss of precision.
11355 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11357 const char *s = start; /* current position in buffer */
11358 char *d; /* destination in temp buffer */
11359 char *e; /* end of temp buffer */
11360 NV nv; /* number read, as a double */
11361 SV *sv = NULL; /* place to put the converted number */
11362 bool floatit; /* boolean: int or float? */
11363 const char *lastub = NULL; /* position of last underbar */
11364 static const char* const number_too_long = "Number too long";
11365 bool warned_about_underscore = 0;
11366 I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
11367 #define WARN_ABOUT_UNDERSCORE() \
11369 if (!warned_about_underscore) { \
11370 warned_about_underscore = 1; \
11371 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
11372 "Misplaced _ in number"); \
11375 /* Hexadecimal floating point.
11377 * In many places (where we have quads and NV is IEEE 754 double)
11378 * we can fit the mantissa bits of a NV into an unsigned quad.
11379 * (Note that UVs might not be quads even when we have quads.)
11380 * This will not work everywhere, though (either no quads, or
11381 * using long doubles), in which case we have to resort to NV,
11382 * which will probably mean horrible loss of precision due to
11383 * multiple fp operations. */
11384 bool hexfp = FALSE;
11385 int total_bits = 0;
11386 int significant_bits = 0;
11387 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
11388 # define HEXFP_UQUAD
11389 Uquad_t hexfp_uquad = 0;
11390 int hexfp_frac_bits = 0;
11395 NV hexfp_mult = 1.0;
11396 UV high_non_zero = 0; /* highest digit */
11397 int non_zero_integer_digits = 0;
11399 PERL_ARGS_ASSERT_SCAN_NUM;
11401 /* We use the first character to decide what type of number this is */
11405 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
11407 /* if it starts with a 0, it could be an octal number, a decimal in
11408 0.13 disguise, or a hexadecimal number, or a binary number. */
11412 u holds the "number so far"
11413 overflowed was the number more than we can hold?
11415 Shift is used when we add a digit. It also serves as an "are
11416 we in octal/hex/binary?" indicator to disallow hex characters
11417 when in octal mode.
11421 bool overflowed = FALSE;
11422 bool just_zero = TRUE; /* just plain 0 or binary number? */
11423 bool has_digs = FALSE;
11424 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11425 static const char* const bases[5] =
11426 { "", "binary", "", "octal", "hexadecimal" };
11427 static const char* const Bases[5] =
11428 { "", "Binary", "", "Octal", "Hexadecimal" };
11429 static const char* const maxima[5] =
11431 "0b11111111111111111111111111111111",
11435 const char *base, *Base, *max;
11437 /* check for hex */
11438 if (isALPHA_FOLD_EQ(s[1], 'x')) {
11442 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
11447 /* check for a decimal in disguise */
11448 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
11450 /* so it must be octal */
11457 WARN_ABOUT_UNDERSCORE();
11461 base = bases[shift];
11462 Base = Bases[shift];
11463 max = maxima[shift];
11465 /* read the rest of the number */
11467 /* x is used in the overflow test,
11468 b is the digit we're adding on. */
11473 /* if we don't mention it, we're done */
11477 /* _ are ignored -- but warned about if consecutive */
11479 if (lastub && s == lastub + 1)
11480 WARN_ABOUT_UNDERSCORE();
11484 /* 8 and 9 are not octal */
11485 case '8': case '9':
11487 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11491 case '2': case '3': case '4':
11492 case '5': case '6': case '7':
11494 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11497 case '0': case '1':
11498 b = *s++ & 15; /* ASCII digit -> value of digit */
11502 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11503 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11504 /* make sure they said 0x */
11507 b = (*s++ & 7) + 9;
11509 /* Prepare to put the digit we have onto the end
11510 of the number so far. We check for overflows.
11517 assert(shift >= 0);
11518 x = u << shift; /* make room for the digit */
11520 total_bits += shift;
11522 if ((x >> shift) != u
11523 && !(PL_hints & HINT_NEW_BINARY)) {
11526 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11527 "Integer overflow in %s number",
11530 u = x | b; /* add the digit to the end */
11533 n *= nvshift[shift];
11534 /* If an NV has not enough bits in its
11535 * mantissa to represent an UV this summing of
11536 * small low-order numbers is a waste of time
11537 * (because the NV cannot preserve the
11538 * low-order bits anyway): we could just
11539 * remember when did we overflow and in the
11540 * end just multiply n by the right
11545 if (high_non_zero == 0 && b > 0)
11549 non_zero_integer_digits++;
11551 /* this could be hexfp, but peek ahead
11552 * to avoid matching ".." */
11553 if (UNLIKELY(HEXFP_PEEK(s))) {
11561 /* if we get here, we had success: make a scalar value from
11566 /* final misplaced underbar check */
11568 WARN_ABOUT_UNDERSCORE();
11570 if (UNLIKELY(HEXFP_PEEK(s))) {
11571 /* Do sloppy (on the underbars) but quick detection
11572 * (and value construction) for hexfp, the decimal
11573 * detection will shortly be more thorough with the
11574 * underbar checks. */
11576 significant_bits = non_zero_integer_digits * shift;
11579 #else /* HEXFP_NV */
11582 /* Ignore the leading zero bits of
11583 * the high (first) non-zero digit. */
11584 if (high_non_zero) {
11585 if (high_non_zero < 0x8)
11586 significant_bits--;
11587 if (high_non_zero < 0x4)
11588 significant_bits--;
11589 if (high_non_zero < 0x2)
11590 significant_bits--;
11597 bool accumulate = TRUE;
11599 int lim = 1 << shift;
11600 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11602 if (isXDIGIT(*h)) {
11603 significant_bits += shift;
11606 if (significant_bits < NV_MANT_DIG) {
11607 /* We are in the long "run" of xdigits,
11608 * accumulate the full four bits. */
11609 assert(shift >= 0);
11610 hexfp_uquad <<= shift;
11612 hexfp_frac_bits += shift;
11613 } else if (significant_bits - shift < NV_MANT_DIG) {
11614 /* We are at a hexdigit either at,
11615 * or straddling, the edge of mantissa.
11616 * We will try grabbing as many as
11617 * possible bits. */
11619 significant_bits - NV_MANT_DIG;
11623 hexfp_uquad <<= tail;
11624 assert((shift - tail) >= 0);
11625 hexfp_uquad |= b >> (shift - tail);
11626 hexfp_frac_bits += tail;
11628 /* Ignore the trailing zero bits
11629 * of the last non-zero xdigit.
11631 * The assumption here is that if
11632 * one has input of e.g. the xdigit
11633 * eight (0x8), there is only one
11634 * bit being input, not the full
11635 * four bits. Conversely, if one
11636 * specifies a zero xdigit, the
11637 * assumption is that one really
11638 * wants all those bits to be zero. */
11640 if ((b & 0x1) == 0x0) {
11641 significant_bits--;
11642 if ((b & 0x2) == 0x0) {
11643 significant_bits--;
11644 if ((b & 0x4) == 0x0) {
11645 significant_bits--;
11651 accumulate = FALSE;
11654 /* Keep skipping the xdigits, and
11655 * accumulating the significant bits,
11656 * but do not shift the uquad
11657 * (which would catastrophically drop
11658 * high-order bits) or accumulate the
11659 * xdigits anymore. */
11661 #else /* HEXFP_NV */
11663 nv_mult /= nvshift[shift];
11665 hexfp_nv += b * nv_mult;
11667 accumulate = FALSE;
11671 if (significant_bits >= NV_MANT_DIG)
11672 accumulate = FALSE;
11676 if ((total_bits > 0 || significant_bits > 0) &&
11677 isALPHA_FOLD_EQ(*h, 'p')) {
11678 bool negexp = FALSE;
11682 else if (*h == '-') {
11688 while (isDIGIT(*h) || *h == '_') {
11691 hexfp_exp += *h - '0';
11694 && -hexfp_exp < NV_MIN_EXP - 1) {
11695 /* NOTE: this means that the exponent
11696 * underflow warning happens for
11697 * the IEEE 754 subnormals (denormals),
11698 * because DBL_MIN_EXP etc are the lowest
11699 * possible binary (or, rather, DBL_RADIX-base)
11700 * exponent for normals, not subnormals.
11702 * This may or may not be a good thing. */
11703 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11704 "Hexadecimal float: exponent underflow");
11710 && hexfp_exp > NV_MAX_EXP - 1) {
11711 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11712 "Hexadecimal float: exponent overflow");
11720 hexfp_exp = -hexfp_exp;
11722 hexfp_exp -= hexfp_frac_bits;
11724 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11731 if (shift != 3 && !has_digs) {
11732 /* 0x or 0b with no digits, treat it as an error.
11733 Originally this backed up the parse before the b or
11734 x, but that has the potential for silent changes in
11735 behaviour, like for: "0x.3" and "0x+$foo".
11738 char *oldbp = PL_bufptr;
11739 if (*d) ++d; /* so the user sees the bad non-digit */
11740 PL_bufptr = (char *)d; /* so yyerror reports the context */
11741 yyerror(Perl_form(aTHX_ "No digits found for %s literal",
11742 shift == 4 ? "hexadecimal" : "binary"));
11747 if (n > 4294967295.0)
11748 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11749 "%s number > %s non-portable",
11755 if (u > 0xffffffff)
11756 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11757 "%s number > %s non-portable",
11762 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11763 sv = new_constant(start, s - start, "integer",
11764 sv, NULL, NULL, 0, NULL);
11765 else if (PL_hints & HINT_NEW_BINARY)
11766 sv = new_constant(start, s - start, "binary",
11767 sv, NULL, NULL, 0, NULL);
11772 handle decimal numbers.
11773 we're also sent here when we read a 0 as the first digit
11775 case '1': case '2': case '3': case '4': case '5':
11776 case '6': case '7': case '8': case '9': case '.':
11779 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11797 NOT_REACHED; /* NOTREACHED */
11801 /* read next group of digits and _ and copy into d */
11804 || UNLIKELY(hexfp && isXDIGIT(*s)))
11806 /* skip underscores, checking for misplaced ones
11810 if (lastub && s == lastub + 1)
11811 WARN_ABOUT_UNDERSCORE();
11815 /* check for end of fixed-length buffer */
11817 Perl_croak(aTHX_ "%s", number_too_long);
11818 /* if we're ok, copy the character */
11823 /* final misplaced underbar check */
11824 if (lastub && s == lastub + 1)
11825 WARN_ABOUT_UNDERSCORE();
11827 /* read a decimal portion if there is one. avoid
11828 3..5 being interpreted as the number 3. followed
11831 if (*s == '.' && s[1] != '.') {
11836 WARN_ABOUT_UNDERSCORE();
11840 /* copy, ignoring underbars, until we run out of digits.
11844 || UNLIKELY(hexfp && isXDIGIT(*s));
11847 /* fixed length buffer check */
11849 Perl_croak(aTHX_ "%s", number_too_long);
11851 if (lastub && s == lastub + 1)
11852 WARN_ABOUT_UNDERSCORE();
11858 /* fractional part ending in underbar? */
11860 WARN_ABOUT_UNDERSCORE();
11861 if (*s == '.' && isDIGIT(s[1])) {
11862 /* oops, it's really a v-string, but without the "v" */
11868 /* read exponent part, if present */
11869 if ((isALPHA_FOLD_EQ(*s, 'e')
11870 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11871 && memCHRs("+-0123456789_", s[1]))
11873 int exp_digits = 0;
11874 const char *save_s = s;
11877 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11878 ditto for p (hexfloats) */
11879 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11880 /* At least some Mach atof()s don't grok 'E' */
11883 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11890 /* stray preinitial _ */
11892 WARN_ABOUT_UNDERSCORE();
11896 /* allow positive or negative exponent */
11897 if (*s == '+' || *s == '-')
11900 /* stray initial _ */
11902 WARN_ABOUT_UNDERSCORE();
11906 /* read digits of exponent */
11907 while (isDIGIT(*s) || *s == '_') {
11911 Perl_croak(aTHX_ "%s", number_too_long);
11915 if (((lastub && s == lastub + 1)
11916 || (!isDIGIT(s[1]) && s[1] != '_')))
11917 WARN_ABOUT_UNDERSCORE();
11923 /* no exponent digits, the [eEpP] could be for something else,
11924 * though in practice we don't get here for p since that's preparsed
11925 * earlier, and results in only the 0xX being consumed, so behave similarly
11926 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11939 We try to do an integer conversion first if no characters
11940 indicating "float" have been found.
11945 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11947 if (flags == IS_NUMBER_IN_UV) {
11949 sv = newSViv(uv); /* Prefer IVs over UVs. */
11952 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11953 if (uv <= (UV) IV_MIN)
11954 sv = newSViv(-(IV)uv);
11961 /* terminate the string */
11963 if (UNLIKELY(hexfp)) {
11964 # ifdef NV_MANT_DIG
11965 if (significant_bits > NV_MANT_DIG)
11966 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11967 "Hexadecimal float: mantissa overflow");
11970 nv = hexfp_uquad * hexfp_mult;
11971 #else /* HEXFP_NV */
11972 nv = hexfp_nv * hexfp_mult;
11975 nv = Atof(PL_tokenbuf);
11981 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11982 const char *const key = floatit ? "float" : "integer";
11983 const STRLEN keylen = floatit ? 5 : 7;
11984 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11985 key, keylen, sv, NULL, NULL, 0, NULL);
11989 /* if it starts with a v, it could be a v-string */
11992 sv = newSV(5); /* preallocate storage space */
11993 ENTER_with_name("scan_vstring");
11995 s = scan_vstring(s, PL_bufend, sv);
11996 SvREFCNT_inc_simple_void_NN(sv);
11997 LEAVE_with_name("scan_vstring");
12001 /* make the op for the constant and return */
12004 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12006 lvalp->opval = NULL;
12012 S_scan_formline(pTHX_ char *s)
12014 SV * const stuff = newSVpvs("");
12015 bool needargs = FALSE;
12016 bool eofmt = FALSE;
12018 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12020 while (!needargs) {
12024 #ifdef PERL_STRICT_CR
12025 while (SPACE_OR_TAB(*t))
12028 while (SPACE_OR_TAB(*t) || *t == '\r')
12031 if (*t == '\n' || t == PL_bufend) {
12036 eol = (char *) memchr(s,'\n',PL_bufend-s);
12041 for (t = s; t < eol; t++) {
12042 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12044 goto enough; /* ~~ must be first line in formline */
12046 if (*t == '@' || *t == '^')
12050 sv_catpvn(stuff, s, eol-s);
12051 #ifndef PERL_STRICT_CR
12052 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12053 char *end = SvPVX(stuff) + SvCUR(stuff);
12056 SvCUR_set(stuff, SvCUR(stuff) - 1);
12064 if ((PL_rsfp || PL_parser->filtered)
12065 && PL_parser->form_lex_state == LEX_NORMAL) {
12067 PL_bufptr = PL_bufend;
12068 COPLINE_INC_WITH_HERELINES;
12069 got_some = lex_next_chunk(0);
12070 CopLINE_dec(PL_curcop);
12075 incline(s, PL_bufend);
12078 if (!SvCUR(stuff) || needargs)
12079 PL_lex_state = PL_parser->form_lex_state;
12080 if (SvCUR(stuff)) {
12081 PL_expect = XSTATE;
12083 const char *s2 = s;
12084 while (isSPACE(*s2) && *s2 != '\n')
12087 PL_expect = XTERMBLOCK;
12088 NEXTVAL_NEXTTOKE.ival = 0;
12091 NEXTVAL_NEXTTOKE.ival = 0;
12092 force_next(FORMLBRACK);
12095 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12098 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
12102 SvREFCNT_dec(stuff);
12104 PL_lex_formbrack = 0;
12110 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12112 const I32 oldsavestack_ix = PL_savestack_ix;
12113 CV* const outsidecv = PL_compcv;
12115 SAVEI32(PL_subline);
12116 save_item(PL_subname);
12117 SAVESPTR(PL_compcv);
12119 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12120 CvFLAGS(PL_compcv) |= flags;
12122 PL_subline = CopLINE(PL_curcop);
12123 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12124 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12125 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12126 if (outsidecv && CvPADLIST(outsidecv))
12127 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
12129 return oldsavestack_ix;
12133 /* Do extra initialisation of a CV (typically one just created by
12134 * start_subparse()) if that CV is for a named sub
12138 Perl_init_named_cv(pTHX_ CV *cv, OP *nameop)
12140 PERL_ARGS_ASSERT_INIT_NAMED_CV;
12142 if (nameop->op_type == OP_CONST) {
12143 const char *const name = SvPV_nolen_const(((SVOP*)nameop)->op_sv);
12144 if ( strEQ(name, "BEGIN")
12145 || strEQ(name, "END")
12146 || strEQ(name, "INIT")
12147 || strEQ(name, "CHECK")
12148 || strEQ(name, "UNITCHECK")
12153 /* State subs inside anonymous subs need to be
12154 clonable themselves. */
12155 if ( CvANON(CvOUTSIDE(cv))
12156 || CvCLONE(CvOUTSIDE(cv))
12157 || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
12159 ))[nameop->op_targ])
12166 S_yywarn(pTHX_ const char *const s, U32 flags)
12168 PERL_ARGS_ASSERT_YYWARN;
12170 PL_in_eval |= EVAL_WARNONLY;
12171 yyerror_pv(s, flags);
12176 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
12178 PERL_ARGS_ASSERT_ABORT_EXECUTION;
12181 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
12184 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
12186 NOT_REACHED; /* NOTREACHED */
12192 /* Called, after at least one error has been found, to abort the parse now,
12193 * instead of trying to forge ahead */
12195 yyerror_pvn(NULL, 0, 0);
12199 Perl_yyerror(pTHX_ const char *const s)
12201 PERL_ARGS_ASSERT_YYERROR;
12202 return yyerror_pvn(s, strlen(s), 0);
12206 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
12208 PERL_ARGS_ASSERT_YYERROR_PV;
12209 return yyerror_pvn(s, strlen(s), flags);
12213 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
12215 const char *context = NULL;
12218 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
12219 int yychar = PL_parser->yychar;
12221 /* Output error message 's' with length 'len'. 'flags' are SV flags that
12222 * apply. If the number of errors found is large enough, it abandons
12223 * parsing. If 's' is NULL, there is no message, and it abandons
12224 * processing unconditionally */
12227 if (!yychar || (yychar == ';' && !PL_rsfp))
12228 sv_catpvs(where_sv, "at EOF");
12229 else if ( PL_oldoldbufptr
12230 && PL_bufptr > PL_oldoldbufptr
12231 && PL_bufptr - PL_oldoldbufptr < 200
12232 && PL_oldoldbufptr != PL_oldbufptr
12233 && PL_oldbufptr != PL_bufptr)
12237 The code below is removed for NetWare because it
12238 abends/crashes on NetWare when the script has error such as
12239 not having the closing quotes like:
12240 if ($var eq "value)
12241 Checking of white spaces is anyway done in NetWare code.
12244 while (isSPACE(*PL_oldoldbufptr))
12247 context = PL_oldoldbufptr;
12248 contlen = PL_bufptr - PL_oldoldbufptr;
12250 else if ( PL_oldbufptr
12251 && PL_bufptr > PL_oldbufptr
12252 && PL_bufptr - PL_oldbufptr < 200
12253 && PL_oldbufptr != PL_bufptr) {
12256 The code below is removed for NetWare because it
12257 abends/crashes on NetWare when the script has error such as
12258 not having the closing quotes like:
12259 if ($var eq "value)
12260 Checking of white spaces is anyway done in NetWare code.
12263 while (isSPACE(*PL_oldbufptr))
12266 context = PL_oldbufptr;
12267 contlen = PL_bufptr - PL_oldbufptr;
12269 else if (yychar > 255)
12270 sv_catpvs(where_sv, "next token ???");
12271 else if (yychar == YYEMPTY) {
12272 if (PL_lex_state == LEX_NORMAL)
12273 sv_catpvs(where_sv, "at end of line");
12274 else if (PL_lex_inpat)
12275 sv_catpvs(where_sv, "within pattern");
12277 sv_catpvs(where_sv, "within string");
12280 sv_catpvs(where_sv, "next char ");
12282 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12283 else if (isPRINT_LC(yychar)) {
12284 const char string = yychar;
12285 sv_catpvn(where_sv, &string, 1);
12288 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12290 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
12291 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
12292 OutCopFILE(PL_curcop),
12293 (IV)(PL_parser->preambling == NOLINE
12294 ? CopLINE(PL_curcop)
12295 : PL_parser->preambling));
12297 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
12298 UTF8fARG(UTF, contlen, context));
12300 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
12301 if ( PL_multi_start < PL_multi_end
12302 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
12304 Perl_sv_catpvf(aTHX_ msg,
12305 " (Might be a runaway multi-line %c%c string starting on"
12306 " line %" IVdf ")\n",
12307 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12310 if (PL_in_eval & EVAL_WARNONLY) {
12311 PL_in_eval &= ~EVAL_WARNONLY;
12312 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
12318 if (s == NULL || PL_error_count >= 10) {
12319 const char * msg = "";
12320 const char * const name = OutCopFILE(PL_curcop);
12323 SV * errsv = ERRSV;
12324 if (SvCUR(errsv)) {
12325 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
12330 abort_execution(msg, name);
12333 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
12337 PL_in_my_stash = NULL;
12342 S_swallow_bom(pTHX_ U8 *s)
12344 const STRLEN slen = SvCUR(PL_linestr);
12346 PERL_ARGS_ASSERT_SWALLOW_BOM;
12350 if (s[1] == 0xFE) {
12351 /* UTF-16 little-endian? (or UTF-32LE?) */
12352 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12353 /* diag_listed_as: Unsupported script encoding %s */
12354 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
12355 #ifndef PERL_NO_UTF16_FILTER
12357 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
12360 if (PL_bufend > (char*)s) {
12361 s = add_utf16_textfilter(s, TRUE);
12364 /* diag_listed_as: Unsupported script encoding %s */
12365 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
12370 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12371 #ifndef PERL_NO_UTF16_FILTER
12373 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12376 if (PL_bufend > (char *)s) {
12377 s = add_utf16_textfilter(s, FALSE);
12380 /* diag_listed_as: Unsupported script encoding %s */
12381 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
12385 case BOM_UTF8_FIRST_BYTE: {
12386 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
12388 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12390 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
12397 if (s[2] == 0xFE && s[3] == 0xFF) {
12398 /* UTF-32 big-endian */
12399 /* diag_listed_as: Unsupported script encoding %s */
12400 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
12403 else if (s[2] == 0 && s[3] != 0) {
12406 * are a good indicator of UTF-16BE. */
12407 #ifndef PERL_NO_UTF16_FILTER
12409 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12411 s = add_utf16_textfilter(s, FALSE);
12413 /* diag_listed_as: Unsupported script encoding %s */
12414 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
12421 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12424 * are a good indicator of UTF-16LE. */
12425 #ifndef PERL_NO_UTF16_FILTER
12427 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12429 s = add_utf16_textfilter(s, TRUE);
12431 /* diag_listed_as: Unsupported script encoding %s */
12432 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
12440 #ifndef PERL_NO_UTF16_FILTER
12442 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12444 SV *const filter = FILTER_DATA(idx);
12445 /* We re-use this each time round, throwing the contents away before we
12447 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
12448 SV *const utf8_buffer = filter;
12449 IV status = IoPAGE(filter);
12450 const bool reverse = cBOOL(IoLINES(filter));
12453 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
12455 /* As we're automatically added, at the lowest level, and hence only called
12456 from this file, we can be sure that we're not called in block mode. Hence
12457 don't bother writing code to deal with block mode. */
12459 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
12462 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
12464 DEBUG_P(PerlIO_printf(Perl_debug_log,
12465 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12466 FPTR2DPTR(void *, S_utf16_textfilter),
12467 reverse ? 'l' : 'b', idx, maxlen, status,
12468 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12475 /* First, look in our buffer of existing UTF-8 data: */
12476 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
12480 } else if (status == 0) {
12482 IoPAGE(filter) = 0;
12483 nl = SvEND(utf8_buffer);
12486 STRLEN got = nl - SvPVX(utf8_buffer);
12487 /* Did we have anything to append? */
12489 sv_catpvn(sv, SvPVX(utf8_buffer), got);
12490 /* Everything else in this code works just fine if SVp_POK isn't
12491 set. This, however, needs it, and we need it to work, else
12492 we loop infinitely because the buffer is never consumed. */
12493 sv_chop(utf8_buffer, nl);
12497 /* OK, not a complete line there, so need to read some more UTF-16.
12498 Read an extra octect if the buffer currently has an odd number. */
12502 if (SvCUR(utf16_buffer) >= 2) {
12503 /* Location of the high octet of the last complete code point.
12504 Gosh, UTF-16 is a pain. All the benefits of variable length,
12505 *coupled* with all the benefits of partial reads and
12507 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
12508 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
12510 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
12514 /* We have the first half of a surrogate. Read more. */
12515 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
12518 status = FILTER_READ(idx + 1, utf16_buffer,
12519 160 + (SvCUR(utf16_buffer) & 1));
12520 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
12521 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
12524 IoPAGE(filter) = status;
12529 /* 'chars' isn't quite the right name, as code points above 0xFFFF
12530 * require 4 bytes per char */
12531 chars = SvCUR(utf16_buffer) >> 1;
12532 have = SvCUR(utf8_buffer);
12534 /* Assume the worst case size as noted by the functions: twice the
12535 * number of input bytes */
12536 SvGROW(utf8_buffer, have + chars * 4 + 1);
12539 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12540 (U8*)SvPVX_const(utf8_buffer) + have,
12541 chars * 2, &newlen);
12543 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12544 (U8*)SvPVX_const(utf8_buffer) + have,
12545 chars * 2, &newlen);
12547 SvCUR_set(utf8_buffer, have + newlen);
12550 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12551 it's private to us, and utf16_to_utf8{,reversed} take a
12552 (pointer,length) pair, rather than a NUL-terminated string. */
12553 if(SvCUR(utf16_buffer) & 1) {
12554 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12555 SvCUR_set(utf16_buffer, 1);
12557 SvCUR_set(utf16_buffer, 0);
12560 DEBUG_P(PerlIO_printf(Perl_debug_log,
12561 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12563 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12564 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12569 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12571 SV *filter = filter_add(S_utf16_textfilter, NULL);
12573 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12575 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12577 IoLINES(filter) = reversed;
12578 IoPAGE(filter) = 1; /* Not EOF */
12580 /* Sadly, we have to return a valid pointer, come what may, so we have to
12581 ignore any error return from this. */
12582 SvCUR_set(PL_linestr, 0);
12583 if (FILTER_READ(0, PL_linestr, 0)) {
12584 SvUTF8_on(PL_linestr);
12586 SvUTF8_on(PL_linestr);
12588 PL_bufend = SvEND(PL_linestr);
12589 return (U8*)SvPVX(PL_linestr);
12594 Returns a pointer to the next character after the parsed
12595 vstring, as well as updating the passed in sv.
12597 Function must be called like
12599 sv = sv_2mortal(newSV(5));
12600 s = scan_vstring(s,e,sv);
12602 where s and e are the start and end of the string.
12603 The sv should already be large enough to store the vstring
12604 passed in, for performance reasons.
12606 This function may croak if fatal warnings are enabled in the
12607 calling scope, hence the sv_2mortal in the example (to prevent
12608 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12614 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12616 const char *pos = s;
12617 const char *start = s;
12619 PERL_ARGS_ASSERT_SCAN_VSTRING;
12621 if (*pos == 'v') pos++; /* get past 'v' */
12622 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12624 if ( *pos != '.') {
12625 /* this may not be a v-string if followed by => */
12626 const char *next = pos;
12627 while (next < e && isSPACE(*next))
12629 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12630 /* return string not v-string */
12631 sv_setpvn(sv,(char *)s,pos-s);
12632 return (char *)pos;
12636 if (!isALPHA(*pos)) {
12637 U8 tmpbuf[UTF8_MAXBYTES+1];
12640 s++; /* get past 'v' */
12645 /* this is atoi() that tolerates underscores */
12648 const char *end = pos;
12650 while (--end >= s) {
12652 const UV orev = rev;
12653 rev += (*end - '0') * mult;
12656 /* diag_listed_as: Integer overflow in %s number */
12657 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12658 "Integer overflow in decimal number");
12662 /* Append native character for the rev point */
12663 tmpend = uvchr_to_utf8(tmpbuf, rev);
12664 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12665 if (!UVCHR_IS_INVARIANT(rev))
12667 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12673 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12677 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12684 Perl_keyword_plugin_standard(pTHX_
12685 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12687 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12688 PERL_UNUSED_CONTEXT;
12689 PERL_UNUSED_ARG(keyword_ptr);
12690 PERL_UNUSED_ARG(keyword_len);
12691 PERL_UNUSED_ARG(op_ptr);
12692 return KEYWORD_PLUGIN_DECLINE;
12696 =for apidoc wrap_keyword_plugin
12698 Puts a C function into the chain of keyword plugins. This is the
12699 preferred way to manipulate the L</PL_keyword_plugin> variable.
12700 C<new_plugin> is a pointer to the C function that is to be added to the
12701 keyword plugin chain, and C<old_plugin_p> points to the storage location
12702 where a pointer to the next function in the chain will be stored. The
12703 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12704 while the value previously stored there is written to C<*old_plugin_p>.
12706 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12707 to hook keyword parsing may find itself invoked more than once per
12708 process, typically in different threads. To handle that situation, this
12709 function is idempotent. The location C<*old_plugin_p> must initially
12710 (once per process) contain a null pointer. A C variable of static
12711 duration (declared at file scope, typically also marked C<static> to give
12712 it internal linkage) will be implicitly initialised appropriately, if it
12713 does not have an explicit initialiser. This function will only actually
12714 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12715 function is also thread safe on the small scale. It uses appropriate
12716 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12718 When this function is called, the function referenced by C<new_plugin>
12719 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12720 In a threading situation, C<new_plugin> may be called immediately, even
12721 before this function has returned. C<*old_plugin_p> will always be
12722 appropriately set before C<new_plugin> is called. If C<new_plugin>
12723 decides not to do anything special with the identifier that it is given
12724 (which is the usual case for most calls to a keyword plugin), it must
12725 chain the plugin function referenced by C<*old_plugin_p>.
12727 Taken all together, XS code to install a keyword plugin should typically
12728 look something like this:
12730 static Perl_keyword_plugin_t next_keyword_plugin;
12731 static OP *my_keyword_plugin(pTHX_
12732 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12734 if (memEQs(keyword_ptr, keyword_len,
12735 "my_new_keyword")) {
12738 return next_keyword_plugin(aTHX_
12739 keyword_ptr, keyword_len, op_ptr);
12743 wrap_keyword_plugin(my_keyword_plugin,
12744 &next_keyword_plugin);
12746 Direct access to L</PL_keyword_plugin> should be avoided.
12752 Perl_wrap_keyword_plugin(pTHX_
12753 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12757 PERL_UNUSED_CONTEXT;
12758 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12759 if (*old_plugin_p) return;
12760 KEYWORD_PLUGIN_MUTEX_LOCK;
12761 if (!*old_plugin_p) {
12762 *old_plugin_p = PL_keyword_plugin;
12763 PL_keyword_plugin = new_plugin;
12765 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12768 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12770 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12772 SAVEI32(PL_lex_brackets);
12773 if (PL_lex_brackets > 100)
12774 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12775 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12776 SAVEI32(PL_lex_allbrackets);
12777 PL_lex_allbrackets = 0;
12778 SAVEI8(PL_lex_fakeeof);
12779 PL_lex_fakeeof = (U8)fakeeof;
12780 if(yyparse(gramtype) && !PL_parser->error_count)
12781 qerror(Perl_mess(aTHX_ "Parse error"));
12784 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12786 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12790 SAVEVPTR(PL_eval_root);
12791 PL_eval_root = NULL;
12792 parse_recdescent(gramtype, fakeeof);
12798 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12800 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12803 if (flags & ~PARSE_OPTIONAL)
12804 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12805 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12806 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12807 if (!PL_parser->error_count)
12808 qerror(Perl_mess(aTHX_ "Parse error"));
12809 exprop = newOP(OP_NULL, 0);
12815 =for apidoc parse_arithexpr
12817 Parse a Perl arithmetic expression. This may contain operators of precedence
12818 down to the bit shift operators. The expression must be followed (and thus
12819 terminated) either by a comparison or lower-precedence operator or by
12820 something that would normally terminate an expression such as semicolon.
12821 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12822 otherwise it is mandatory. It is up to the caller to ensure that the
12823 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12824 the source of the code to be parsed and the lexical context for the
12827 The op tree representing the expression is returned. If an optional
12828 expression is absent, a null pointer is returned, otherwise the pointer
12831 If an error occurs in parsing or compilation, in most cases a valid op
12832 tree is returned anyway. The error is reflected in the parser state,
12833 normally resulting in a single exception at the top level of parsing
12834 which covers all the compilation errors that occurred. Some compilation
12835 errors, however, will throw an exception immediately.
12837 =for apidoc Amnh||PARSE_OPTIONAL
12844 Perl_parse_arithexpr(pTHX_ U32 flags)
12846 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12850 =for apidoc parse_termexpr
12852 Parse a Perl term expression. This may contain operators of precedence
12853 down to the assignment operators. The expression must be followed (and thus
12854 terminated) either by a comma or lower-precedence operator or by
12855 something that would normally terminate an expression such as semicolon.
12856 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12857 otherwise it is mandatory. It is up to the caller to ensure that the
12858 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12859 the source of the code to be parsed and the lexical context for the
12862 The op tree representing the expression is returned. If an optional
12863 expression is absent, a null pointer is returned, otherwise the pointer
12866 If an error occurs in parsing or compilation, in most cases a valid op
12867 tree is returned anyway. The error is reflected in the parser state,
12868 normally resulting in a single exception at the top level of parsing
12869 which covers all the compilation errors that occurred. Some compilation
12870 errors, however, will throw an exception immediately.
12876 Perl_parse_termexpr(pTHX_ U32 flags)
12878 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12882 =for apidoc parse_listexpr
12884 Parse a Perl list expression. This may contain operators of precedence
12885 down to the comma operator. The expression must be followed (and thus
12886 terminated) either by a low-precedence logic operator such as C<or> or by
12887 something that would normally terminate an expression such as semicolon.
12888 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12889 otherwise it is mandatory. It is up to the caller to ensure that the
12890 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12891 the source of the code to be parsed and the lexical context for the
12894 The op tree representing the expression is returned. If an optional
12895 expression is absent, a null pointer is returned, otherwise the pointer
12898 If an error occurs in parsing or compilation, in most cases a valid op
12899 tree is returned anyway. The error is reflected in the parser state,
12900 normally resulting in a single exception at the top level of parsing
12901 which covers all the compilation errors that occurred. Some compilation
12902 errors, however, will throw an exception immediately.
12908 Perl_parse_listexpr(pTHX_ U32 flags)
12910 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12914 =for apidoc parse_fullexpr
12916 Parse a single complete Perl expression. This allows the full
12917 expression grammar, including the lowest-precedence operators such
12918 as C<or>. The expression must be followed (and thus terminated) by a
12919 token that an expression would normally be terminated by: end-of-file,
12920 closing bracketing punctuation, semicolon, or one of the keywords that
12921 signals a postfix expression-statement modifier. If C<flags> has the
12922 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12923 mandatory. It is up to the caller to ensure that the dynamic parser
12924 state (L</PL_parser> et al) is correctly set to reflect the source of
12925 the code to be parsed and the lexical context for the expression.
12927 The op tree representing the expression is returned. If an optional
12928 expression is absent, a null pointer is returned, otherwise the pointer
12931 If an error occurs in parsing or compilation, in most cases a valid op
12932 tree is returned anyway. The error is reflected in the parser state,
12933 normally resulting in a single exception at the top level of parsing
12934 which covers all the compilation errors that occurred. Some compilation
12935 errors, however, will throw an exception immediately.
12941 Perl_parse_fullexpr(pTHX_ U32 flags)
12943 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12947 =for apidoc parse_block
12949 Parse a single complete Perl code block. This consists of an opening
12950 brace, a sequence of statements, and a closing brace. The block
12951 constitutes a lexical scope, so C<my> variables and various compile-time
12952 effects can be contained within it. It is up to the caller to ensure
12953 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12954 reflect the source of the code to be parsed and the lexical context for
12957 The op tree representing the code block is returned. This is always a
12958 real op, never a null pointer. It will normally be a C<lineseq> list,
12959 including C<nextstate> or equivalent ops. No ops to construct any kind
12960 of runtime scope are included by virtue of it being a block.
12962 If an error occurs in parsing or compilation, in most cases a valid op
12963 tree (most likely null) is returned anyway. The error is reflected in
12964 the parser state, normally resulting in a single exception at the top
12965 level of parsing which covers all the compilation errors that occurred.
12966 Some compilation errors, however, will throw an exception immediately.
12968 The C<flags> parameter is reserved for future use, and must always
12975 Perl_parse_block(pTHX_ U32 flags)
12978 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12979 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12983 =for apidoc parse_barestmt
12985 Parse a single unadorned Perl statement. This may be a normal imperative
12986 statement or a declaration that has compile-time effect. It does not
12987 include any label or other affixture. It is up to the caller to ensure
12988 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12989 reflect the source of the code to be parsed and the lexical context for
12992 The op tree representing the statement is returned. This may be a
12993 null pointer if the statement is null, for example if it was actually
12994 a subroutine definition (which has compile-time side effects). If not
12995 null, it will be ops directly implementing the statement, suitable to
12996 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12997 equivalent op (except for those embedded in a scope contained entirely
12998 within the statement).
13000 If an error occurs in parsing or compilation, in most cases a valid op
13001 tree (most likely null) is returned anyway. The error is reflected in
13002 the parser state, normally resulting in a single exception at the top
13003 level of parsing which covers all the compilation errors that occurred.
13004 Some compilation errors, however, will throw an exception immediately.
13006 The C<flags> parameter is reserved for future use, and must always
13013 Perl_parse_barestmt(pTHX_ U32 flags)
13016 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
13017 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
13021 =for apidoc parse_label
13023 Parse a single label, possibly optional, of the type that may prefix a
13024 Perl statement. It is up to the caller to ensure that the dynamic parser
13025 state (L</PL_parser> et al) is correctly set to reflect the source of
13026 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
13027 label is optional, otherwise it is mandatory.
13029 The name of the label is returned in the form of a fresh scalar. If an
13030 optional label is absent, a null pointer is returned.
13032 If an error occurs in parsing, which can only occur if the label is
13033 mandatory, a valid label is returned anyway. The error is reflected in
13034 the parser state, normally resulting in a single exception at the top
13035 level of parsing which covers all the compilation errors that occurred.
13041 Perl_parse_label(pTHX_ U32 flags)
13043 if (flags & ~PARSE_OPTIONAL)
13044 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
13046 PL_parser->yychar = yylex();
13047 if (PL_parser->yychar == LABEL) {
13048 SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv;
13049 PL_parser->yychar = YYEMPTY;
13050 cSVOPx(pl_yylval.opval)->op_sv = NULL;
13051 op_free(pl_yylval.opval);
13059 STRLEN wlen, bufptr_pos;
13062 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
13064 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
13065 if (word_takes_any_delimiter(s, wlen))
13067 bufptr_pos = s - SvPVX(PL_linestr);
13069 lex_read_space(LEX_KEEP_PREVIOUS);
13071 s = SvPVX(PL_linestr) + bufptr_pos;
13072 if (t[0] == ':' && t[1] != ':') {
13073 PL_oldoldbufptr = PL_oldbufptr;
13076 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
13080 if (flags & PARSE_OPTIONAL) {
13083 qerror(Perl_mess(aTHX_ "Parse error"));
13084 return newSVpvs("x");
13091 =for apidoc parse_fullstmt
13093 Parse a single complete Perl statement. This may be a normal imperative
13094 statement or a declaration that has compile-time effect, and may include
13095 optional labels. It is up to the caller to ensure that the dynamic
13096 parser state (L</PL_parser> et al) is correctly set to reflect the source
13097 of the code to be parsed and the lexical context for the statement.
13099 The op tree representing the statement is returned. This may be a
13100 null pointer if the statement is null, for example if it was actually
13101 a subroutine definition (which has compile-time side effects). If not
13102 null, it will be the result of a L</newSTATEOP> call, normally including
13103 a C<nextstate> or equivalent op.
13105 If an error occurs in parsing or compilation, in most cases a valid op
13106 tree (most likely null) is returned anyway. The error is reflected in
13107 the parser state, normally resulting in a single exception at the top
13108 level of parsing which covers all the compilation errors that occurred.
13109 Some compilation errors, however, will throw an exception immediately.
13111 The C<flags> parameter is reserved for future use, and must always
13118 Perl_parse_fullstmt(pTHX_ U32 flags)
13121 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
13122 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
13126 =for apidoc parse_stmtseq
13128 Parse a sequence of zero or more Perl statements. These may be normal
13129 imperative statements, including optional labels, or declarations
13130 that have compile-time effect, or any mixture thereof. The statement
13131 sequence ends when a closing brace or end-of-file is encountered in a
13132 place where a new statement could have validly started. It is up to
13133 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
13134 is correctly set to reflect the source of the code to be parsed and the
13135 lexical context for the statements.
13137 The op tree representing the statement sequence is returned. This may
13138 be a null pointer if the statements were all null, for example if there
13139 were no statements or if there were only subroutine definitions (which
13140 have compile-time side effects). If not null, it will be a C<lineseq>
13141 list, normally including C<nextstate> or equivalent ops.
13143 If an error occurs in parsing or compilation, in most cases a valid op
13144 tree is returned anyway. The error is reflected in the parser state,
13145 normally resulting in a single exception at the top level of parsing
13146 which covers all the compilation errors that occurred. Some compilation
13147 errors, however, will throw an exception immediately.
13149 The C<flags> parameter is reserved for future use, and must always
13156 Perl_parse_stmtseq(pTHX_ U32 flags)
13161 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
13162 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
13163 c = lex_peek_unichar(0);
13164 if (c != -1 && c != /*{*/'}')
13165 qerror(Perl_mess(aTHX_ "Parse error"));
13170 =for apidoc parse_subsignature
13172 Parse a subroutine signature declaration. This is the contents of the
13173 parentheses following a named or anonymous subroutine declaration when the
13174 C<signatures> feature is enabled. Note that this function neither expects
13175 nor consumes the opening and closing parentheses around the signature; it
13176 is the caller's job to handle these.
13178 This function must only be called during parsing of a subroutine; after
13179 L</start_subparse> has been called. It might allocate lexical variables on
13180 the pad for the current subroutine.
13182 The op tree to unpack the arguments from the stack at runtime is returned.
13183 This op tree should appear at the beginning of the compiled function. The
13184 caller may wish to use L</op_append_list> to build their function body
13185 after it, or splice it together with the body before calling L</newATTRSUB>.
13187 The C<flags> parameter is reserved for future use, and must always
13194 Perl_parse_subsignature(pTHX_ U32 flags)
13197 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_subsignature");
13198 return parse_recdescent_for_op(GRAMSUBSIGNATURE, LEX_FAKEEOF_NONEXPR);
13202 * ex: set ts=8 sts=4 sw=4 et: